[r2004-06-28 01:16:40 by afrisch] Fix capture in stub gen, registered types, functions

Original author: afrisch
Date: 2004-06-28 01:16:40+00:00

Makefile.distrib

@@ -193,7 +193,7 @@ ALL_OBJECTS = $(OBJECTS) $(CQL_OBJECTS) \
 ALL_INTERFACES = schema/schema_types.mli 
 
 ifneq ($(ML_INTERFACE), false)
-  ALL_INTERFACES += ocamliface/mltypes.mli ocamluface/mlstub.mli
+  ALL_INTERFACES += ocamliface/mltypes.mli ocamliface/mlstub.mli
 endif
 
 DEPEND = $(ALL_OBJECTS:.cmo=.ml) $(ALL_OBJECTS:.cmo=.mli) $(ALL_INTERFACES)

depend

@@ -220,28 +220,30 @@ driver/librarian.cmx: types/builtin.cmx compile/compile.cmx \
     misc/encodings.cmx runtime/eval.cmx types/ident.cmx compile/lambda.cmx \
     parser/location.cmx parser/parser.cmx misc/serialize.cmx typing/typer.cmx \
     types/types.cmx runtime/value.cmx driver/librarian.cmi 
-ocamliface/mltypes.cmo: cdo2cmo/asttypes.cmo types/ident.cmo types/types.cmi \
-    ocamliface/mltypes.cmi 
-ocamliface/mltypes.cmx: cdo2cmo/asttypes.cmx types/ident.cmx types/types.cmx \
-    ocamliface/mltypes.cmi 
+ocamliface/mltypes.cmo: cdo2cmo/asttypes.cmo types/ident.cmo \
+    driver/librarian.cmi types/types.cmi ocamliface/mltypes.cmi 
+ocamliface/mltypes.cmx: cdo2cmo/asttypes.cmx types/ident.cmx \
+    driver/librarian.cmx types/types.cmx ocamliface/mltypes.cmi 
 ocamliface/mlstub.cmo: types/atoms.cmi types/builtin_defs.cmi \
-    compile/compile.cmi types/ident.cmo ocamliface/mltypes.cmi misc/ns.cmi \
-    types/sequence.cmi typing/typer.cmi types/types.cmi ocamliface/mlstub.cmi 
+    compile/compile.cmi types/ident.cmo driver/librarian.cmi \
+    ocamliface/mltypes.cmi misc/ns.cmi types/sequence.cmi typing/typer.cmi \
+    types/types.cmi ocamliface/mlstub.cmi 
 ocamliface/mlstub.cmx: types/atoms.cmx types/builtin_defs.cmx \
-    compile/compile.cmx types/ident.cmx ocamliface/mltypes.cmx misc/ns.cmx \
-    types/sequence.cmx typing/typer.cmx types/types.cmx ocamliface/mlstub.cmi 
+    compile/compile.cmx types/ident.cmx driver/librarian.cmx \
+    ocamliface/mltypes.cmx misc/ns.cmx types/sequence.cmx typing/typer.cmx \
+    types/types.cmx ocamliface/mlstub.cmi 
 driver/cduce.cmo: parser/ast.cmo types/builtin.cmi compile/compile.cmi \
     misc/encodings.cmi runtime/eval.cmi runtime/explain.cmi types/ident.cmo \
-    driver/librarian.cmi parser/location.cmi ocamliface/mlstub.cmi \
-    ocamliface/mltypes.cmi misc/ns.cmi parser/parser.cmi types/patterns.cmi \
-    types/sample.cmi schema/schema_common.cmi misc/state.cmi typing/typer.cmi \
-    types/types.cmi parser/ulexer.cmi runtime/value.cmi driver/cduce.cmi 
+    driver/librarian.cmi parser/location.cmi misc/ns.cmi parser/parser.cmi \
+    types/patterns.cmi types/sample.cmi schema/schema_common.cmi \
+    misc/state.cmi typing/typer.cmi types/types.cmi parser/ulexer.cmi \
+    runtime/value.cmi driver/cduce.cmi 
 driver/cduce.cmx: parser/ast.cmx types/builtin.cmx compile/compile.cmx \
     misc/encodings.cmx runtime/eval.cmx runtime/explain.cmx types/ident.cmx \
-    driver/librarian.cmx parser/location.cmx ocamliface/mlstub.cmx \
-    ocamliface/mltypes.cmx misc/ns.cmx parser/parser.cmx types/patterns.cmx \
-    types/sample.cmx schema/schema_common.cmx misc/state.cmx typing/typer.cmx \
-    types/types.cmx parser/ulexer.cmx runtime/value.cmx driver/cduce.cmi 
+    driver/librarian.cmx parser/location.cmx misc/ns.cmx parser/parser.cmx \
+    types/patterns.cmx types/sample.cmx schema/schema_common.cmx \
+    misc/state.cmx typing/typer.cmx types/types.cmx parser/ulexer.cmx \
+    runtime/value.cmx driver/cduce.cmi 
 query/query.cmo: parser/ast.cmo types/atoms.cmi types/builtin_defs.cmi \
     types/chars.cmi types/ident.cmo types/intervals.cmi parser/location.cmi \
     parser/parser.cmi types/types.cmi query/query.cmi 

driver/cduce.ml

@@ -275,18 +275,6 @@ let run rule ppf ppf_err input =
 let topinput = run Parser.top_phrases
 let script = run Parser.prog
 
-ifdef ML_INTERFACE then 
-  let stub_ml cu id =
-    try
-      let name = String.capitalize cu in
-      let (prolog, values) = Mltypes.read_cmi name in
-      let stub = Mlstub.stub cu id values in
-      Some (prolog,stub)
-    with 
-      | Mltypes.Error s -> raise (Generic s)
-      | Not_found -> Printf.eprintf "Warning: no caml interface\n"; None
-else 
-  let stub_ml cu id = None;;
 
 let compile src out_dir =
   try
@@ -299,9 +287,8 @@ let compile src out_dir =
 	| Some x -> x in
     let out = Filename.concat out_dir (cu ^ ".cdo") in
     let id = Types.CompUnit.mk (U.mk_latin1 cu) in
-    Librarian.compile !verbose id src;
-    let stub = stub_ml cu id in
-    Librarian.save id out stub;
+    Librarian.compile !verbose cu id src;
+    Librarian.save id out;
     exit 0
   with exn -> catch_exn Format.err_formatter exn; exit 1
   
@@ -311,7 +298,7 @@ let compile_run src =
     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.compile !verbose cu id src;
     Librarian.run id
   with exn -> catch_exn Format.err_formatter exn; exit 1
 

driver/librarian.ml

 open Location
 open Ident
 
+type stub_ml
+let stub_ml = ref (fun cu ty_env c_env -> None, [| |])
+
+
 module C = Types.CompUnit
 
 exception InconsistentCrc of C.t
@@ -13,20 +17,26 @@ type t = {
   typing: Typer.t;
   compile: Compile.env;
   code: Lambda.code_item list;
+  types: Types.t array;
+
   mutable digest: Digest.t option;
   vals: Value.t array;
   mutable depends: C.t list;
-  mutable status: [ `Evaluating | `Unevaluated | `Evaluated ]
+  mutable status: [ `Evaluating | `Unevaluated | `Evaluated ];
+
+  mutable stub : stub_ml option
 }
 
-let mk (typing,compile,code) =
+let mk ((typing,compile,code),types) =
   { typing = typing;
     compile = compile;
     code = code;
+    types = types;
     digest = None;
     vals = Array.make (Compile.global_size compile) Value.Absent;
     depends = [];
     status = `Unevaluated;
+    stub = None
   }
 
 let magic = "CDUCE:compunit:00003"
@@ -43,14 +53,16 @@ let serialize s cu =
   Serialize.Put.magic s magic;
   Typer.serialize s cu.typing;
   Compile.serialize s cu.compile;
-  Lambda.Put.codes s cu.code
+  Lambda.Put.codes s cu.code;
+  Serialize.Put.array Types.serialize s cu.types
 
 let deserialize s =
   Serialize.Get.magic s magic;
   let typing = Typer.deserialize s in
   let compile = Compile.deserialize s in
   let code = Lambda.Get.codes s in
-  mk (typing,compile,code)
+  let types = Serialize.Get.array Types.deserialize s in
+  mk ((typing,compile,code),types)
 
 let serialize_dep=
   Serialize.Put.list 
@@ -67,9 +79,11 @@ let find_obj id =
     List.find (fun p -> Sys.file_exists (Filename.concat p base)) !obj_path in
   Filename.concat p base
 
-let save id out extra =
+let save id out =
   protect_op "Save compilation unit";
+
   let cu = find id in
+
   C.enter id;
   let raw = Serialize.Put.run serialize cu in
   let depend = C.close_serialize () in
@@ -92,7 +106,7 @@ let save id out extra =
   let depend = Serialize.Put.run serialize_dep depend in
   let digest = Digest.string raw in
   let oc = open_out out in
-  Marshal.to_channel oc (digest,depend,raw,extra) [];
+  Marshal.to_channel oc (digest,depend,raw,cu.stub) [];
   close_out oc
   
   
@@ -123,7 +137,9 @@ let show ppf id t v =
 	Types.Print.print t 
     | None -> ()
 
-let rec compile verbose id src =
+
+
+let rec compile verbose name id src =
   check_loop id;
   protect_op "Compile external file";
   let ic = 
@@ -145,14 +161,16 @@ let rec compile verbose id src =
     if verbose 
     then Some (show Format.std_formatter)
     else None in
-  let cu =
+  let (ty_env,c_env,_) as cu =
     Compile.comp_unit 
       ?show
       Builtin.env
       (Compile.empty id)
       p
   in
-  let cu = mk cu in
+  let stub,types = !stub_ml name ty_env c_env in
+  let cu = mk (cu,types) in
+  cu.stub <- stub;
   C.Tbl.add tbl id cu;
   C.leave ();
   during_compile := false;
@@ -233,3 +251,4 @@ let () =
 			  | _ -> assert false);;
     
 
+let registered_types cu = (load cu).types

driver/librarian.mli

@@ -6,9 +6,15 @@ exception NoImplementation of Types.CompUnit.t
 
 val obj_path: string list ref
 
-val compile: bool -> Types.CompUnit.t -> string -> unit
+val compile: bool -> string -> Types.CompUnit.t -> string -> 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 -> 'a -> unit
+val save: Types.CompUnit.t -> string -> unit
 
+val registered_types: Types.CompUnit.t -> Types.t array
+
+
+type stub_ml
+val stub_ml : (string -> Typer.t -> Compile.env -> 
+		 stub_ml option * Types.t array) ref

ocamliface/mlstub.ml

@@ -67,10 +67,12 @@ and variant = function
 
 (* Syntactic tools *)
 
+let var_counter = ref 0
+let mk_var _ =
+  incr var_counter;
+  Printf.sprintf "x%i" !var_counter
 
-let mk_vars l = 
-  let i = ref 0 in
-  List.map (fun t -> incr i; Printf.sprintf "x%i" !i) l
+let mk_vars = List.map mk_var
 
 let loc = (-1,-1)
 
@@ -93,15 +95,39 @@ let rec matches ine oute = function
   | [v1;v2] ->
       let_in <:patt<($lid:v1$,$lid:v2$)>> <:expr< Value.get_pair $ine$ >> oute
   | v::vl ->
-      let oute = matches <:expr< r >> oute vl in
-      let_in <:patt<($lid:v$,r)>> <:expr< Value.get_pair $ine$ >> oute
+      let r = mk_var () in
+      let oute = matches <:expr< $lid:r$ >> oute vl in
+      let_in <:patt<($lid:v$,$lid:r$)>> <:expr< Value.get_pair $ine$ >> oute
   | [] -> assert false
 
 let list_lit el =
   List.fold_right (fun a e -> <:expr< [$a$ :: $e$] >>) el <:expr< [] >>
 
+(* Registered types *)
+
+module HashTypes = Hashtbl.Make(Types)
+let registered_types = HashTypes.create 13
+let nb_registered_types = ref 0
+
+let register_type t =
+  let n =
+    try HashTypes.find registered_types t
+    with Not_found ->
+      let i = !nb_registered_types in
+      HashTypes.add registered_types t i;
+      incr nb_registered_types;
+      i 
+  in
+  <:expr< types.($int:string_of_int n$) >>
+
+let get_registered_types () =
+  let a = Array.make !nb_registered_types Types.empty in
+  HashTypes.iter (fun t i -> a.(i) <- t) registered_types;
+  a
+
 (* OCaml -> CDuce conversions *)
 
+
 let to_cd_gen = ref []
 
 let to_cd_fun_name t = 
@@ -111,6 +137,15 @@ let to_cd_fun t =
   to_cd_gen := t :: !to_cd_gen;
   to_cd_fun_name t
 
+let to_ml_gen = ref []
+
+let to_ml_fun_name t =
+  Printf.sprintf "to_ml_%i" t.uid
+
+let to_ml_fun t =
+  to_ml_gen := t :: !to_ml_gen;
+  to_ml_fun_name t
+
 let rec tuple = function
   | [v] -> v
   | v::l -> <:expr< Value.Pair ($v$, $tuple l$) >> 
@@ -129,7 +164,15 @@ let rec to_cd e t =
 
 and to_cd_descr e = function
   | Link t -> to_cd e t
-  | Arrow (t,s) -> failwith "to_cd: Arrow. TODO"
+  | Arrow (t,s) -> 
+      (* Value.Abstraction (t,s, fun x -> s(<...> (t(x))) *)
+      let x = mk_var () in
+      let arg = to_ml <:expr< $lid:x$ >> t in
+      let res = to_cd <:expr< $e$ $arg$ >> s in
+      let abs = <:expr< fun $lid:x$ -> $res$ >> in
+      let tt = register_type (Types.descr (typ t)) in
+      let ss = register_type (Types.descr (typ s)) in
+      <:expr< Value.Abstraction ($tt$,$ss$,$abs$) >>
   | Tuple tl -> 
       (* let (x1,...,xn) = ... in Value.Pair (t1(x1), Value.Pair(...,tn(xn))) *)
       let vars = mk_vars tl in
@@ -165,14 +208,15 @@ and to_cd_descr e = function
       pmatch e cases
   | Record (l,_) ->
       (* let x = <...> in Value.record [ l1,t1(x.l1); ...; ln,x.ln ] *)
+      let x = mk_var () in
       let l = 
 	List.map
 	  (fun (lab,t) ->
-	     let e = to_cd <:expr<x.$lid:lab$>> t in
+	     let e = to_cd <:expr<$lid:x$.$lid:lab$>> t in
 	     <:expr< ($label_ascii lab$, $e$) >>)
 	  l
       in
-      let_in <:patt< x >> e <:expr< Value.record $list_lit l$ >>
+      let_in <:patt< $lid:x$ >> e <:expr< Value.record $list_lit l$ >>
       
   | Abstract "int" -> <:expr< ocaml2cduce_int $e$ >>
   | Abstract "char" -> <:expr< ocaml2cduce_char $e$ >>
@@ -191,16 +235,9 @@ and tuple_to_cd tl vars = List.map2 (fun t id -> to_cd <:expr< $lid:id$ >> t) tl
 
 (* CDuce -> OCaml conversions *)
 
-let to_ml_gen = ref []
-
-let to_ml_fun_name t =
-  Printf.sprintf "to_ml_%i" t.uid
 
-let to_ml_fun t =
-  to_ml_gen := t :: !to_ml_gen;
-  to_ml_fun_name t
 
-let rec to_ml e t =
+and to_ml e t =
 (*  Format.fprintf Format.std_formatter "to_ml %a@."
     Mltypes.print t; *)
   if t.recurs > 0 then <:expr< $lid:to_ml_fun t$ $e$ >>
@@ -210,9 +247,10 @@ and to_ml_descr e = function
   | Link t -> to_ml e t
   | Arrow (t,s) -> 
       (* fun x -> s(Eval.eval_apply <...> (t(x))) *)
-      let arg = to_cd <:expr< x >> t in
+      let x = mk_var () in
+      let arg = to_cd <:expr< $lid:x$ >> t in
       let res = to_ml <:expr< Eval.eval_apply $e$ $arg$ >> s in
-      <:expr< fun x -> $res$ >>
+      <:expr< fun $lid:x$ -> $res$ >>
 
   | Tuple tl -> 
       (* let (x1,r) = Value.get_pair <...> in
@@ -229,6 +267,7 @@ and to_ml_descr e = function
 	 | "A",None -> `A 
 	 | "B",Some x -> `B (t(x))
       *)
+      let x = mk_var () in
       let cases = 
 	List.map 
 	  (function 
@@ -236,8 +275,10 @@ and to_ml_descr e = function
 		 <:patt< ($str: String.escaped lab$, None) >>,
 		 <:expr< `$lid:lab$ >>
 	     | (lab,Some t) ->
-		 <:patt< ($str: String.escaped lab$, Some x) >>,
-		 <:expr< `$lid:lab$ $to_ml <:expr< x >> t$ >>
+		 let x = mk_var () in
+		 let ex = <:expr< $lid:x$ >> in
+		 <:patt< ($str: String.escaped lab$, Some $lid:x$) >>,
+		 <:expr< `$lid:lab$ $to_ml ex t$ >>
 	  ) l in
       pmatch <:expr< Value.get_variant $e$ >> cases
   | Variant (l,false) ->
@@ -257,13 +298,17 @@ and to_ml_descr e = function
 		    | "false" -> <:expr< False >>
 		    | lab -> <:expr< $lid:lab$ >>)
 	     | (lab,[t]) ->
-		 <:patt< ($str: String.escaped lab$, Some x) >>,
-		 <:expr< $lid:lab$ $to_ml <:expr< x >> t$ >>
+		 let x = mk_var () in
+		 let ex = <:expr< $lid:x$ >> in
+		 <:patt< ($str: String.escaped lab$, Some $lid:x$) >>,
+		 <:expr< $lid:lab$ $to_ml ex t$ >>
 	     | (lab,tl) ->
 		 let vars = mk_vars tl in
 		 let el = tuple_to_ml tl vars in
-		 <:patt< ($str: String.escaped lab$, Some x) >>,
-		 matches <:expr< x >> <:expr< $lid:lab$ ($list:el$) >> vars
+		 let x = mk_var () in
+		 <:patt< ($str: String.escaped lab$, Some $lid:x$) >>,
+		 matches <:expr< $lid:x$ >> 
+		         <:expr< $lid:lab$ ($list:el$) >> vars
 	  ) l in
       pmatch <:expr< Value.get_variant $e$ >> cases
   | Record (l,false) ->
@@ -271,12 +316,13 @@ and to_ml_descr e = function
   | Record (l,true) ->
       (* let x = <...> in
 	 { l1 = t1(Value.get_field x "l1"); ... } *)
+      let x = mk_var () in
       let l = 
 	List.map
 	  (fun (lab,t) ->
 	     (<:patt< $uid:lab$>>,
-	      to_ml <:expr< Value.get_field x $label_ascii lab$ >> t)) l in
-      let_in <:patt< x >> e <:expr< {$list:l$} >>
+	      to_ml <:expr< Value.get_field $lid:x$ $label_ascii lab$ >> t)) l in
+      let_in <:patt< $lid:x$ >> e <:expr< {$list:l$} >>
 
   | Abstract "int" -> <:expr< cduce2ocaml_int $e$ >>
   | Abstract "char" -> <:expr< cduce2ocaml_char $e$ >>
@@ -359,11 +405,10 @@ let check_value ty_env c_env (s,caml_t,t) =
   let e = to_ml <:expr< Eval.get_slot cu $int:string_of_int slot$ >> t in
   <:patt< $uid:s$ >>, e
 
-let stub name cu values =
-  let ty_env = !Typer.from_comp_unit cu in
-  let c_env = !Compile.from_comp_unit cu in
+let stub name ty_env c_env values =
   let items = List.map (check_value ty_env c_env) values in
   let g = global_transl () in
+  
 
   (* open Cdml
      open CDuce_all
@@ -374,9 +419,22 @@ let stub name cu values =
 
   [ <:str_item< open Cdml >>;
     <:str_item< open CDuce_all >>;
-    <:str_item< value cu = Cdml.initialize $str: String.escaped name$ >> ] @
+    <:str_item< value cu = Cdml.initialize $str: String.escaped name$ >>;
+    <:str_item< value types = Librarian.registered_types cu >>
+  ] @
   (if g = [] then [] else [ <:str_item< value rec $list:g$ >> ]) @
   [ <:str_item< value $list:items$ >> ]
 
 
 
+let () =
+  Librarian.stub_ml := fun cu ty_env c_env ->
+    try
+      let name = String.capitalize cu in
+      let (prolog, values) = Mltypes.read_cmi name in
+      let code = stub cu ty_env c_env values in
+      Some (Obj.magic (prolog,code)),
+      get_registered_types ()
+    with 
+      | Mltypes.Error s -> raise (Location.Generic s)
+      | Not_found -> Printf.eprintf "Warning: no caml interface\n"; None, [||]

ocamliface/mlstub.mli

-val stub: 
-  string -> Types.CompUnit.t -> (string * OCaml_all.Types.type_expr * Mltypes.t ) list -> 
-  MLast.str_item list
+(* nothing *)