[r2004-05-05 23:56:31 by afrisch] Revu compilation des globals

Original author: afrisch
Date: 2004-05-05 23:56:32+00:00

compile/compile.ml

@@ -2,10 +2,14 @@ open Ident
 open Lambda
 
 type env = {
+  cu: Types.CompUnit.t option;  (* None: toplevel *)
   vars: var_loc Env.t;
-  stack_size: int
+  stack_size: int;
+  global_size: int
 }
 
+let global_size env = env.global_size
+
 let dump ppf env =
   Env.iter 
     (fun id loc ->
@@ -13,19 +17,25 @@ let dump ppf env =
     env.vars
 
 
-let empty = { vars = Env.empty; stack_size = 0 }
+let mk cu = { cu = cu; vars = Env.empty; stack_size = 0; global_size = 0 }
+let empty_toplevel = mk None
+let empty x = mk (Some x)
+
 
 let serialize s env =
+  assert (env.stack_size = 0);
+  (match env.cu with
+    | Some cu -> Types.CompUnit.serialize s cu
+    | None -> assert false);
   Serialize.Put.env Id.serialize Lambda.Put.var_loc Env.iter s env.vars;
-  Serialize.Put.int s env.stack_size    
+  Serialize.Put.int s env.global_size
 
 let deserialize s =
+  let cu = Types.CompUnit.deserialize s in
   let vars = 
     Serialize.Get.env Id.deserialize Lambda.Get.var_loc Env.add Env.empty s in
   let size = Serialize.Get.int s in
-  { vars = vars; stack_size = size }
-
-
+  { cu = Some cu; vars = vars; stack_size = 0; global_size = size }
 
 
 let find x env =
@@ -37,15 +47,14 @@ let from_comp_unit = ref (fun cu -> assert false)
 
 let find_ext cu x =
   let env = !from_comp_unit cu in
-  match find x env with
-    | Ext(_,_) as v -> Var v
-    | _ -> assert false
+  find x env
+
 
 let rec compile env tail e = compile_aux env tail e.Typed.exp_descr
 and compile_aux env tail = function
   | Typed.Forget (e,_) -> compile env tail e
   | Typed.Var x -> Var (find x env)
-  | Typed.ExtVar (cu,x) -> find_ext cu x
+  | Typed.ExtVar (cu,x) -> Var (find_ext cu x)
   | Typed.Apply (e1,e2) -> Apply (tail, compile env false e1, compile env tail e2)
   | Typed.Abstraction a -> compile_abstr env a
   | Typed.Cst c -> Const c
@@ -92,7 +101,7 @@ and compile_abstr env a =
 
 
   let slots = Array.of_list (List.rev slots) in  
-  let env = { vars = fun_env; stack_size = 0 } in
+  let env = { env with vars = fun_env; stack_size = 0 } in
   let body = compile_branches env true a.Typed.fun_body in
   Abstraction (slots, a.Typed.fun_iface, body)
 
@@ -112,39 +121,59 @@ and compile_branch env tail br =
   let env = 
     List.fold_left 
       (fun env x ->
-	 { vars = Env.add x (Stack env.stack_size) env.vars;
-	   stack_size = env.stack_size + 1 }
+	 { env with 
+	     vars = Env.add x (Stack env.stack_size) env.vars;
+	     stack_size = env.stack_size + 1 }
 
       ) env (Patterns.fv_list br.Typed.br_pat) in
   (br.Typed.br_pat, compile env tail br.Typed.br_body)
 
 
-let enter_global env x =
-  { vars = Env.add x (Global env.stack_size) env.vars;
-    stack_size = env.stack_size + 1 }
-
-let enter_globals = List.fold_left enter_global
-
-let compile_eval env e = Eval (compile env false e)
+let enter_globals env n = 
+  match env.cu with
+    | None ->
+	let env = 
+	  List.fold_left
+	    (fun env x ->
+	       { env with
+		   vars = Env.add x (Global env.stack_size) env.vars;
+		   stack_size = env.stack_size + 1 })
+	    env n in
+	(env,[])
+    | Some cu ->
+	List.fold_left
+	(fun (env,code) x ->
+	 let code = SetGlobal (cu, env.global_size) :: code in
+	 let env = 
+	   { env with
+	       vars = Env.add x (Ext (cu, env.global_size)) env.vars;
+	       global_size = env.global_size + 1 } in
+	 (env,code)
+	)
+	(env,[])
+	n
+
+let compile_expr env = compile env false
+
+let compile_eval env e = [ Push (compile_expr env e); Pop ]
 
 let compile_let_decl env decl =
   let pat = decl.Typed.let_pat in
-  let code = Let_decl (pat, compile env false (decl.Typed.let_body)) in
-  let env = enter_globals env (Patterns.fv_list pat) in
-  (env, code)
-
+  let (env,code) = enter_globals env (Patterns.fv_list pat) in
+  (env, (Push (compile_expr env decl.Typed.let_body)) :: (Split pat) :: code)
 
 let compile_rec_funs env funs =
   let fun_name = function
     | { Typed.exp_descr=Typed.Abstraction{Typed.fun_name = Some x}} -> x
     | _ -> assert false in
-  let fun_a = function
-    | { Typed.exp_descr=Typed.Abstraction a } -> a
+  let fun_a env = function
+    | { Typed.exp_descr=Typed.Abstraction a } -> 
+	Push (compile_abstr env a)
     | _ -> assert false in
   let names = List.map fun_name funs in
-  let env = enter_globals env names in
-  let exprs = List.map (compile_abstr env) (List.map fun_a funs) in
-  (env, Let_funs exprs)
+  let (env,code) = enter_globals env names in
+  let exprs = List.map (fun_a env) funs in
+  (env, exprs @ code)
 
 
 (****************************************)
@@ -153,17 +182,17 @@ open Location
 
 let eval ~run ~show (tenv,cenv,codes) e =
   let (e,t) = Typer.type_expr tenv e in
-  let code = compile_eval cenv e in
+  let expr = compile_expr cenv e in
   if run then
-    let v = Eval.expr code in
+    let v = Eval.expr expr in
     show None t (Some v)
   else
     show None t None;
-  (tenv,cenv,code::codes)
+  (tenv,cenv, Pop :: Push expr ::codes)
 
-let run_show ~run ~show tenv cenv code ids =
+let run_show ~run ~show tenv cenv codes ids =
   if run then
-    let () = Eval.eval code in
+    let () = Eval.code_items codes in
     List.iter 
       (fun (id,_) -> show (Some id) 
 	 (Typer.find_value id tenv)
@@ -178,13 +207,13 @@ let let_decl ~run ~show (tenv,cenv,codes) p e =
   let (tenv,decl,ids) = Typer.type_let_decl tenv p e in
   let (cenv,code) = compile_let_decl cenv decl in
   run_show ~run ~show tenv cenv code ids;
-  (tenv,cenv,code::codes)
+  (tenv,cenv,List.rev_append code codes)
   
 let let_funs ~run ~show (tenv,cenv,codes) funs =
   let (tenv,funs,ids) = Typer.type_let_funs tenv funs in
   let (cenv,code) = compile_rec_funs cenv funs in
   run_show ~run ~show tenv cenv code ids;
-  (tenv,cenv,code::codes)
+  (tenv,cenv,List.rev_append code codes)
   
 let type_defs (tenv,cenv,codes) typs =
   let tenv = Typer.enter_types (Typer.type_defs tenv typs) tenv in

compile/compile.mli

@@ -2,21 +2,24 @@ open Ident
 open Lambda
 
 type env
+val global_size: env -> int
 val from_comp_unit: (Types.CompUnit.t -> env) ref
 
 val dump: Format.formatter -> env -> unit
 
-val empty : env
+val empty : Types.CompUnit.t -> env
+val empty_toplevel : env
 val serialize: env Serialize.Put.f
 val deserialize: env Serialize.Get.f
 
+(*
 val enter_global : env -> id -> env
 val enter_globals : env -> id list -> env
+*)
 val find : id -> env -> var_loc
 
-val compile_eval : env -> Typed.texpr -> code_item
-val compile_let_decl : env -> Typed.let_decl -> env * code_item
-val compile_rec_funs : env -> Typed.texpr list -> env * code_item
+
+val compile_expr : env -> Typed.texpr -> Lambda.expr
 
 
 val comp_unit:
@@ -25,5 +28,5 @@ val comp_unit:
   ?loading:(Types.CompUnit.t -> unit) ->
   ?directive:(Typer.t -> env -> Ast.toplevel_directive -> unit) ->
 
-  Typer.t -> env -> 
-  Ast.pmodule_item list -> Typer.t * env * Lambda.code_item list
+  Typer.t -> env -> Ast.pmodule_item list -> 
+  Typer.t * env * Lambda.code_item list

compile/lambda.ml

@@ -3,15 +3,15 @@ open Ident
 type var_loc =
   | Stack of int
   | Env of int
-  | Global of int
   | Ext of Types.CompUnit.t * int (* If pos < 0, the first arg is the value *)
+  | Global of int (* Only for the toplevel *)
   | Dummy
 
 let print_var_loc ppf = function
   | Stack i -> Format.fprintf ppf "Stack %i" i
   | Env i -> Format.fprintf ppf "Env %i" i
-  | Global i -> Format.fprintf ppf "Global %i" i
   | Ext (cu,i) -> Format.fprintf ppf "Ext (_,%i)" i
+  | Global i -> Format.fprintf ppf "Global %i" i
   | Dummy -> Format.fprintf ppf "Dummy"
 
 type schema_component_kind =
@@ -64,21 +64,23 @@ and dump_branches ppf brs =
   List.iter (fun (p,e) -> Format.fprintf ppf "_ -> %a |" dump_expr e) brs.brs
 
 type code_item =
-  | Eval of expr
-  | Let_decl of Patterns.node * expr
-  | Let_funs of expr list
+  | Push of expr
+  | Pop
+  | Split of Patterns.node
+  | SetGlobal of Types.CompUnit.t * int
 
 let print_code_item ppf = function
-  | Eval _ -> Format.fprintf ppf "Eval@."
-  | Let_decl _ -> Format.fprintf ppf "Let_decl@."
-  | Let_funs _ -> Format.fprintf ppf "Let_funs@."
+  | Push _ -> Format.fprintf ppf "Push@."
+  | Pop -> Format.fprintf ppf "Pop@."
+  | Split _ -> Format.fprintf ppf "Split@."
+  | SetGlobal (_,_) -> Format.fprintf ppf "SetGlobal@."
 
 type code = code_item list
 
 
 let nbits = 5
 
-let magic_compunit = "CDUCE:0.2:COMPUNIT"
+let magic_compunit = "CDUCE:0.3:COMPUNIT"
 
 module Put = struct
   let unary_op = ref (fun _ _ -> assert false; ())
@@ -86,17 +88,10 @@ module Put = struct
 
   open Serialize.Put
 
-  let current_cu = ref Types.CompUnit.pervasives
-		     (* Used to create self reference when saving *)
-		    
   let var_loc s = function
     | Stack i ->
 	bits 2 s 0;
 	int s i
-    | Global i ->
-	bits 2 s 1;
-	Types.CompUnit.serialize s !current_cu;
-	int s i
     | Ext (cu,i) ->
 	bits 2 s 1;
 	Types.CompUnit.serialize s cu;
@@ -106,6 +101,7 @@ module Put = struct
 	int s i
     | Dummy ->
 	bits 2 s 3
+    | Global _ -> assert false
 	
   let rec expr s = function
     | Var v -> 
@@ -191,9 +187,10 @@ module Put = struct
     bool s brs.brs_accept_chars
 
   let code_item s = function
-    | Eval e -> bits 2 s 0; expr s e
-    | Let_decl (p,e) -> bits 2 s 1; Patterns.Node.serialize s p; expr s e
-    | Let_funs e -> bits 2 s 2; list expr s e
+    | Push e -> bits 2 s 0; expr s e
+    | Pop -> bits 2 s 1
+    | Split p -> bits 2 s 2; Patterns.Node.serialize s p
+    | SetGlobal (cu,i) -> bits 2 s 3; Types.CompUnit.serialize s cu; int s i
 
   let codes = list code_item
 
@@ -304,13 +301,13 @@ module Get = struct
 
   let code_item s =
     match bits 2 s with
-      | 0 -> Eval (expr s)
-      | 1 -> 
-	  let p = Patterns.Node.deserialize s in
-	  let e = expr s in
-	  Let_decl (p,e)
-      | 2 -> 
-	  Let_funs (list expr s)
+      | 0 -> Push (expr s)
+      | 1 -> Pop
+      | 2 -> Split (Patterns.Node.deserialize s)
+      | 3 -> 
+	  let cu = Types.CompUnit.deserialize s in
+	  let pos = int s in
+	  SetGlobal (cu,pos)
       | _ -> assert false
 
   let codes = list code_item

driver/cduce.ml

@@ -22,7 +22,7 @@ let toplevel = ref false
 let verbose = ref false
 
 let typing_env = State.ref "Cduce.typing_env" Builtin.env
-let compile_env = State.ref "Cduce.compile_env" Compile.empty
+let compile_env = State.ref "Cduce.compile_env" Compile.empty_toplevel
 
 let get_global_value cenv v =
   Eval.var (Compile.find v !compile_env)
@@ -30,11 +30,6 @@ let get_global_value cenv v =
 let get_global_type v =
   Typer.find_value v !typing_env
 
-let enter_global_value x v t =
-  typing_env := Typer.enter_value x t !typing_env;
-  compile_env := Compile.enter_global !compile_env x; 
-  Eval.push v
-  
 let rec is_abstraction = function
   | Ast.Abstraction _ -> true
   | Ast.LocatedExpr (_,e) -> is_abstraction e
@@ -165,7 +160,7 @@ let rec print_exn ppf = function
 
 let eval_quiet tenv cenv e = 
   let (e,_) = Typer.type_expr tenv e in
-  let e = Compile.compile_eval cenv e in 
+  let e = Compile.compile_expr cenv e in 
   Eval.expr e
 
 let debug ppf tenv cenv = function
@@ -255,7 +250,7 @@ let phrases ppf phs =
   let (tenv,cenv,_) = 
     Compile.comp_unit 
       ~run:true ~show:(show ppf) 
-      ~loading:(fun cu -> Librarian.import cu; Librarian.run Value.nil cu)
+      ~loading:Librarian.import_and_run
       ~directive:(directive ppf)
       !typing_env !compile_env phs in
   typing_env := tenv;
@@ -279,7 +274,6 @@ let run rule ppf ppf_err input =
   try phrases ppf (parse rule input); true
   with exn -> catch_exn ppf_err exn; false
 
-let script = run Parser.prog
 let topinput = run Parser.top_phrases
 
 ifdef ML_INTERFACE then 
@@ -330,24 +324,23 @@ let compile src out_dir =
     exit 0
   with exn -> catch_exn Format.err_formatter exn; exit 1
   
-let compile_run src argv =
+let compile_run src =
   try
     if not (Filename.check_suffix src ".cd")
     then raise (InvalidInputFilename src);
     let cu = Filename.chop_suffix (Filename.basename src) ".cd" in
     let id = Types.CompUnit.mk (U.mk_latin1 cu) in
     Librarian.compile !verbose id src;
-    Librarian.run argv id
+    Librarian.run id
   with exn -> catch_exn Format.err_formatter exn; exit 1
 
-let run obj argv =  
+let run obj =  
   try
     if not (Filename.check_suffix obj ".cdo") || (Filename.basename obj <> obj)
     then raise (InvalidObjectFilename obj);
     let cu = Filename.chop_suffix (Filename.basename obj) ".cdo" in
     let id = Types.CompUnit.mk (U.mk_latin1 cu) in
-    Librarian.import id;
-    Librarian.run argv id
+    Librarian.import_and_run id
   with exn -> catch_exn Format.err_formatter exn; exit 1
 
 

driver/cduce.mli

 val toplevel: bool ref
 val verbose: bool ref
 
-val enter_global_value : Ident.id -> Value.t -> Types.descr -> unit
-val script   : Format.formatter -> Format.formatter -> char Stream.t -> bool
 val topinput : Format.formatter -> Format.formatter -> char Stream.t -> bool
 
 val dump_env : Format.formatter -> unit
 
 val compile: string -> string option -> unit
-val compile_run: string -> Value.t -> unit
-val run: string -> Value.t -> unit
+val compile_run: string -> unit
+val run: string -> unit

driver/librarian.ml

@@ -14,8 +14,9 @@ type t = {
   compile: Compile.env;
   code: Lambda.code_item list;
   mutable digest: Digest.t option;
-  mutable vals: Value.t array option;
-  mutable depends: C.t list
+  vals: Value.t array;
+  mutable depends: C.t list;
+  mutable status: [ `Evaluating | `Unevaluated | `Evaluated ]
 }
 
 let mk (typing,compile,code) =
@@ -23,11 +24,12 @@ let mk (typing,compile,code) =
     compile = compile;
     code = code;
     digest = None;
-    vals = None;
+    vals = Array.make (Compile.global_size compile) Value.Absent;
     depends = [];
+    status = `Unevaluated;
   }
 
-let magic = "CDUCE:compunit:00001"
+let magic = "CDUCE:compunit:00002"
 
 let obj_path = ref [ "" ]
 
@@ -67,7 +69,6 @@ let find_obj id =
 
 let save id out =
   protect_op "Save compilation unit";
-  Lambda.Put.current_cu := id;
   let cu = find id in
   C.enter id;
   let raw = Serialize.Put.run serialize cu in
@@ -147,8 +148,8 @@ let rec compile verbose id src =
   let cu =
     Compile.comp_unit 
       ?show
-      (Typer.enter_value argv (Sequence.star Sequence.string) Builtin.env)
-      (Compile.enter_global Compile.empty argv)
+      Builtin.env
+      (Compile.empty id)
       p
   in
   let cu = mk cu in
@@ -195,28 +196,40 @@ and load_check id exp =
   let cu = load id in
   check_digest id exp cu.digest
 
-let rec run argv id =
+let rec run id =
   let cu = find id in
-  match cu.vals with
-    | None -> 
-	List.iter (run argv) cu.depends;
-	let vals = Eval.comp_unit [argv] cu.code in
+  match cu.status with
+    | `Unevaluated -> 
+	List.iter run cu.depends;
+	cu.status <- `Evaluating;
+	Eval.code_items cu.code;
+	cu.status <- `Evaluated
 (*
 	Compile.dump Format.std_formatter cu.compile;
 	Array.iter (fun v ->
 		      Format.fprintf Format.std_formatter "%a@."
 		      Value.print v) vals;
 *)
-	cu.vals <- Some vals
-    | Some _ -> ()
+    | `Evaluating -> 
+(*
+	failwith 
+	("Librarian.run. Already running:" ^ (U.to_string (C.value id)))
+*)
+	()
+    | `Evaluated -> ()
   
 let import id = ignore (load id)
 
+let import_and_run id = import id; run id
+
 let () =
   Typer.from_comp_unit := (fun cu -> (load cu).typing);
   Compile.from_comp_unit := (fun cu -> (load cu).compile);
-  Eval.from_comp_unit := 
-  (fun cu i ->
-     match (load cu).vals with
-       | None -> !Eval.stack.(i) (* TODO: check that cu is being evaluated *)
-       | Some a -> a.(i))
+  Eval.get_global := (fun cu i -> import_and_run cu; (load cu).vals.(i));
+  Eval.set_global := (fun cu i v -> import cu;
+			let cu = load cu in
+			match cu.status with
+			  | `Evaluating -> cu.vals.(i) <- v
+			  | _ -> assert false);;
+    
+

driver/librarian.mli

@@ -7,7 +7,8 @@ exception NoImplementation of Types.CompUnit.t
 val obj_path: string list ref
 
 val compile: bool -> Types.CompUnit.t -> string -> unit
-val run:  Value.t -> Types.CompUnit.t -> unit
+val run: Types.CompUnit.t -> unit
 val import: Types.CompUnit.t -> unit
+val import_and_run: Types.CompUnit.t -> unit
 val save: Types.CompUnit.t -> string -> unit
 

driver/run.ml

@@ -169,7 +169,7 @@ let toploop () =
 let argv args = 
   Value.sequence (List.rev_map Value.string_latin1 args)
 
-let restore argv =
+let restore () =
   match !load_dump with
     | Some f ->
 	(try 
@@ -182,8 +182,7 @@ let restore argv =
 	 with Sys_error _ ->  
 	   Format.fprintf ppf "failed ...@.")
     | None -> 
-	let t = Sequence.star Sequence.string in
-	Cduce.enter_global_value (ident (U.mk "argv")) argv t
+	()
 
 let save () =
   match !save_dump with
@@ -198,15 +197,18 @@ let save () =
 let main () = 
   match mode () with
     | `Toplevel args ->
-	restore (argv args);
+	Builtin.argv := argv args;
+	restore ();
 	toploop ();
 	save ()
     | `Script (f,args) ->
-	Cduce.compile_run f (argv args)
+	Builtin.argv := argv args;
+	Cduce.compile_run f
     | `Compile (f,o) ->
 	Cduce.compile f o
     | `Run (f,args) ->
-	Cduce.run f (argv args)
+	Builtin.argv := argv args;
+	Cduce.run f
 	 
 let () = 
 (* Hum... *)

parser/parser.ml

@@ -271,7 +271,7 @@ EXTEND
 	   | IDENT "load_xml"
 	   | IDENT "load_file" | IDENT "load_file_utf8"
 	   | IDENT "float_of"
-           | IDENT "getenv"
+           | IDENT "getenv" | IDENT "argv"
 	   | IDENT "load_html"
 	   | IDENT "print_xml" | IDENT "print_xml_utf8"
 	   | IDENT "print"

runtime/eval.ml

@@ -57,16 +57,22 @@ let push x =
   set stack !sp x;
   incr sp
 
-let from_comp_unit = ref (fun cu pos -> assert false)
+let pop () =
+  decr sp;
+  !stack.(!sp)
+
+let get_global = ref (fun cu pos -> assert false)
+let set_global = ref (fun cu pos -> assert false)
+
 
 let eval_var env = function
   | Env i -> env.(i)
-  | Global i -> !stack.(i)
   | Stack i -> !stack.(!frame + i) 
   | Dummy -> Value.Absent
+  | Global i -> !stack.(i)
   | Ext (cu,pos) as x ->
       if pos < 0 then (Obj.magic cu : Value.t) else
-	let v = !from_comp_unit cu pos in
+	let v = !get_global cu pos in
 	let x = Obj.repr x in
 	Obj.set_field x 0 (Obj.repr v);