[r2002-11-10 02:21:45 by cvscast] Saving/restoring global state

Original author: cvscast
Date: 2002-11-10 02:21:46+00:00

Makefile

@@ -5,7 +5,7 @@ CLEAN_DIRS = $(DIRS) tools tests
 
 # Objects to build
 
-MISC = misc/pool.cmo misc/encodings.cmo
+MISC = misc/pool.cmo misc/encodings.cmo misc/state.cmo
 
 PARSER = parser/lexer.cmo parser/location.cmo \
          parser/wlexer.cmo \

depend

@@ -2,6 +2,8 @@ misc/encodings.cmo: misc/encodings.cmi
 misc/encodings.cmx: misc/encodings.cmi 
 misc/pool.cmo: misc/pool.cmi 
 misc/pool.cmx: misc/pool.cmi 
+misc/state.cmo: misc/state.cmi 
+misc/state.cmx: misc/state.cmi 
 parser/ast.cmo: parser/location.cmi types/patterns.cmi types/types.cmi 
 parser/ast.cmx: parser/location.cmx types/patterns.cmx types/types.cmx 
 parser/location.cmo: parser/location.cmi 
@@ -20,10 +22,12 @@ typing/typed.cmx: parser/location.cmx types/patterns.cmx types/sortedMap.cmx \
     types/types.cmx 
 typing/typer.cmo: parser/ast.cmo types/builtin.cmo types/intervals.cmi \
     parser/location.cmi types/patterns.cmi types/sequence.cmi \
-    types/sortedList.cmi typing/typed.cmo types/types.cmi typing/typer.cmi 
+    types/sortedList.cmi misc/state.cmi typing/typed.cmo types/types.cmi \
+    typing/typer.cmi 
 typing/typer.cmx: parser/ast.cmx types/builtin.cmx types/intervals.cmx \
     parser/location.cmx types/patterns.cmx types/sequence.cmx \
-    types/sortedList.cmx typing/typed.cmx types/types.cmx typing/typer.cmi 
+    types/sortedList.cmx misc/state.cmx typing/typed.cmx types/types.cmx \
+    typing/typer.cmi 
 types/atoms.cmo: types/sortedList.cmi types/atoms.cmi 
 types/atoms.cmx: types/sortedList.cmx types/atoms.cmi 
 types/boolean.cmo: types/recursive.cmo types/sortedList.cmi types/boolean.cmi 
@@ -36,14 +40,14 @@ types/chars.cmo: types/chars.cmi
 types/chars.cmx: types/chars.cmi 
 types/intervals.cmo: types/intervals.cmi 
 types/intervals.cmx: types/intervals.cmi 
-types/patterns.cmo: types/sortedList.cmi types/sortedMap.cmi types/types.cmi \
-    types/patterns.cmi 
-types/patterns.cmx: types/sortedList.cmx types/sortedMap.cmx types/types.cmx \
-    types/patterns.cmi 
-types/recursive_noshare.cmo: types/recursive.cmo 
-types/recursive_noshare.cmx: types/recursive.cmx 
-types/recursive_share.cmo: types/recursive.cmo 
-types/recursive_share.cmx: types/recursive.cmx 
+types/patterns.cmo: types/sortedList.cmi types/sortedMap.cmi misc/state.cmi \
+    types/types.cmi types/patterns.cmi 
+types/patterns.cmx: types/sortedList.cmx types/sortedMap.cmx misc/state.cmx \
+    types/types.cmx types/patterns.cmi 
+types/recursive_noshare.cmo: types/recursive.cmo misc/state.cmi 
+types/recursive_noshare.cmx: types/recursive.cmx misc/state.cmx 
+types/recursive_share.cmo: types/recursive.cmo misc/state.cmi 
+types/recursive_share.cmx: types/recursive.cmx misc/state.cmx 
 types/sequence.cmo: types/atoms.cmi types/types.cmi types/sequence.cmi 
 types/sequence.cmx: types/atoms.cmx types/types.cmx types/sequence.cmi 
 types/sortedList.cmo: types/sortedList.cmi 
@@ -55,11 +59,11 @@ types/type_bool.cmx: types/boolean.cmx types/recursive.cmx
 types/types.cmo: types/atoms.cmi types/boolean.cmi types/chars.cmi \
     types/intervals.cmi misc/pool.cmi types/recursive.cmo \
     types/recursive_noshare.cmo types/sortedList.cmi types/sortedMap.cmi \
-    types/types.cmi 
+    misc/state.cmi types/types.cmi 
 types/types.cmx: types/atoms.cmx types/boolean.cmx types/chars.cmx \
     types/intervals.cmx misc/pool.cmx types/recursive.cmx \
     types/recursive_noshare.cmx types/sortedList.cmx types/sortedMap.cmx \
-    types/types.cmi 
+    misc/state.cmx types/types.cmi 
 runtime/eval.cmo: runtime/load_xml.cmi runtime/print_xml.cmo \
     runtime/run_dispatch.cmi typing/typed.cmo types/types.cmi \
     runtime/value.cmi runtime/eval.cmi 
@@ -83,15 +87,15 @@ runtime/value.cmo: types/chars.cmi types/sequence.cmi types/sortedMap.cmi \
 runtime/value.cmx: types/chars.cmx types/sequence.cmx types/sortedMap.cmx \
     types/types.cmx runtime/value.cmi 
 driver/cduce.cmo: parser/ast.cmo types/builtin.cmo runtime/eval.cmi \
-    parser/location.cmi parser/parser.cmi types/patterns.cmi typing/typed.cmo \
-    typing/typer.cmi types/types.cmi runtime/value.cmi parser/wlexer.cmo \
-    driver/cduce.cmi 
+    parser/location.cmi parser/parser.cmi types/patterns.cmi misc/state.cmi \
+    typing/typed.cmo typing/typer.cmi types/types.cmi runtime/value.cmi \
+    parser/wlexer.cmo driver/cduce.cmi 
 driver/cduce.cmx: parser/ast.cmx types/builtin.cmx runtime/eval.cmx \
-    parser/location.cmx parser/parser.cmx types/patterns.cmx typing/typed.cmx \
-    typing/typer.cmx types/types.cmx runtime/value.cmx parser/wlexer.cmx \
-    driver/cduce.cmi 
-driver/run.cmo: driver/cduce.cmi parser/location.cmi 
-driver/run.cmx: driver/cduce.cmx parser/location.cmx 
+    parser/location.cmx parser/parser.cmx types/patterns.cmx misc/state.cmx \
+    typing/typed.cmx typing/typer.cmx types/types.cmx runtime/value.cmx \
+    parser/wlexer.cmx driver/cduce.cmi 
+driver/run.cmo: driver/cduce.cmi parser/location.cmi misc/state.cmi 
+driver/run.cmx: driver/cduce.cmx parser/location.cmx misc/state.cmx 
 driver/webiface.cmo: driver/cduce.cmi runtime/load_xml.cmi \
     parser/location.cmi 
 driver/webiface.cmx: driver/cduce.cmx runtime/load_xml.cmx \

driver/cduce.ml

@@ -133,10 +133,12 @@ let mk_builtin () =
     (fun (n,t) -> Typer.register_global_types [n, mk noloc (Ast.Internal t)])
     Builtin.types
 
+let () = mk_builtin ()
+
+let typing_env = State.ref "Cduce.typing_env" Typer.Env.empty
+let eval_env = State.ref "Cduce.eval_env" Eval.Env.empty
+
 let run ppf input =
-  let typing_env = ref Typer.Env.empty in
-  let eval_env = ref Eval.Env.empty in
-  
   let insert_type_bindings = 
     List.iter (fun (x,t) ->
 		 typing_env := Typer.Env.add x t !typing_env;
@@ -181,7 +183,6 @@ let run ppf input =
     List.iter eval_decl decls
   in
   try 
-    mk_builtin ();
     let p = 
       try Parser.prog input
       with
@@ -198,10 +199,11 @@ let run ppf input =
 	) ([],[]) p in
     Typer.register_global_types type_decls;
     do_fun_decls fun_decls;
-    List.iter phrase p
+    List.iter phrase p;
+    true
   with 
     | (Failure _ | Not_found | Invalid_argument _) as e -> 
 	raise e  (* To get ocamlrun stack trace *)
-    | exn -> print_exn ppf exn
+    | exn -> print_exn ppf exn; false
 	
 

driver/cduce.mli

 val print_exn: Format.formatter -> exn -> unit
-val run : Format.formatter -> char Stream.t -> unit
+
+val run : Format.formatter -> char Stream.t -> bool
+  (* Returns true if everything is ok (no error) *)

driver/run.ml

-let input_channel = 
-  match Array.length Sys.argv with
-    | 1 -> Location.set_source `Stream; stdin
-    | 2 -> let fn = Sys.argv.(1) in Location.set_source (`File fn); open_in fn
-    | _ -> Printf.eprintf "Usage: cduce [script]\n"; exit 2
-in
-let input = Stream.of_channel input_channel
-and ppf = Format.std_formatter in
-Cduce.run ppf input
+let () = State.close ();;
 
+let dump = ref None
+let src  = ref []
 
+let specs =
+  [ "-dump", Arg.String (fun s -> dump := Some s), " specify filename for persistency" ]
 
+let () =
+  Arg.parse specs (fun s -> src := s :: !src) 
+    "cduce [options] [script]\n\nOptions:"
+
+let ppf = Format.std_formatter
+
+let do_file s =
+  let (src, chan) = 
+    if s = "" then (`Stream, stdin) else (`File s, open_in s) in
+  Location.set_source src;
+  let input = Stream.of_channel chan in
+  let ok = Cduce.run ppf input in
+  if s <> "" then close_in chan;
+  if not ok then exit 1
+
+  
+
+let main () =
+  (match !dump with
+     | Some f ->
+	 (try 
+	    Format.fprintf ppf "Restoring state: ";
+	    let chan = open_in_bin f in
+	    let s = Marshal.from_channel chan in
+	    close_in chan;
+	    State.set s;
+	    Format.fprintf ppf "done ...@."
+	  with Sys_error _ ->  
+	    Format.fprintf ppf "failed ...@.")
+     | None -> ());
+  (match !src with
+     | [] -> 
+	 Format.fprintf ppf "No script specified; using stdin ...@.";
+	 do_file ""
+     | l -> List.iter do_file l);
+  (match !dump with
+     | Some f ->
+	 Format.fprintf ppf "Saving state ...@\n";
+	 let s = State.get () in
+	 let chan = open_out_bin f in
+	 Marshal.to_channel chan s [ Marshal.Closures ];
+	 close_out chan
+     | None -> ())
+
+
+
+
+let () = main ()

runtime/eval.ml

@@ -4,7 +4,7 @@ open Run_dispatch
 module Env = Map.Make (struct type t = string let compare = compare end)
 type env = t Env.t
 
-let global_env = ref Env.empty
+let global_env = State.ref "Eval.global_env" Env.empty
 let enter_global x v = global_env := Env.add x v !global_env
 
 

types/patterns.ml

@@ -27,11 +27,11 @@ and node = {
   fv : fv
 } and descr = Types.descr * fv * d
 
-let make =
-  let counter = ref 0 in
-  fun fv ->
-    incr counter;
-    { id = !counter; descr = None; accept = Types.make (); fv = fv }
+let counter = State.ref "Patterns.counter" 0
+
+let make fv =
+  incr counter;
+  { id = !counter; descr = None; accept = Types.make (); fv = fv }
 
 let define x ((accept,fv,_) as d) =
   assert (x.fv = fv);
@@ -483,7 +483,8 @@ struct
 	 `TailCall disp
     | x -> x
    
-  let cur_id = ref 0
+  let cur_id = State.ref "Patterns.cur_id" 0
+		 (* TODO: save dispatchers ? *)
 		 
   module DispMap = Map.Make(
     struct
@@ -730,8 +731,10 @@ struct
 	 | (res, catch, `Label (l1, _, ab)) when l1 = l -> (res, catch, ab)
 	 | x -> x)
 
+(*
   let memo_dispatch_record = ref []
   let memo_dr_count = ref 0
+*)
 
   let rec print_normal_record ppf = function
     | `Success -> Format.fprintf ppf "Success"
@@ -770,7 +773,7 @@ struct
     let pl0 = Array.map prep disp.pl in
     let t = Types.Record.get disp.t in
     let r = dispatch_record_opt disp t pl0 in
-    memo_dispatch_record := [];
+(*    memo_dispatch_record := []; *)
     r
   and dispatch_record_opt disp t pl =
     if Types.Record.is_empty t then None 

types/recursive_noshare.ml

@@ -13,7 +13,7 @@ struct
 
   let id n = n.id
 
-  let counter = ref 0
+  let counter = State.ref "Recursive_noshare" 0
 
   let make () =
     incr counter;

types/recursive_share.ml

-(* $Id: recursive_share.ml,v 1.2 2002/10/31 17:35:39 cvscast Exp $ *)
+(* $Id: recursive_share.ml,v 1.3 2002/11/10 02:21:46 cvscast Exp $ *)
 open Recursive
 
 module Make(X : S) = 
@@ -64,7 +64,9 @@ struct
 
   let id n = !n.id
 
-  let counter = ref 0
+  let counter = State.ref "Recursive_share" 0
+
+		  (* TODO: need to save the Hashtbl ... *)
 
   let make () =
     incr counter;

types/types.ml

@@ -167,8 +167,9 @@ struct
     | Atom a -> print_atom ppf a
     | Char c -> Chars.Unichar.print ppf c
 
-  let named = DescrHash.create 10
-  let register_global name d = DescrHash.add named d name
+  let named = State.ref "Types.Printf.named" DescrMap.empty
+  let register_global name d = 
+    named := DescrMap.add d name !named
 
   let marks = DescrHash.create 63
   let wh = ref []
@@ -189,7 +190,7 @@ struct
 
   let rec mark n = mark_descr (descr n)
   and mark_descr d =
-    if not (DescrHash.mem named d) then
+    if not (DescrMap.mem d !named) then
       try 
 	let r = DescrHash.find marks d in
 	if (!r = None) && (worth_abbrev d) then 
@@ -212,7 +213,7 @@ struct
   let rec print ppf n = print_descr ppf (descr n)
   and print_descr ppf d = 
     try 
-      let name = DescrHash.find named d in
+      let name = DescrMap.find d !named in
       Format.fprintf ppf "%s" name
     with Not_found ->
       try

typing/typer.ml

@@ -301,7 +301,7 @@ and pat_node s : Patterns.node =
 	Patterns.define x t;
 	x
 
-let global_types = ref StringMap.empty
+let global_types = State.ref "Typer.global_types" StringMap.empty
 
 let mk_typ e =
   if fv e = [] then type_node e
@@ -318,12 +318,16 @@ let pat e =
 let register_global_types b =
   let env = compile_many !global_types b in
   List.iter (fun (v,_) -> 
-	       let d = Types.descr (mk_typ (StringMap.find v env)) in
+	       let t = StringMap.find v env in
+	       if StringMap.mem v !global_types then
+		 raise 
+		   (Location.Generic ("Multiple definition for type " ^ v));
+	       global_types := StringMap.add v t !global_types;
+	       let d = Types.descr (mk_typ t) in
 (*	       let d = Types.normalize d in*)
 	       Types.Print.register_global v d;
 	       ()
-	    ) b;
-  global_types := env
+	    ) b
 
 
 (* II. Build skeleton *)