src/Pure/Thy/thy_info.ML
changeset 23974 16ecf0a5a6bb
parent 23967 92130b24e87f
child 23982 e3c4c0b9ae05
equal deleted inserted replaced
23973:b6ce6de5b700 23974:16ecf0a5a6bb
   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;