[r2004-06-28 04:51:58 by afrisch] -static

Original author: afrisch
Date: 2004-06-28 04:51:59+00:00

driver/cduce.ml

@@ -288,7 +288,7 @@ let compile src out_dir =
     let out = Filename.concat out_dir (cu ^ ".cdo") in
     let id = Types.CompUnit.mk (U.mk_latin1 cu) in
     Librarian.compile !verbose cu id src;
-    Librarian.save id out;
+    Librarian.save cu id out;
     exit 0
   with exn -> catch_exn Format.err_formatter exn; exit 1
   

driver/librarian.ml

@@ -64,6 +64,7 @@ let deserialize s =
   let types = Serialize.Get.array Types.deserialize s in
   mk ((typing,compile,code),types)
 
+(*
 let serialize_dep=
   Serialize.Put.list 
     (Serialize.Put.pair Encodings.Utf8.serialize Serialize.Put.string)
@@ -71,6 +72,7 @@ let serialize_dep=
 let deserialize_dep =
   Serialize.Get.list
     (Serialize.Get.pair Encodings.Utf8.deserialize Serialize.Get.string)
+*)
 
 
 let find_obj id = 
@@ -79,7 +81,7 @@ 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 =
+let save name id out =
   protect_op "Save compilation unit";
 
   let cu = find id in
@@ -103,10 +105,10 @@ let save id out =
       ) depend
     with Not_found -> assert false in
 
-  let depend = Serialize.Put.run serialize_dep depend in
+(*  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,cu.stub) [];
+  Marshal.to_channel oc (name,digest,depend,raw,cu.stub) [];
   close_out oc
   
   
@@ -192,28 +194,40 @@ let rec load id =
       try open_in obj
       with Sys_error _ -> raise (CannotOpen obj) in
 
-    let (dig, depend, raw, stub) = 
+    let (name, dig, depend, raw, stub) = 
       try Marshal.from_channel ic
       with Failure _ | End_of_file -> raise (InvalidObject obj) in
 
     close_in ic;
-    let depend = Serialize.Get.run deserialize_dep depend in
+(*    let depend = Serialize.Get.run deserialize_dep depend in *)
     check_loop id;
     if !during_compile then depends := id :: !depends;
-    List.iter (fun (id,dig) -> load_check (C.mk id) dig) depend;
-    C.enter id;
-    let cu = Serialize.Get.run deserialize raw in
-    C.leave ();
-    cu.depends <- List.map (fun (id,_) -> C.mk id) depend;
-    cu.digest <- Some dig;
-    C.Tbl.add tbl id cu;
-    Typer.register_types id cu.typing;
-    cu
+    load_from_string id raw dig depend
 
 and load_check id exp =
   let cu = load id in
   check_digest id exp cu.digest
 
+and load_from_string id raw dig depend =
+  List.iter (fun (id,dig) -> load_check (C.mk id) dig) depend;
+  C.enter id;
+  let cu = Serialize.Get.run deserialize raw in
+  C.leave ();
+  cu.depends <- List.map (fun (id,_) -> C.mk id) depend;
+  C.Tbl.add tbl id cu;
+  Typer.register_types id cu.typing;
+  cu.digest <- Some dig;
+  cu
+
+let load_from_string id raw dig depend =
+  if C.Tbl.mem tbl id then failwith "Librarian: unit already loaded";
+  load_from_string id raw dig depend
+
+let register_unit id raw dig depend =
+  let id = C.mk (Ident.U.mk id) in
+  let depend = List.map (fun (x,y) -> (Ident.U.mk x,y)) depend in
+  ignore (load_from_string id raw dig depend)
+
 let rec run id =
   let cu = find id in
   match cu.status with
@@ -238,8 +252,12 @@ let rec run id =
   
 let import id = ignore (load id)
 
+let import_check id chk = ignore (load_check id chk)
+
 let import_and_run id = import id; run id
 
+let import_from_string id str dig dep = ignore (load_from_string id str dig dep)
+
 let () =
   Typer.from_comp_unit := (fun cu -> (load cu).typing);
   Compile.from_comp_unit := (fun cu -> (load cu).compile);

driver/librarian.mli

@@ -9,8 +9,12 @@ val obj_path: string list ref
 val compile: bool -> string -> Types.CompUnit.t -> string -> unit
 val run: Types.CompUnit.t -> unit
 val import: Types.CompUnit.t -> unit
+val import_check: Types.CompUnit.t -> Digest.t -> unit
+val import_from_string: Types.CompUnit.t -> string -> string -> (Ident.U.t * Digest.t) list -> unit
+val register_unit: string -> string -> string -> (string * string) list -> unit
+
 val import_and_run: Types.CompUnit.t -> unit
-val save: Types.CompUnit.t -> string -> unit
+val save: string -> Types.CompUnit.t -> string -> unit
 
 val registered_types: Types.CompUnit.t -> Types.t array
 

misc/inttbl.ml

@@ -7,6 +7,7 @@ module type S = sig
   val clear: 'a t -> unit
   val add: 'a t -> key -> 'a -> unit
   val find: 'a t -> key -> 'a
+  val mem: 'a t -> key -> bool
 end
 
 type key = int
@@ -46,3 +47,8 @@ let find t i =
     | None -> raise Not_found
     | Some x -> x
     
+let mem t i =
+  if i >= Array.length !t then false
+  else match (!t).(i) with
+    | None -> false
+    | Some _ -> true

misc/inttbl.mli

@@ -7,6 +7,7 @@ module type S = sig
   val clear: 'a t -> unit
   val add: 'a t -> key -> 'a -> unit
   val find: 'a t -> key -> 'a
+  val mem: 'a t -> key -> bool
 end
 
 include S with type key = int

ocamliface/cdo2ml.ml

 let loc = (-1,-1)
 
 let usage =
-"Usage: cdo2ml <module>.cdo
+"Usage: cdo2ml [-static] <module>.cdo
 
  Can also be used as a preprocessor for OCaml:
 
  ocamlc -c -pp cdo2ml -impl <module>.cdo
+ ocamlc -c -pp \"cdo2ml -static\" -impl <module>.cdo
 " 
 
+let err () = prerr_endline usage; exit 1
+
 let () =
-  let fn = 
-    if Array.length Sys.argv != 2 then (prerr_endline usage; exit 1)
-    else Sys.argv.(1) in
+  let fn,static = 
+    match Array.length Sys.argv with
+      | 2 -> Sys.argv.(1),false
+      | 3 ->
+	  if Sys.argv.(1) <> "-static" then err ();
+	  Sys.argv.(2),true
+      | _ -> err ()
+  in
   let ic = 
-    try open_in (Sys.argv.(1))
+    try open_in fn
     with Sys_error x ->
       prerr_endline x;
       exit 1 in
-  let (digest,depend,raw,extra) = input_value ic in
+  let (name,digest,depend,raw,stub) : 
+    string * Digest.t * (string*string) list * string * 
+    (string * MLast.str_item list) option =
+    input_value ic in
   let (prolog,code) = 
-    match extra with
+    match stub with
       | None ->
 	  Printf.eprintf "Error: no stub found in this cdo file !\n";
 	  exit 1
       | Some x -> x in
   print_endline "(* Automatically generated by cdo2ml.ml. Do no edit ! *)";
+
+  if static then (
+    Printf.printf
+		    "let () = CDuce_all.Librarian.register_unit %S %S %S ["
+		    name raw digest;
+    List.iter (fun (cu,chk) -> Printf.printf "(%S,%S)" cu chk) depend;
+    Printf.printf "]\n";
+  );
+
   print_endline prolog;
   let code = List.map (fun x -> (x,loc)) code in
   !Pcaml.print_implem code

ocamliface/mlstub.ml

@@ -460,7 +460,7 @@ let stub name ty_env c_env values =
     <:str_item< Librarian.run cu >>
   ] @
   (if g = [] then [] else [ <:str_item< value rec $list:g$ >> ]) @
-  [ <:str_item< value $list:items$ >> ]
+  (if items = [] then [] else [ <:str_item< value $list:items$ >> ])
 
 
 
@@ -469,13 +469,15 @@ let () =
   (fun cu ty_env c_env ->
      try
        let name = String.capitalize cu in
-       let (prolog, values) = Mltypes.read_cmi name in
+       let (prolog, values) = 
+	 try Mltypes.read_cmi name
+	 with Not_found ->  
+	   Printf.eprintf "Warning: no caml interface\n";
+	   ("",[]) 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, [||]
+     with Mltypes.Error s -> raise (Location.Generic s)
   );
 
   Externals.register_external :=

tests/ocaml/Makefile

@@ -2,9 +2,12 @@
 
 run:
 	ocamlc -c a.mli
+	../../cduce --compile c.cd
 	../../cduce --compile a.cd
-	../../cdo2ml a.cdo > a.ml
-	ocamlfind ocamlc -package cduce -linkpkg -o a a.ml b.ml
+	../../cdo2ml -static c.cdo > c.ml
+	../../cdo2ml -static a.cdo > a.ml
+	ocamlfind ocamlc -package cduce -linkpkg -o a c.ml a.ml b.ml
+	rm *.cdo
 	./a
 
 clean:

tests/ocaml/a.cd

@@ -18,7 +18,7 @@ let pp (x : Any) : Latin1 = string_of x
 
 let exists = external "Sys.file_exists"
 
-let i = 1
+let i = c:j
 
 let home = external "Sys.getenv" "HOME"