360 in (current, deps', parents) end |
360 in (current, deps', parents) end |
361 end); |
361 end); |
362 |
362 |
363 in |
363 in |
364 |
364 |
365 fun require_thys really ml time strict keep_strict initiators dir strs tasks_visited = |
365 fun require_thys really ml time strict keep_strict initiators dir strs tasks = |
366 fold_map (require_thy really ml time strict keep_strict initiators dir) strs tasks_visited |
366 fold_map (require_thy really ml time strict keep_strict initiators dir) strs tasks |
367 |>> forall I |
367 |>> forall I |
368 and require_thy really ml time strict keep_strict initiators dir str (tasks, visited) = |
368 and require_thy really ml time strict keep_strict initiators dir str tasks = |
369 let |
369 let |
370 val path = Path.expand (Path.explode str); |
370 val path = Path.expand (Path.explode str); |
371 val name = Path.implode (Path.base path); |
371 val name = Path.implode (Path.base path); |
372 val dir' = Path.append dir (Path.dir path); |
372 val dir' = Path.append dir (Path.dir path); |
373 val _ = member (op =) initiators name andalso error (cycle_msg initiators); |
373 val _ = member (op =) initiators name andalso error (cycle_msg initiators); |
374 in |
374 in |
375 (case AList.lookup (op =) visited name of |
375 (case try (Graph.get_node (fst tasks)) name of |
376 SOME current => (current, (tasks, visited)) |
376 SOME task => (is_none task, tasks) |
377 | NONE => |
377 | NONE => |
378 let |
378 let |
379 val (current, deps, parents) = check_deps ml strict dir' name |
379 val (current, deps, parents) = check_deps ml strict dir' name |
380 handle ERROR msg => cat_error msg |
380 handle ERROR msg => cat_error msg |
381 (loader_msg "the error(s) above occurred while examining theory" [name] ^ |
381 (loader_msg "the error(s) above occurred while examining theory" [name] ^ |
382 required_by "\n" initiators); |
382 required_by "\n" initiators); |
383 val parent_names = map base_name parents; |
383 val parent_names = map base_name parents; |
384 |
384 |
385 val (parents_current, (tasks', visited')) = |
385 val (parents_current, (tasks_graph', tasks_len')) = |
386 require_thys true true time (strict andalso keep_strict) keep_strict |
386 require_thys true true time (strict andalso keep_strict) keep_strict |
387 (name :: initiators) (Path.append dir (master_dir' deps)) |
387 (name :: initiators) (Path.append dir (master_dir' deps)) parents tasks; |
388 parents (tasks, visited); |
|
389 |
388 |
390 val all_current = current andalso parents_current; |
389 val all_current = current andalso parents_current; |
391 val thy = if all_current orelse not really then SOME (get_theory name) else NONE; |
390 val thy = if all_current orelse not really then SOME (get_theory name) else NONE; |
392 val _ = change_thys (new_deps name parent_names (deps, thy)); |
391 val _ = change_thys (new_deps name parent_names (deps, thy)); |
393 |
392 |
394 val tasks'' = tasks' |> new_deps name parent_names |
393 val tasks_graph'' = tasks_graph' |> new_deps name parent_names |
395 (fn () => if all_current then () else load_thy really ml time initiators dir' name); |
394 (if all_current then NONE |
396 val visited'' = (name, all_current) :: visited'; |
395 else SOME (fn () => load_thy really ml time initiators dir' name)); |
397 in (all_current, (tasks'', visited'')) end) |
396 val tasks_len'' = if all_current then tasks_len' else tasks_len' + 1; |
|
397 in (all_current, (tasks_graph'', tasks_len'')) end) |
398 end; |
398 end; |
399 |
399 |
400 end; |
400 end; |
401 |
401 |
402 |
402 |
403 (* variations on use_thy *) |
403 (* use_thy etc. -- scheduling required theories *) |
404 |
404 |
405 local |
405 local |
406 |
406 |
407 fun schedule_seq tasks = |
407 fun schedule_seq tasks = |
408 Graph.topological_order tasks |> List.app (fn name => Graph.get_node tasks name ()); |
408 Graph.topological_order tasks |
409 |
409 |> List.app (fn name => the_default I (Graph.get_node tasks name) ()); |
410 fun schedule_tasks tasks = |
410 |
411 let val m = ! Multithreading.number_of_threads in |
411 fun next_task (SOME f :: fs, G) = (SOME f, (fs, G)) |
412 if m <= 1 then schedule_seq tasks |
412 | next_task (NONE :: fs, G) = next_task (fs, G) |
|
413 | next_task ([], G) = |
|
414 (case Graph.minimals G of |
|
415 [] => (NONE, ([], G)) |
|
416 | ms => next_task (map (Graph.get_node G) ms, Graph.del_nodes ms G)); |
|
417 |
|
418 fun schedule_tasks (tasks, n) = |
|
419 let val m = ! Multithreading.max_threads in |
|
420 if m <= 1 orelse n <= 1 then schedule_seq tasks |
413 else if Multithreading.self_critical () then |
421 else if Multithreading.self_critical () then |
414 (warning (loader_msg "no multithreading within critical section" []); |
422 (warning (loader_msg "no multithreading within critical section" []); |
415 schedule_seq tasks) |
423 schedule_seq tasks) |
416 else sys_error "No multithreading scheduler yet" |
424 else |
|
425 (case Multithreading.schedule (Int.min (m, n)) next_task ([], tasks) of |
|
426 [] => () |
|
427 | exns => raise Exn.EXCEPTIONS (exns, "")) |
417 end; |
428 end; |
418 |
429 |
419 fun gen_use_thy' req dir arg = Output.toplevel_errors (fn () => |
430 fun gen_use_thy' req dir arg = Output.toplevel_errors (fn () => |
420 let val (_, (tasks, _)) = req [] dir arg (Graph.empty, []) |
431 let val (_, tasks) = req [] dir arg (Graph.empty, 0) |
421 in schedule_tasks tasks end) (); |
432 in schedule_tasks tasks end) (); |
422 |
433 |
423 fun gen_use_thy req str = |
434 fun gen_use_thy req str = |
424 let val name = base_name str in |
435 let val name = base_name str in |
425 check_unfinished warning name; |
436 check_unfinished warning name; |