[r2004-06-28 18:24:35 by afrisch] Delay the allocation of slots for externals

Original author: afrisch
Date: 2004-06-28 18:24:35+00:00

compile/compile.ml

@@ -17,9 +17,9 @@ let dump ppf env =
     env.vars
 
 
-let mk cu g = { cu = cu; vars = Env.empty; stack_size = 0; global_size = g }
-let empty_toplevel = mk None 0
-let empty x g = mk (Some x) g
+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 =
@@ -84,7 +84,7 @@ and compile_aux env tail = function
   | Typed.Ref (e,t) ->  Ref (compile env tail e, t)
   | Typed.External (t,i) -> 
       (match env.cu with
-	 | Some cu -> Var (Ext (cu,i))
+	 | Some cu -> Var (External (cu,i))
 	 | None -> failwith "Cannot compile externals in the toplevel")
 
 and compile_abstr env a =
@@ -101,7 +101,7 @@ and compile_abstr env a =
 	       p::slots,
 	       succ nb_slots,
 	       Env.add x (Env nb_slots) fun_env;
-	   | Global _ | Ext _ as p -> 
+	   | Global _ | Ext _ | External _ as p -> 
 	       slots,
 	       nb_slots,
 	       Env.add x p fun_env

compile/compile.mli

@@ -7,17 +7,11 @@ val from_comp_unit: (Types.CompUnit.t -> env) ref
 
 val dump: Format.formatter -> env -> unit
 
-val empty : Types.CompUnit.t -> int -> env
-  (* integer: number of already allocated globals *)
-
+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 find_slot : id -> env -> int
 

compile/lambda.ml

@@ -4,6 +4,8 @@ type var_loc =
   | Stack of int
   | Env of int
   | Ext of Types.CompUnit.t * int (* If pos < 0, the first arg is the value *)
+  | External of Types.CompUnit.t * int 
+      (* If pos < 0, the first arg is the value *)
   | Global of int (* Only for the toplevel *)
   | Dummy
 
@@ -11,6 +13,7 @@ let print_var_loc ppf = function
   | Stack i -> Format.fprintf ppf "Stack %i" i
   | Env i -> Format.fprintf ppf "Env %i" i
   | Ext (cu,i) -> Format.fprintf ppf "Ext (_,%i)" i
+  | External (cu,i) -> Format.fprintf ppf "External (_,%i)" i
   | Global i -> Format.fprintf ppf "Global %i" i
   | Dummy -> Format.fprintf ppf "Dummy"
 
@@ -90,17 +93,21 @@ module Put = struct
 
   let var_loc s = function
     | Stack i ->
-	bits 2 s 0;
+	bits 3 s 0;
 	int s i
     | Ext (cu,i) ->
-	bits 2 s 1;
+	bits 3 s 1;
+	Types.CompUnit.serialize s cu;
+	int s i
+    | External (cu,i) ->
+	bits 3 s 2;
 	Types.CompUnit.serialize s cu;
 	int s i
     | Env i ->
-	bits 2 s 2;
+	bits 3 s 3;
 	int s i
     | Dummy ->
-	bits 2 s 3
+	bits 3 s 4
     | Global _ -> assert false
 	
   let rec expr s = function
@@ -207,14 +214,18 @@ module Get = struct
   open Serialize.Get
 
   let var_loc s =
-    match bits 2 s with
+    match bits 3 s with
       | 0 -> Stack (int s)
       | 1 ->
 	  let cu = Types.CompUnit.deserialize s in
 	  let pos = int s in
 	  Ext (cu,pos)
-      | 2 -> Env (int s)
-      | 3 -> Dummy
+      | 2 ->
+	  let cu = Types.CompUnit.deserialize s in
+	  let pos = int s in
+	  External (cu,pos)
+      | 3 -> Env (int s)
+      | 4 -> Dummy
       | _ -> assert false
 
   let rec expr s =

driver/librarian.ml

@@ -18,22 +18,26 @@ type t = {
   compile: Compile.env;
   code: Lambda.code_item list;
   types: Types.t array;
+  has_ext: bool;
 
   mutable digest: Digest.t option;
   vals: Value.t array;
+  mutable exts: Value.t array;
   mutable depends: C.t list;
   mutable status: [ `Evaluating | `Unevaluated | `Evaluated ];
 
   mutable stub : stub_ml option
 }
 
-let mk ((typing,compile,code),types) =
+let mk ((typing,compile,code),types,ext) =
   { typing = typing;
     compile = compile;
     code = code;
     types = types;
+    has_ext = ext;
     digest = None;
     vals = Array.make (Compile.global_size compile) Value.Absent;
+    exts = [| |];
     depends = [];
     status = `Unevaluated;
     stub = None
@@ -54,7 +58,8 @@ let serialize s cu =
   Typer.serialize s cu.typing;
   Compile.serialize s cu.compile;
   Lambda.Put.codes s cu.code;
-  Serialize.Put.array Types.serialize s cu.types
+  Serialize.Put.array Types.serialize s cu.types;
+  Serialize.Put.bool s cu.has_ext
 
 let deserialize s =
   Serialize.Get.magic s magic;
@@ -62,7 +67,8 @@ let deserialize s =
   let compile = Compile.deserialize s in
   let code = Lambda.Get.codes s in
   let types = Serialize.Get.array Types.deserialize s in
-  mk ((typing,compile,code),types)
+  let ext = Serialize.Get.bool s in
+  mk ((typing,compile,code),types,ext)
 
 (*
 let serialize_dep=
@@ -167,11 +173,12 @@ let rec compile verbose name id src =
     Compile.comp_unit 
       ?show
       Builtin.env
-      (Compile.empty id (Externals.nb ()))
+      (Compile.empty id)
       p
   in
   let stub,types = !stub_ml name ty_env c_env in
-  let cu = mk (cu,types) in
+  let ext = Externals.nb () > 0 in
+  let cu = mk (cu,types,ext) in
   cu.stub <- stub;
   C.Tbl.add tbl id cu;
   C.leave ();
@@ -238,6 +245,10 @@ let rec run id =
   let cu = find id in
   match cu.status with
     | `Unevaluated -> 
+	if cu.has_ext && (Array.length cu.exts = 0) then
+	  failwith
+	    ("Librarian.run. This module needs externals:" ^ 
+	     (U.to_string (C.value id)));
 	List.iter run cu.depends;
 	cu.status <- `Evaluating;
 	Eval.code_items cu.code;
@@ -268,10 +279,10 @@ let () =
   Typer.from_comp_unit := (fun cu -> (load cu).typing);
   Compile.from_comp_unit := (fun cu -> (load cu).compile);
   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
-			cu.vals.(i) <- v)
-
+  Eval.set_global := (fun cu i v -> import cu; (load cu).vals.(i) <- v);
+  Eval.get_external := (fun cu i -> (load cu).exts.(i))
     
 
+let set_externals cu a = (load cu).exts <- a
+
 let registered_types cu = (load cu).types

driver/librarian.mli

@@ -21,6 +21,8 @@ val save: string -> Types.CompUnit.t -> string -> unit
 
 val registered_types: Types.CompUnit.t -> Types.t array
 
+val set_externals: Types.CompUnit.t -> Value.t array -> unit
+
 
 type stub_ml
 val stub_ml : (string -> Typer.t -> Compile.env -> 

ocamliface/mlstub.ml

@@ -461,14 +461,8 @@ let check_value ty_env c_env (s,caml_t,t) =
 
 let stub name ty_env c_env values =
   let items = List.map (check_value ty_env c_env) values in
-  let exts = 
-    List.map 
-      (fun (s,i,t) ->
-	 let c = to_cd <:expr< $lid:s$ >> t in
-	 <:str_item< Eval.set_slot cu $int:string_of_int i$ $c$ >>
-      ) !exts in
-
 
+  let exts = List.rev_map (fun (s,t) -> to_cd <:expr< $lid:s$ >> t) !exts in
   let g = global_transl () in
 
   (* 
@@ -492,7 +486,7 @@ let stub name ty_env c_env values =
     [ <:str_item< open CDuce_all >>;
       <:str_item< value types = Librarian.registered_types cu >> ] @
     (if g = [] then [] else [ <:str_item< value rec $list:g$ >> ]) @
-    [ <:str_item< declare $list:exts$ end >>;
+    [ <:str_item< Librarian.set_externals cu [|$list:exts$|] >>;
     <:str_item< Librarian.run cu >> ] @
     (if items = [] then [] else [ <:str_item< value $list:items_def$ >> ]) in
 
@@ -520,7 +514,7 @@ let () =
      with Mltypes.Error s -> raise (Location.Generic s)
   );
 
-  Externals.resolve :=
+  Externals.register :=
   (fun i s args ->
      let (t,n) = 
        try Mltypes.find_value s 
@@ -534,12 +528,10 @@ let () =
 	 Printf.eprintf "Wrong arity for external symbol %s (real arity = %i; given = %i)\n" s n m;
 	 exit 1
        );
-     exts := (s, i, t) :: !exts;
+     exts := (s, t) :: !exts;
 
      vars := Array.of_list args;
      let cdt = Types.descr (typ t) in
-(*     Format.fprintf Format.std_formatter "Instance: %a@."
-       Types.Print.print cdt; *)
      vars := [| |];
      cdt
   )

parser/ast.ml

@@ -72,7 +72,7 @@ and pexpr =
   | Forget of pexpr * ppat    
   | Op of string * pexpr list
   | Ref of pexpr * ppat
-  | External of string * ppat list * int
+  | External of string * ppat list
 
 
 

parser/parser.ml

@@ -218,9 +218,9 @@ EXTEND
     | "fun"; (f,a,b) = fun_decl ->
 	exp loc (Abstraction { fun_name = f; fun_iface = a; fun_body = b })
     | "external"; s = STRING2 ->
-	exp loc (External (s,[],Externals.alloc ()))
+	exp loc (External (s,[]))
     | "external"; "{"; s = STRING2; pl = LIST0 pat; "}" ->
-	exp loc (External (s,pl,Externals.alloc ()))
+	exp loc (External (s,pl))
     | (_,p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
         exp loc (Match (e1,[p,e2]))
     | (name,ns) = namespace_binding; "in"; e2 = expr LEVEL "top" ->

runtime/eval.ml

@@ -63,6 +63,8 @@ let pop () =
 
 let get_global = ref (fun cu pos -> assert false)
 let set_global = ref (fun cu pos -> assert false)
+let get_external = ref (fun cu pos -> assert false)
+let set_external = ref (fun cu pos -> assert false)
 
 let get_slot cu pos = !get_global cu pos
 let set_slot cu pos v = !set_global cu pos v
@@ -79,6 +81,13 @@ let eval_var env = function
 	Obj.set_field x 0 (Obj.repr v);
 	Obj.set_field x 1 (Obj.repr (-1));
 	v
+  | External (cu,pos) as x ->
+      if pos < 0 then (Obj.magic cu : Value.t) else
+	let v = !get_external cu pos in
+	let x = Obj.repr x in
+	Obj.set_field x 0 (Obj.repr v);
+	Obj.set_field x 1 (Obj.repr (-1));
+	v
 
 let rec eval env = function
   | Var x -> eval_var env x

runtime/eval.mli

@@ -7,6 +7,8 @@ val eval_binary_op : (int -> (t -> t -> t)) ref
 
 val get_global: (Types.CompUnit.t -> int -> t) ref
 val set_global: (Types.CompUnit.t -> int -> t -> unit) ref
+val get_external: (Types.CompUnit.t -> int -> t) ref
+val set_external: (Types.CompUnit.t -> int -> t -> unit) ref
 
 val get_slot : Types.CompUnit.t -> int -> t
 val set_slot : Types.CompUnit.t -> int -> t -> unit

tests/ocaml/Makefile

 # Do "make install_cdml" before running this test
 
-STATIC=-static
-CAML=ocamlopt
+STATIC=
+CAML=ocamlc
 
 CDUCE=../../cduce
 CDO2ML=../../cdo2ml

types/externals.ml

 let nb_ext_syms = ref 0
 
-let alloc () =
-  let i = !nb_ext_syms in
-  incr nb_ext_syms;
-  i
-
 let nb () = !nb_ext_syms
 
-let resolve = ref (fun i s args -> assert false)
+let register = ref (fun i s args -> assert false)
+
+let resolve s args =
+  let i = !nb_ext_syms in
+  incr nb_ext_syms;
+  (i, !register i s args)

types/externals.mli

-val alloc : unit -> int
 val nb: unit -> int
 
-val resolve: ref (int -> string -> Types.Node.t list -> Types.t)
+val register: ref (int -> string -> Types.Node.t list -> Types.t)
+
+val resolve: string -> Types.Node.t list -> int * Types.t 

typing/typer.ml

@@ -939,9 +939,9 @@ let rec expr env loc = function
   | Ref (e,t) ->
       let (fv,e) = expr env loc e and t = typ env t in
       exp loc fv (Typed.Ref (e,t))
-  | External (s,args,i) ->
+  | External (s,args) ->
       let args = List.map (typ env) args in
-      let t = !Externals.resolve i s args in
+      let (i,t) = Externals.resolve s args in
       exp loc Fv.empty (Typed.External (t,i))
 	      
   and branches env b =