simplified/clarified theory loader: more explicit task management, kill old versions at start, commit results only in the very end, non-optional master dependency, do not store text in deps;
authorwenzelm
Tue, 27 Jul 2010 22:00:26 +0200
changeset 37977 3ceccd415145
parent 37976 ce2ea240895c
child 37978 548f3f165d05
simplified/clarified theory loader: more explicit task management, kill old versions at start, commit results only in the very end, non-optional master dependency, do not store text in deps; explicit Thy_Info.toplevel_begin_theory, which does not maintain theory loader database; Outer_Syntax.load_thy: modify Toplevel.init for theory loading, and avoid slightly odd implicit batch mode of 'theory' command; added Thy_Load.begin_theory for clarity; structure ProofGeneral.ThyLoad.add_path appears to be old ThyLoad.add_path to Proof General, but actually operates on new Thy_Load.master_path instead -- for more precise imitation of theory loader; moved some basic commands from isar_cmd.ML to isar_syn.ML; misc tuning and simplification;
src/Pure/General/secure.ML
src/Pure/Isar/isar_cmd.ML
src/Pure/Isar/isar_syn.ML
src/Pure/Isar/outer_syntax.ML
src/Pure/Isar/toplevel.ML
src/Pure/ProofGeneral/proof_general_emacs.ML
src/Pure/ProofGeneral/proof_general_pgip.ML
src/Pure/Thy/thy_info.ML
src/Pure/Thy/thy_load.ML
--- a/src/Pure/General/secure.ML	Tue Jul 27 12:59:22 2010 +0200
+++ b/src/Pure/General/secure.ML	Tue Jul 27 22:00:26 2010 +0200
@@ -57,7 +57,7 @@
 fun commit () = use_global "commit();";   (*commit is dynamically bound!*)
 
 fun Isar_setup () = use_global "open Unsynchronized;";
-fun PG_setup () = use_global "structure ThyLoad = Thy_Load;";
+fun PG_setup () = use_global "structure ThyLoad = ProofGeneral.ThyLoad;";
 
 
 (* shell commands *)
--- a/src/Pure/Isar/isar_cmd.ML	Tue Jul 27 12:59:22 2010 +0200
+++ b/src/Pure/Isar/isar_cmd.ML	Tue Jul 27 22:00:26 2010 +0200
@@ -34,10 +34,6 @@
   val immediate_proof: Toplevel.transition -> Toplevel.transition
   val done_proof: Toplevel.transition -> Toplevel.transition
   val skip_proof: Toplevel.transition -> Toplevel.transition
-  val init_theory: string * string list * (string * bool) list ->
-    Toplevel.transition -> Toplevel.transition
-  val exit: Toplevel.transition -> Toplevel.transition
-  val quit: Toplevel.transition -> Toplevel.transition
   val pr: string list * (int option * int option) -> Toplevel.transition -> Toplevel.transition
   val disable_pr: Toplevel.transition -> Toplevel.transition
   val enable_pr: Toplevel.transition -> Toplevel.transition
@@ -271,19 +267,6 @@
 val skip_proof = local_skip_proof o global_skip_proof;
 
 
-(* init and exit *)
-
-fun init_theory (name, imports, uses) =
-  Toplevel.init_theory name
-    (Thy_Info.begin_theory name imports (map (apfst Path.explode) uses));
-
-val exit = Toplevel.keep (fn state =>
- (Context.set_thread_data (try Toplevel.generic_theory_of state);
-  raise Toplevel.TERMINATE));
-
-val quit = Toplevel.imperative quit;
-
-
 (* print state *)
 
 fun set_limit _ NONE = ()
--- a/src/Pure/Isar/isar_syn.ML	Tue Jul 27 12:59:22 2010 +0200
+++ b/src/Pure/Isar/isar_syn.ML	Tue Jul 27 22:00:26 2010 +0200
@@ -28,7 +28,10 @@
 
 val _ =
   Outer_Syntax.command "theory" "begin theory" (Keyword.tag_theory Keyword.thy_begin)
-    (Thy_Header.args >> (Toplevel.print oo Isar_Cmd.init_theory));
+    (Thy_Header.args >> (fn (name, imports, uses) =>
+      Toplevel.print o
+        Toplevel.init_theory name
+          (fn () => Thy_Info.toplevel_begin_theory name imports (map (apfst Path.explode) uses))));
 
 val _ =
   Outer_Syntax.command "end" "end (local) theory" (Keyword.tag_theory Keyword.thy_end)
@@ -992,11 +995,14 @@
 
 val _ =
   Outer_Syntax.improper_command "quit" "quit Isabelle" Keyword.control
-    (Parse.opt_unit >> (Toplevel.no_timing oo K Isar_Cmd.quit));
+    (Parse.opt_unit >> (Toplevel.no_timing oo K (Toplevel.imperative quit)));
 
 val _ =
   Outer_Syntax.improper_command "exit" "exit Isar loop" Keyword.control
-    (Scan.succeed (Toplevel.no_timing o Isar_Cmd.exit));
+    (Scan.succeed
+      (Toplevel.no_timing o Toplevel.keep (fn state =>
+        (Context.set_thread_data (try Toplevel.generic_theory_of state);
+          raise Toplevel.TERMINATE))));
 
 end;
 
--- a/src/Pure/Isar/outer_syntax.ML	Tue Jul 27 12:59:22 2010 +0200
+++ b/src/Pure/Isar/outer_syntax.ML	Tue Jul 27 22:00:26 2010 +0200
@@ -31,7 +31,7 @@
   type isar
   val isar: bool -> isar
   val prepare_command: Position.T -> string -> Toplevel.transition
-  val load_thy: string -> Position.T -> string -> (unit -> unit) * theory
+  val load_thy: string -> (unit -> theory) -> Position.T -> string -> (unit -> unit) * theory
 end;
 
 structure Outer_Syntax: OUTER_SYNTAX =
@@ -249,9 +249,9 @@
     handle ERROR msg => (Toplevel.malformed range_pos msg, true)
   end;
 
-fun prepare_unit commands (cmd, proof, proper_proof) =
+fun prepare_unit commands init (cmd, proof, proper_proof) =
   let
-    val (tr, proper_cmd) = prepare_span commands cmd;
+    val (tr, proper_cmd) = prepare_span commands cmd |>> Toplevel.modify_init init;
     val proof_trs = map (prepare_span commands) proof |> filter #2 |> map #1;
   in
     if proper_cmd andalso proper_proof then [(tr, proof_trs)]
@@ -268,7 +268,7 @@
 
 (* load_thy *)
 
-fun load_thy name pos text =
+fun load_thy name init pos text =
   let
     val (lexs, commands) = get_syntax ();
     val time = ! Output.timing;
@@ -279,7 +279,7 @@
     val spans = Source.exhaust (Thy_Syntax.span_source toks);
     val _ = List.app Thy_Syntax.report_span spans;
     val units = Source.exhaust (Thy_Syntax.unit_source (Source.of_list spans))
-      |> Par_List.map (prepare_unit commands) |> flat;
+      |> Par_List.map (prepare_unit commands init) |> flat;
 
     val _ = Present.theory_source name
       (fn () => HTML.html_mode (implode o map Thy_Syntax.present_span) spans);
--- a/src/Pure/Isar/toplevel.ML	Tue Jul 27 12:59:22 2010 +0200
+++ b/src/Pure/Isar/toplevel.ML	Tue Jul 27 22:00:26 2010 +0200
@@ -46,7 +46,8 @@
   val interactive: bool -> transition -> transition
   val print: transition -> transition
   val no_timing: transition -> transition
-  val init_theory: string -> (bool -> theory) -> transition -> transition
+  val init_theory: string -> (unit -> theory) -> transition -> transition
+  val modify_init: (unit -> theory) -> transition -> transition
   val exit: transition -> transition
   val keep: (state -> unit) -> transition -> transition
   val keep': (bool -> state -> unit) -> transition -> transition
@@ -295,16 +296,16 @@
 (* primitive transitions *)
 
 datatype trans =
-  Init of string * (bool -> theory) |    (*theory name, init*)
+  Init of string * (unit -> theory) |    (*theory name, init*)
   Exit |                                 (*formal exit of theory*)
   Keep of bool -> state -> unit |        (*peek at state*)
   Transaction of (bool -> node -> node) * (state -> unit);  (*node transaction and presentation*)
 
 local
 
-fun apply_tr int (Init (_, f)) (State (NONE, _)) =
+fun apply_tr _ (Init (_, f)) (State (NONE, _)) =
       State (SOME (Theory (Context.Theory
-          (Theory.checkpoint (Runtime.controlled_execution f int)), NONE)), NONE)
+          (Theory.checkpoint (Runtime.controlled_execution f ())), NONE)), NONE)
   | apply_tr _ Exit (State (prev as SOME (Theory (Context.Theory _, _)), _)) =
       State (NONE, prev)
   | apply_tr int (Keep f) state =
@@ -394,6 +395,12 @@
 (* basic transitions *)
 
 fun init_theory name f = add_trans (Init (name, f));
+
+fun modify_init f tr =
+  (case init_of tr of
+    SOME name => init_theory name f (reset_trans tr)
+  | NONE => tr);
+
 val exit = add_trans Exit;
 val keep' = add_trans o Keep;
 
--- a/src/Pure/ProofGeneral/proof_general_emacs.ML	Tue Jul 27 12:59:22 2010 +0200
+++ b/src/Pure/ProofGeneral/proof_general_emacs.ML	Tue Jul 27 22:00:26 2010 +0200
@@ -8,9 +8,10 @@
 signature PROOF_GENERAL =
 sig
   val test_markupN: string
+  val sendback: string -> Pretty.T list -> unit
   val init: bool -> unit
   val init_outer_syntax: unit -> unit
-  val sendback: string -> Pretty.T list -> unit
+  structure ThyLoad: sig val add_path: string -> unit end
 end;
 
 structure ProofGeneral: PROOF_GENERAL =
@@ -130,19 +131,17 @@
 (*liberal low-level version*)
 val thy_name = perhaps (try (unsuffix ".thy")) o List.last o space_explode "/";
 
-val inform_file_retracted = Thy_Info.if_known_thy Thy_Info.remove_thy o thy_name;
+val inform_file_retracted = Thy_Info.kill_thy o thy_name;
 
 fun inform_file_processed file =
   let
     val name = thy_name file;
     val _ = name = "" andalso error ("Bad file name: " ^ quote file);
     val _ =
-      if Thy_Info.known_thy name then
-        Thy_Info.register_thy (Toplevel.end_theory Position.none (Isar.state ()))
-          handle ERROR msg =>
-            (warning (cat_lines ["Failed to register theory: " ^ quote name, msg]);
-              tell_file_retracted (Thy_Header.thy_path name))
-      else ();
+      Thy_Info.register_thy (Toplevel.end_theory Position.none (Isar.state ()))
+        handle ERROR msg =>
+          (warning (cat_lines ["Failed to register theory: " ^ quote name, msg]);
+            tell_file_retracted (Thy_Header.thy_path name))
     val _ = Isar.init ();
   in () end;
 
@@ -247,4 +246,12 @@
        Secure.PG_setup ();
        Isar.toplevel_loop {init = true, welcome = true, sync = true, secure = Secure.is_secure ()});
 
+
+(* fake old ThyLoad -- with new semantics *)
+
+structure ThyLoad =
+struct
+  val add_path = Thy_Load.set_master_path o Path.explode;
 end;
+
+end;
--- a/src/Pure/ProofGeneral/proof_general_pgip.ML	Tue Jul 27 12:59:22 2010 +0200
+++ b/src/Pure/ProofGeneral/proof_general_pgip.ML	Tue Jul 27 22:00:26 2010 +0200
@@ -217,11 +217,11 @@
 
 val thy_name = Path.implode o #1 o Path.split_ext o Path.base;
 
-val inform_file_retracted = Thy_Info.if_known_thy Thy_Info.remove_thy o thy_name;
+val inform_file_retracted = Thy_Info.kill_thy o thy_name;
 
 fun inform_file_processed path state =
   let val name = thy_name path in
-    if Toplevel.is_toplevel state andalso Thy_Info.known_thy name then
+    if Toplevel.is_toplevel state then
       Thy_Info.register_thy (Toplevel.end_theory Position.none state)
         handle ERROR msg =>
           (warning (cat_lines [msg, "Failed to register theory: " ^ quote name]);
@@ -804,8 +804,7 @@
       val filepath = PgipTypes.path_of_pgipurl url
       val filedir = Path.dir filepath
       val thy_name = Path.implode o #1 o Path.split_ext o Path.base
-      val openfile_retract = Output.no_warnings_CRITICAL
-        (Thy_Info.if_known_thy Thy_Info.remove_thy) o thy_name;
+      val openfile_retract = Output.no_warnings_CRITICAL Thy_Info.kill_thy o thy_name;
   in
       case !currently_open_file of
           SOME f => raise PGIP ("<openfile> when a file is already open!\nCurrently open file: " ^
--- a/src/Pure/Thy/thy_info.ML	Tue Jul 27 12:59:22 2010 +0200
+++ b/src/Pure/Thy/thy_info.ML	Tue Jul 27 22:00:26 2010 +0200
@@ -10,8 +10,6 @@
   datatype action = Update | Outdate | Remove
   val add_hook: (action -> string -> unit) -> unit
   val get_names: unit -> string list
-  val known_thy: string -> bool
-  val if_known_thy: (string -> unit) -> string -> unit
   val lookup_theory: string -> theory option
   val get_theory: string -> theory
   val is_finished: string -> bool
@@ -23,7 +21,7 @@
   val kill_thy: string -> unit
   val use_thys: string list -> unit
   val use_thy: string -> unit
-  val begin_theory: string -> string list -> (Path.T * bool) list -> bool -> theory
+  val toplevel_begin_theory: string -> string list -> (Path.T * bool) list -> theory
   val register_thy: theory -> unit
   val finish: unit -> unit
 end;
@@ -60,6 +58,9 @@
 fun add_deps name parents G = Graph.add_deps_acyclic (name, parents) G
   handle Graph.CYCLES namess => error (cat_lines (map cycle_msg namess));
 
+fun new_node name parents entry =
+  Graph.new_node (name, entry) #> add_deps name parents;
+
 fun upd_deps name entry G =
   fold (fn parent => Graph.del_edge (parent, name)) (Graph.imm_preds G name) G
   |> Graph.map_node name (K entry);
@@ -72,21 +73,18 @@
 (* thy database *)
 
 type deps =
- {update_time: int,                      (*symbolic time of update; negative value means outdated*)
-  master: (Path.T * File.ident) option,  (*master dependencies for thy file*)
-  text: string,                          (*source text for thy*)
-  parents: string list};                 (*source specification of parents (partially qualified)*)
-
-fun make_deps update_time master text parents : deps =
-  {update_time = update_time, master = master, text = text, parents = parents};
+ {update_time: int,               (*symbolic time of update; negative value means outdated*)
+  master: (Path.T * File.ident),  (*master dependencies for thy file*)
+  parents: string list};          (*source specification of parents (partially qualified)*)
 
-fun init_deps master text parents = SOME (make_deps ~1 master text parents);
+fun make_deps update_time master parents : deps =
+  {update_time = update_time, master = master, parents = parents};
 
-fun master_dir NONE = Path.current
-  | master_dir (SOME (path, _)) = Path.dir path;
+fun init_deps master parents = SOME (make_deps (serial ()) master parents);
 
-fun master_dir' (d: deps option) = the_default Path.current (Option.map (master_dir o #master) d);
-fun master_dir'' d = the_default Path.current (Option.map master_dir' d);
+fun master_dir (path, _) = Path.dir path;
+
+fun master_dir' (d: deps option) = the_default Path.current (Option.map (Path.dir o #1 o #master) d);
 
 fun base_name s = Path.implode (Path.base (Path.explode s));
 
@@ -112,7 +110,6 @@
   SOME (thy_graph Graph.get_node name) handle Graph.UNDEF _ => NONE;
 
 val known_thy = is_some o lookup_thy;
-fun if_known_thy f name = if known_thy name then f name else ();
 
 fun get_thy name =
   (case lookup_thy name of
@@ -128,7 +125,6 @@
 val lookup_deps = Option.map #1 o lookup_thy;
 val get_deps = #1 o get_thy;
 fun change_deps name f = change_thy name (fn (deps, x) => (f deps, x));
-fun put_theory name theory = change_thy name (fn (deps, _) => (deps, SOME theory));
 
 val is_finished = is_none o get_deps;
 val master_directory = master_dir' o get_deps;
@@ -153,10 +149,7 @@
 fun loaded_files name =
   (case get_deps name of
     NONE => []
-  | SOME {master, ...} =>
-      (case master of
-        NONE => []
-      | SOME (thy_path, _) => thy_path :: Thy_Load.loaded_files (get_theory name)));
+  | SOME {master = (thy_path, _), ...} => thy_path :: Thy_Load.loaded_files (get_theory name));
 
 
 
@@ -180,8 +173,8 @@
 fun outdate_thy name =
   if is_finished name orelse is_outdated name then ()
   else CRITICAL (fn () =>
-   (change_deps name (Option.map (fn {master, text, parents, ...} =>
-    make_deps ~1 master text parents)); perform Outdate name));
+   (change_deps name (Option.map (fn {master, parents, ...} =>
+    make_deps ~1 master parents)); perform Outdate name));
 
 fun touch_thys names =
   List.app outdate_thy (thy_graph Graph.all_succs (map_filter unfinished names));
@@ -191,136 +184,91 @@
 end;
 
 
-(* management data *)
+(* abstract update time *)
 
-structure Management_Data = Theory_Data
+structure Update_Time = Theory_Data
 (
-  type T =
-    Task_Queue.group option *   (*worker thread group*)
-    int;                        (*abstract update time*)
-  val empty = (NONE, 0);
+  type T = int;
+  val empty = 0;
   fun extend _ = empty;
   fun merge _ = empty;
 );
 
-val thy_ord = int_ord o pairself (#2 o Management_Data.get);
-
-
-(* pending proofs *)
-
-fun join_thy name =
-  (case lookup_theory name of
-    NONE => ()
-  | SOME thy => PureThy.join_proofs thy);
-
-fun cancel_thy name =
-  (case lookup_theory name of
-    NONE => ()
-  | SOME thy =>
-      (case #1 (Management_Data.get thy) of
-        NONE => ()
-      | SOME group => Future.cancel_group group));
+val thy_ord = int_ord o pairself Update_Time.get;
 
 
 (* remove theory *)
 
 fun remove_thy name =
-  if is_finished name then error (loader_msg "cannot remove finished theory" [name])
+  if is_finished name then error (loader_msg "cannot change finished theory" [name])
   else
     let
       val succs = thy_graph Graph.all_succs [name];
-      val _ = List.app cancel_thy succs;
       val _ = priority (loader_msg "removing" succs);
       val _ = CRITICAL (fn () =>
         (List.app (perform Remove) succs; change_thys (Graph.del_nodes succs)));
     in () end;
 
-val kill_thy = if_known_thy remove_thy;
-
-
-(* load_thy *)
-
-fun required_by _ [] = ""
-  | required_by s initiators = s ^ "(required by " ^ show_path (rev initiators) ^ ")";
-
-fun load_thy upd_time initiators name =
-  let
-    val _ = priority ("Loading theory " ^ quote name ^ required_by " " initiators);
-    fun corrupted () = error (loader_msg "corrupted dependency information" [name]);
-    val (pos, text) =
-      (case get_deps name of
-        SOME {master = SOME (master_path, _), text, ...} =>
-          if text = "" then corrupted ()
-          else (Path.position master_path, text)
-      | _ => corrupted ());
-    val _ = touch_thy name;
-    val _ =
-      change_deps name (Option.map (fn {master, text, parents, ...} =>
-        make_deps upd_time master text parents));
-    val (after_load, theory) = Outer_Syntax.load_thy name pos text;
-    val _ = put_theory name theory;
-    val _ =
-      CRITICAL (fn () =>
-       (change_deps name
-          (Option.map (fn {update_time, master, parents, ...} =>
-            make_deps update_time master "" parents));
-        perform Update name));
-  in after_load end;
+fun kill_thy name =
+  if known_thy name then remove_thy name
+  else ();
 
 
 (* scheduling loader tasks *)
 
-datatype task = Task of (unit -> unit -> unit) | Finished | Running;
-fun task_finished Finished = true | task_finished _ = false;
+datatype task =
+  Task of string list * (theory list -> (theory * (unit -> unit))) |
+  Finished of theory;
+
+fun task_finished (Task _) = false
+  | task_finished (Finished _) = true;
 
 local
 
+fun schedule_seq task_graph =
+  ((Graph.topological_order task_graph, Symtab.empty) |-> fold (fn name => fn tab =>
+    (case Graph.get_node task_graph name of
+      Task (parents, body) =>
+        let
+          val (thy, after_load) = body (map (the o Symtab.lookup tab) parents);
+          val _ = after_load ();
+        in Symtab.update (name, thy) tab end
+    | Finished thy => Symtab.update (name, thy) tab))) |> ignore;
+
 fun schedule_futures task_graph = uninterruptible (fn _ => fn () =>
   let
-    val tasks = Graph.topological_order task_graph |> map_filter (fn name =>
-      (case Graph.get_node task_graph name of Task body => SOME (name, body) | _ => NONE));
-
+    val tasks = Graph.topological_order task_graph;
     val par_proofs = ! parallel_proofs >= 1;
 
-    fun fork (name, body) tab =
-      let
-        val deps = Graph.imm_preds task_graph name
-          |> map_filter (fn parent =>
-            (case Symtab.lookup tab parent of SOME future => SOME (parent, future) | NONE => NONE));
-        fun failed (parent, future) = if can Future.join future then NONE else SOME parent;
-
-        val future = Future.fork_deps (map #2 deps) (fn () =>
-          (case map_filter failed deps of
-            [] => body ()
-          | bad => error (loader_msg
-              ("failed to load " ^ quote name ^ " (unresolved " ^ commas_quote bad ^ ")") [])));
-        val future' =
-          if par_proofs then future
-          else Future.map (fn after_load => (after_load (); fn () => ())) future;
-      in Symtab.update (name, future') tab end;
-
-    val futures = fold fork tasks Symtab.empty;
+    val futures = (tasks, Symtab.empty) |-> fold (fn name => fn tab =>
+      (case Graph.get_node task_graph name of
+        Task (parents, body) =>
+          let
+            val get = the o Symtab.lookup tab;
+            val deps = map (`get) (Graph.imm_preds task_graph name);
+            fun failed (future, parent) = if can Future.join future then NONE else SOME parent;
 
-    val failed = tasks |> maps (fn (name, _) =>
+            val future = Future.fork_deps (map #1 deps) (fn () =>
+              (case map_filter failed deps of
+                [] => body (map (#1 o Future.join o get) parents)
+              | bad => error (loader_msg
+                  ("failed to load " ^ quote name ^ " (unresolved " ^ commas_quote bad ^ ")") [])));
+            val future' =
+              if par_proofs then future
+              else Future.map (fn (thy, after_load) => (after_load (); (thy, I))) future;
+          in Symtab.update (name, future') tab end
+      | Finished thy => Symtab.update (name, Future.value (thy, I)) tab));
+
+    val exns = tasks |> maps (fn name =>
       let
-        val after_load = Future.join (the (Symtab.lookup futures name));
-        val _ = join_thy name;
+        val (thy, after_load) = Future.join (the (Symtab.lookup futures name));
+        val _ = PureThy.join_proofs thy;
         val _ = after_load ();
-      in [] end handle exn => [(name, exn)]) |> rev;
+      in [] end handle exn => [exn]) |> rev;
 
-    val _ = List.app (kill_thy o #1) failed;
-    val _ = Exn.release_all (map (Exn.Exn o #2) failed);
+    val _ = Exn.release_all (map Exn.Exn exns);
   in () end) ();
 
-fun schedule_seq tasks =
-  Graph.topological_order tasks
-  |> List.app (fn name =>
-    (case Graph.get_node tasks name of
-      Task body =>
-        let val after_load = body ()
-        in after_load () handle exn => (kill_thy name; reraise exn) end
-    | _ => ()));
-
 in
 
 fun schedule_tasks tasks =
@@ -337,34 +285,56 @@
 
 local
 
+fun required_by _ [] = ""
+  | required_by s initiators = s ^ "(required by " ^ show_path (rev initiators) ^ ")";
+
+fun load_thy initiators (deps: deps) text dir name parent_thys =
+  let
+    val _ = kill_thy name;
+    val _ = priority ("Loading theory " ^ quote name ^ required_by " " initiators);
+
+    val {update_time, master = (thy_path, _), ...} = deps;
+    val pos = Path.position thy_path;
+    val uses =
+      map (apfst Path.explode) (#3 (Thy_Header.read pos (Source.of_string_limited 8000 text)));
+    fun init () =
+      Thy_Load.begin_theory dir name parent_thys uses
+      |> Present.begin_theory update_time dir uses
+      |> Update_Time.put update_time;
+
+    val (after_load, theory) = Outer_Syntax.load_thy name init pos text;
+
+    val parent_names = map Context.theory_name parent_thys;
+    fun after_load' () =
+     (after_load ();
+      CRITICAL (fn () =>
+        (change_thys (new_node name parent_names (SOME deps, SOME theory));
+          perform Update name)));
+
+  in (theory, after_load') end;
+
 fun check_deps dir name =
   (case lookup_deps name of
     SOME NONE => (true, NONE, get_parents name)
   | NONE =>
-      let val {master, text, imports = parents, ...} = Thy_Load.deps_thy dir name
-      in (false, init_deps (SOME master) text parents, parents) end
-  | SOME (SOME {update_time, master, text, parents}) =>
-      let
-        val (thy_path, thy_id) = Thy_Load.check_thy dir name;
-        val master' = SOME (thy_path, thy_id);
-      in
-        if Option.map #2 master <> SOME thy_id then
-          let val {text = text', imports = parents', ...} = Thy_Load.deps_thy dir name;
-          in (false, init_deps master' text' parents', parents') end
+      let val {master, imports = parents, ...} = Thy_Load.deps_thy dir name
+      in (false, init_deps master parents, parents) end
+  | SOME (SOME {update_time, master, parents}) =>
+      let val master' = Thy_Load.check_thy dir name in
+        if #2 master <> #2 master' then
+          let val {imports = parents', ...} = Thy_Load.deps_thy dir name;
+          in (false, init_deps master' parents', parents') end
         else
           let
             val current =
               (case lookup_theory name of
                 NONE => false
               | SOME theory => update_time >= 0 andalso Thy_Load.all_current theory);
-            val update_time' = if current then update_time else ~1;
-            val deps' = SOME (make_deps update_time' master' text parents);
+            val update_time' = if current then update_time else serial ();
+            val deps' = SOME (make_deps update_time' master' parents);
           in (current, deps', parents) end
       end);
 
-fun read_text (SOME {update_time, master = master as SOME (path, _), text = _, parents}) =
-  SOME (make_deps update_time master (File.read path) parents);
-
 in
 
 fun require_thys initiators dir strs tasks =
@@ -386,21 +356,22 @@
                 required_by "\n" initiators);
           val parent_names = map base_name parents;
 
-          val (parents_current, tasks_graph') =
+          val (parents_current, tasks') =
             require_thys (name :: initiators) (Path.append dir (master_dir' deps)) parents tasks;
 
           val all_current = current andalso parents_current;
+
+          (* FIXME ?? *)
           val _ = if not all_current andalso known_thy name then outdate_thy name else ();
-          val entry =
-            if all_current then (deps, SOME (get_theory name))
-            else (read_text deps, NONE);
-          val _ = change_thys (new_deps name parent_names entry);
 
-          val upd_time = serial ();
-          val tasks_graph'' = tasks_graph' |> new_deps name parent_names
-           (if all_current then Finished
-            else Task (fn () => load_thy upd_time initiators name));
-        in (all_current, tasks_graph'') end)
+          val task =
+            if all_current then Finished (get_theory name)
+            else
+              let
+                val SOME {master = (thy_path, _), ...} = deps;
+                val text = File.read thy_path;
+              in Task (parent_names, load_thy initiators (the deps) text dir' name) end;
+        in (all_current, new_node name parent_names task tasks') end)
   end;
 
 end;
@@ -417,56 +388,32 @@
 
 (* begin theory *)
 
-fun check_unfinished name =
-  if known_thy name andalso is_finished name then
-    error (loader_msg "cannot update finished theory" [name])
-  else ();
-
-fun begin_theory name parents uses int =
+fun toplevel_begin_theory name imports uses =
   let
-    val parent_names = map base_name parents;
-    val dir = master_dir'' (lookup_deps name);
-    val _ = check_unfinished name;
-    val _ = if int then use_thys_dir dir parents else ();
-
-    val theory =
-      Theory.begin_theory name (map get_theory parent_names)
-      |> Thy_Load.init dir
-      |> fold (Thy_Load.require o fst) uses;
-
-    val deps =
-      if known_thy name then get_deps name
-      else init_deps NONE "" parents;
-    val _ = change_thys (new_deps name parent_names (deps, NONE));
-
-    val update_time = (case deps of NONE => 0 | SOME {update_time, ...} => update_time);
-    val update_time = if update_time > 0 then update_time else serial ();
-    val theory' = theory
-      |> Management_Data.put (Future.worker_group (), update_time)
-      |> Present.begin_theory update_time dir uses;
-
-    val uses_now = map_filter (fn (x, true) => SOME x | _ => NONE) uses;
-    val theory'' =
-      fold (fn x => Context.theory_map (Thy_Load.exec_ml x) o Theory.checkpoint) uses_now theory';
-  in theory'' end;
+    val dir = Thy_Load.get_master_path ();
+    val _ = kill_thy name;
+    val _ = use_thys_dir dir imports;
+    val parents = map (get_theory o base_name) imports;
+  in Thy_Load.begin_theory dir name parents uses end;
 
 
-(* register existing theories *)
+(* register theory *)
 
 fun register_thy theory =
   let
     val name = Context.theory_name theory;
+    (* FIXME kill_thy name (??) *)
     val _ = priority ("Registering theory " ^ quote name);
     val parent_names = map Context.theory_name (Theory.parents_of theory);
     val _ = map get_theory parent_names;
 
     val master = Thy_Load.check_thy (Thy_Load.master_directory theory) name;
-    val update_time = #2 (Management_Data.get theory);
+    val update_time = Update_Time.get theory;
     val parents =
       (case lookup_deps name of
         SOME (SOME {parents, ...}) => parents
       | _ => parent_names);
-    val deps = make_deps update_time (SOME master) "" parents;
+    val deps = make_deps update_time master parents;
   in
     CRITICAL (fn () =>
      (if known_thy name then
--- a/src/Pure/Thy/thy_load.ML	Tue Jul 27 12:59:22 2010 +0200
+++ b/src/Pure/Thy/thy_load.ML	Tue Jul 27 22:00:26 2010 +0200
@@ -17,8 +17,9 @@
 signature THY_LOAD =
 sig
   include BASIC_THY_LOAD
+  val set_master_path: Path.T -> unit
+  val get_master_path: unit -> Path.T
   val master_directory: theory -> Path.T
-  val init: Path.T -> theory -> theory
   val require: Path.T -> theory -> theory
   val provide: Path.T * (Path.T * File.ident) -> theory -> theory
   val test_file: Path.T -> Path.T -> (Path.T * File.ident) option
@@ -31,6 +32,7 @@
   val provide_file: Path.T -> theory -> theory
   val use_ml: Path.T -> unit
   val exec_ml: Path.T -> generic_theory -> generic_theory
+  val begin_theory: Path.T -> string -> theory list -> (Path.T * bool) list -> theory
 end;
 
 structure Thy_Load: THY_LOAD =
@@ -61,7 +63,7 @@
 
 val master_directory = #master_dir o Files.get;
 
-fun init master_dir = map_files (fn _ => (master_dir, [], []));
+fun master dir = map_files (fn _ => (dir, [], []));
 
 fun require src_path =
   map_files (fn (master_dir, required, provided) =>
@@ -76,9 +78,12 @@
     else (master_dir, required, (src_path, path_info) :: provided));
 
 
-(* maintain load path *)
+(* maintain default paths *)
 
-local val load_path = Unsynchronized.ref [Path.current] in
+local
+  val load_path = Unsynchronized.ref [Path.current];
+  val master_path = Unsynchronized.ref Path.current;
+in
 
 fun show_path () = map Path.implode (! load_path);
 
@@ -97,6 +102,9 @@
 fun search_path dir path =
   distinct (op =) (dir :: (if Path.is_basic path then (! load_path) else [Path.current]));
 
+fun set_master_path path = master_path := path;
+fun get_master_path () = ! master_path;
+
 end;
 
 
@@ -202,6 +210,16 @@
 
 fun exec_ml src_path = ML_Context.exec (fn () => use_ml src_path);
 
+
+(* begin theory *)
+
+fun begin_theory dir name parents uses =
+  Theory.begin_theory name parents
+  |> master dir
+  |> fold (require o fst) uses
+  |> fold (fn (path, true) => Context.theory_map (exec_ml path) o Theory.checkpoint | _ => I) uses
+  |> Theory.checkpoint;
+
 end;
 
 structure Basic_Thy_Load: BASIC_THY_LOAD = Thy_Load;