trunk/driver/librarian.ml

open Cduce_loc
open Ident


exception InconsistentCrc of U.t
exception InvalidObject of string
exception CannotOpen of string
exception NoImplementation of U.t

let run_loaded = ref false

type t = {
  name: U.t;
  descr: Compunit.t;

  typing: Typer.t;
  compile: Compile.env;
  code: Lambda.code_item list;
  ext_info: Externals.ext_info option;

  mutable digest: Digest.t option;
  vals: Value.t array; (* Exported values *)
  mutable exts: Value.t array;
  mutable depends: (U.t * string) list;


  mutable status: [ `Evaluating | `Unevaluated | `Evaluated ];
}

let digest c = match c.digest with None -> assert false | Some x -> x


module Tbl = Hashtbl.Make(U)
let tbl = Tbl.create 64

module CTbl = Hashtbl.Make(Compunit)
let ctbl = CTbl.create 64

let mk name descr typing compile code ext_info depends =
  { name = name;
    descr = descr;
    typing = typing;
    compile = compile;
    code = code;
    ext_info = ext_info;
    digest = None;
    vals = Array.make (Compile.global_size compile) Value.Absent;
    exts = [| |];
    depends = depends;
    status = `Unevaluated;
  }

let magic = "CDUCE:compunit:00007"

let has_obj n =
  let base = U.to_string n ^ ".cdo" in
  List.exists (fun p -> Sys.file_exists (Filename.concat p base)) !obj_path

let find_obj n = 
  let base = U.to_string n ^ ".cdo" in
  let p = 
    List.find (fun p -> Sys.file_exists (Filename.concat p base)) !obj_path in
  Filename.concat p base
  
let check_digest c dig = 
  if digest c <> dig then raise (InconsistentCrc c.name)

let show ppf id t v =
  match id with
    | Some id ->
        Format.fprintf ppf "@[val %a : @[%a@]@."
        Ident.print id
        Types.Print.print t 
    | None -> ()


let compile verbose name src =
  protect_op "Compile external file";
  let ic = 
    if src = "" then (Cduce_loc.push_source `Stream; stdin)
    else
      try Cduce_loc.push_source (`File src); open_in src
      with Sys_error _ -> raise (CannotOpen src) in
  let input = Stream.of_channel ic in
  let p = 
    try Parser.prog input 
    with
      | Ulexer.Loc.Exc_located (_, (Location _ | Ulexer.Error _ as e)) -> raise e
      | Ulexer.Loc.Exc_located ((i,j), e) -> 
          raise_loc i j e
  in
  if src <> "" then close_in ic;

  let show =
    if verbose 
    then Some (show Format.std_formatter)
    else None in
  Compunit.enter ();
  let descr = Compunit.current () in
  let (ty_env,c_env,code) =
    Compile.comp_unit 
      ?show
      Builtin.env
      (Compile.empty descr)
      p in
  Compunit.leave ();
  let ext = Externals.get () in
  let depends = Tbl.fold (fun name c accu -> (name,digest c) :: accu) tbl [] in

  mk name descr ty_env c_env code ext depends

let set_hash c =
  let h = Hashtbl.hash_param 1000 10000 (c.typing,c.name) in
  let max_rank = 
    Tbl.fold 
      (fun _ c accu -> max accu (fst (Compunit.get_hash c.descr))) tbl 0 in
  Compunit.set_hash c.descr (succ max_rank) h
  (* This invalidates all hash tables on types ! *)


let compile_save verbose name src out =
  protect_op "Save compilation unit";

  let c = compile verbose name src in
  set_hash c;
  let pools = Value.extract_all () in

  let oc = open_out_bin out in
  output_string oc magic;
  
  Marshal.to_channel oc (pools,c) [];
  let digest = Digest.file out in
  Marshal.to_channel oc digest [];
  close_out oc

let from_descr descr : t =
  try CTbl.find ctbl descr
  with Not_found -> 
    let i1,i2 = Compunit.get_hash descr in
    failwith (Printf.sprintf "Can't find cu(%i,%i)" i1 i2)

let register c =
  (* Look for an already loaded unit with the same descriptor *)
  if CTbl.mem ctbl c.descr then failwith "Collision on unit descriptors";
  CTbl.add ctbl c.descr c
 
let reg_types = ref true


let rec real_load src =
  let ic = 
    try open_in_bin src
    with Sys_error _ -> raise (CannotOpen src) in
  try
    let s = String.copy magic in
    really_input ic s 0 (String.length s);
    if s <> magic then raise (InvalidObject src);
    let pools,c = Marshal.from_channel ic in
    let digest = Marshal.from_channel ic in
    c.digest <- Some digest;
    Value.intract_all pools;
    close_in ic;
    c
  with Failure _ | End_of_file -> raise (InvalidObject src)

and load name =
  protect_op "Load compiled compilation unit";
  try Tbl.find tbl name
  with Not_found -> 
    let src = 
      try find_obj name
      with Not_found -> raise (NoImplementation name) in
    let c = real_load src in
    register c;
    (* Register types *)
    if !reg_types then 
      Typer.register_types (U.to_string c.name ^ ".") c.typing;
    (* Load dependencies *)
    List.iter (fun (name,dig) -> check_digest (load name) dig) c.depends;
    Tbl.add tbl name c;
    c

let rec run c =
  match c.status with
    | `Unevaluated ->
        if (c.ext_info != None) && (Array.length c.exts = 0) then
          failwith (Printf.sprintf 
            "The CDuce unit `%s' needs externals"
             (U.to_string c.name));

        (* Run dependencies *)
        List.iter (fun (name,_) -> run (load name)) c.depends;

        c.status <- `Evaluating;
        Eval.eval_unit c.vals c.code;
        c.status <- `Evaluated
    | `Evaluating -> 
        failwith 
          ("Librarian.run. Already running:" ^ (U.to_string c.name))
    | `Evaluated -> ()

let compile_run verbose name src = 
  let c = compile verbose name src in
  register c;
  run c

let load_run name = reg_types := false; run (load name)

let static_externals = Hashtbl.create 17
let register_static_external n v = 
  Hashtbl.add static_externals n v

let get_builtins () =
  List.sort Pervasives.compare 
    (Hashtbl.fold (fun n _ accu  -> n::accu) static_externals [])

let () =
  Typer.from_comp_unit := (fun d -> (from_descr d).typing);
  Typer.load_comp_unit := (fun name -> 
                             if has_obj name then 
                               let cu = load name in
                               if !run_loaded then run cu;
                               cu.descr
                             else raise Not_found);
  Typer.has_static_external :=  Hashtbl.mem static_externals;
  Compile.from_comp_unit := (fun d -> (from_descr d).compile);
  Eval.get_globals := (fun d -> (from_descr d).vals);
  Eval.get_external := (fun d i -> (from_descr d).exts.(i));
  Eval.get_builtin := Hashtbl.find static_externals


let stub_ml = ref (fun _ _ _ _ _ -> 
                     Printf.eprintf
                       "Fatal error: no support for the OCaml interface.\n";
                     exit 2)

let prepare_stub src =
  let c = real_load src in
  
  (* Create stub types in a fresh compilation unit *)
  Compunit.enter ();
  let i1,i2 = Compunit.get_hash c.descr in
  Compunit.set_hash (Compunit.current ()) (-i1) i2;
  !stub_ml (U.get_str c.name) c.typing c.compile c.ext_info
    (fun types ->
       Compunit.leave ();
       Marshal.to_string (Value.extract_all (), types, c) [])
(* TODO: could remove typing and compile env *)

let ocaml_stub stub =
  let pools, types, (c : t) = Marshal.from_string stub 0 in
  if Tbl.mem tbl c.name then
    failwith ("CDuce unit " ^ (U.get_str c.name) ^ " already loaded");
  Value.intract_all pools;
  register c;
  List.iter 
    (fun (name,dig) -> 
       let c = 
         try Tbl.find tbl name
         with Not_found ->
           failwith ("CDuce unit " ^ (U.get_str name) ^ " not loaded")
       in
       check_digest c dig) c.depends;
  Tbl.add tbl c.name c;
  types,
  (fun a -> c.exts <- a),
  c.vals,
  (fun () -> run c)

let name d = (from_descr d).name
let run d = run (from_descr d)

let make_wrapper = ref (fun _ ->
                          failwith "OCaml/CDuce interface not available")
1	open Cduce_loc
2	open Ident
3
4
5	exception InconsistentCrc of U.t
6	exception InvalidObject of string
7	exception CannotOpen of string
8	exception NoImplementation of U.t
9
10	let run_loaded = ref false
11
12	type t = {
13	name: U.t;
14	descr: Compunit.t;
15
16	typing: Typer.t;
17	compile: Compile.env;
18	code: Lambda.code_item list;
19	ext_info: Externals.ext_info option;
20
21	mutable digest: Digest.t option;
22	vals: Value.t array; (* Exported values *)
23	mutable exts: Value.t array;
24	mutable depends: (U.t * string) list;
25
26
27	mutable status: [ `Evaluating \| `Unevaluated \| `Evaluated ];
28	}
29
30	let digest c = match c.digest with None -> assert false \| Some x -> x
31
32
33	module Tbl = Hashtbl.Make(U)
34	let tbl = Tbl.create 64
35
36	module CTbl = Hashtbl.Make(Compunit)
37	let ctbl = CTbl.create 64
38
39	let mk name descr typing compile code ext_info depends =
40	{ name = name;
41	descr = descr;
42	typing = typing;
43	compile = compile;
44	code = code;
45	ext_info = ext_info;
46	digest = None;
47	vals = Array.make (Compile.global_size compile) Value.Absent;
48	exts = [\| \|];
49	depends = depends;
50	status = `Unevaluated;
51	}
52
53	let magic = "CDUCE:compunit:00007"
54
55	let has_obj n =
56	let base = U.to_string n ^ ".cdo" in
57	List.exists (fun p -> Sys.file_exists (Filename.concat p base)) !obj_path
58
59	let find_obj n =
60	let base = U.to_string n ^ ".cdo" in
61	let p =
62	List.find (fun p -> Sys.file_exists (Filename.concat p base)) !obj_path in
63	Filename.concat p base
64
65	let check_digest c dig =
66	if digest c <> dig then raise (InconsistentCrc c.name)
67
68	let show ppf id t v =
69	match id with
70	\| Some id ->
71	Format.fprintf ppf "@[val %a : @[%a@]@."
72	Ident.print id
73	Types.Print.print t
74	\| None -> ()
75
76
77	let compile verbose name src =
78	protect_op "Compile external file";
79	let ic =
80	if src = "" then (Cduce_loc.push_source `Stream; stdin)
81	else
82	try Cduce_loc.push_source (`File src); open_in src
83	with Sys_error _ -> raise (CannotOpen src) in
84	let input = Stream.of_channel ic in
85	let p =
86	try Parser.prog input
87	with
88	\| Ulexer.Loc.Exc_located (_, (Location _ \| Ulexer.Error _ as e)) -> raise e
89	\| Ulexer.Loc.Exc_located ((i,j), e) ->
90	raise_loc i j e
91	in
92	if src <> "" then close_in ic;
93
94	let show =
95	if verbose
96	then Some (show Format.std_formatter)
97	else None in
98	Compunit.enter ();
99	let descr = Compunit.current () in
100	let (ty_env,c_env,code) =
101	Compile.comp_unit
102	?show
103	Builtin.env
104	(Compile.empty descr)
105	p in
106	Compunit.leave ();
107	let ext = Externals.get () in
108	let depends = Tbl.fold (fun name c accu -> (name,digest c) :: accu) tbl [] in
109
110	mk name descr ty_env c_env code ext depends
111
112	let set_hash c =
113	let h = Hashtbl.hash_param 1000 10000 (c.typing,c.name) in
114	let max_rank =
115	Tbl.fold
116	(fun _ c accu -> max accu (fst (Compunit.get_hash c.descr))) tbl 0 in
117	Compunit.set_hash c.descr (succ max_rank) h
118	(* This invalidates all hash tables on types ! *)
119
120
121	let compile_save verbose name src out =
122	protect_op "Save compilation unit";
123
124	let c = compile verbose name src in
125	set_hash c;
126	let pools = Value.extract_all () in
127
128	let oc = open_out_bin out in
129	output_string oc magic;
130
131	Marshal.to_channel oc (pools,c) [];
132	let digest = Digest.file out in
133	Marshal.to_channel oc digest [];
134	close_out oc
135
136	let from_descr descr : t =
137	try CTbl.find ctbl descr
138	with Not_found ->
139	let i1,i2 = Compunit.get_hash descr in
140	failwith (Printf.sprintf "Can't find cu(%i,%i)" i1 i2)
141
142	let register c =
143	(* Look for an already loaded unit with the same descriptor *)
144	if CTbl.mem ctbl c.descr then failwith "Collision on unit descriptors";
145	CTbl.add ctbl c.descr c
146
147	let reg_types = ref true
148
149
150	let rec real_load src =
151	let ic =
152	try open_in_bin src
153	with Sys_error _ -> raise (CannotOpen src) in
154	try
155	let s = String.copy magic in
156	really_input ic s 0 (String.length s);
157	if s <> magic then raise (InvalidObject src);
158	let pools,c = Marshal.from_channel ic in
159	let digest = Marshal.from_channel ic in
160	c.digest <- Some digest;
161	Value.intract_all pools;
162	close_in ic;
163	c
164	with Failure _ \| End_of_file -> raise (InvalidObject src)
165
166	and load name =
167	protect_op "Load compiled compilation unit";
168	try Tbl.find tbl name
169	with Not_found ->
170	let src =
171	try find_obj name
172	with Not_found -> raise (NoImplementation name) in
173	let c = real_load src in
174	register c;
175	(* Register types *)
176	if !reg_types then
177	Typer.register_types (U.to_string c.name ^ ".") c.typing;
178	(* Load dependencies *)
179	List.iter (fun (name,dig) -> check_digest (load name) dig) c.depends;
180	Tbl.add tbl name c;
181	c
182
183	let rec run c =
184	match c.status with
185	\| `Unevaluated ->
186	if (c.ext_info != None) && (Array.length c.exts = 0) then
187	failwith (Printf.sprintf
188	"The CDuce unit `%s' needs externals"
189	(U.to_string c.name));
190
191	(* Run dependencies *)
192	List.iter (fun (name,_) -> run (load name)) c.depends;
193
194	c.status <- `Evaluating;
195	Eval.eval_unit c.vals c.code;
196	c.status <- `Evaluated
197	\| `Evaluating ->
198	failwith
199	("Librarian.run. Already running:" ^ (U.to_string c.name))
200	\| `Evaluated -> ()
201
202	let compile_run verbose name src =
203	let c = compile verbose name src in
204	register c;
205	run c
206
207	let load_run name = reg_types := false; run (load name)
208
209	let static_externals = Hashtbl.create 17
210	let register_static_external n v =
211	Hashtbl.add static_externals n v
212
213	let get_builtins () =
214	List.sort Pervasives.compare
215	(Hashtbl.fold (fun n _ accu -> n::accu) static_externals [])
216
217	let () =
218	Typer.from_comp_unit := (fun d -> (from_descr d).typing);
219	Typer.load_comp_unit := (fun name ->
220	if has_obj name then
221	let cu = load name in
222	if !run_loaded then run cu;
223	cu.descr
224	else raise Not_found);
225	Typer.has_static_external := Hashtbl.mem static_externals;
226	Compile.from_comp_unit := (fun d -> (from_descr d).compile);
227	Eval.get_globals := (fun d -> (from_descr d).vals);
228	Eval.get_external := (fun d i -> (from_descr d).exts.(i));
229	Eval.get_builtin := Hashtbl.find static_externals
230
231
232	let stub_ml = ref (fun _ _ _ _ _ ->
233	Printf.eprintf
234	"Fatal error: no support for the OCaml interface.\n";
235	exit 2)
236
237	let prepare_stub src =
238	let c = real_load src in
239
240	(* Create stub types in a fresh compilation unit *)
241	Compunit.enter ();
242	let i1,i2 = Compunit.get_hash c.descr in
243	Compunit.set_hash (Compunit.current ()) (-i1) i2;
244	!stub_ml (U.get_str c.name) c.typing c.compile c.ext_info
245	(fun types ->
246	Compunit.leave ();
247	Marshal.to_string (Value.extract_all (), types, c) [])
248	(* TODO: could remove typing and compile env *)
249
250	let ocaml_stub stub =
251	let pools, types, (c : t) = Marshal.from_string stub 0 in
252	if Tbl.mem tbl c.name then
253	failwith ("CDuce unit " ^ (U.get_str c.name) ^ " already loaded");
254	Value.intract_all pools;
255	register c;
256	List.iter
257	(fun (name,dig) ->
258	let c =
259	try Tbl.find tbl name
260	with Not_found ->
261	failwith ("CDuce unit " ^ (U.get_str name) ^ " not loaded")
262	in
263	check_digest c dig) c.depends;
264	Tbl.add tbl c.name c;
265	types,
266	(fun a -> c.exts <- a),
267	c.vals,
268	(fun () -> run c)
269
270	let name d = (from_descr d).name
271	let run d = run (from_descr d)
272
273	let make_wrapper = ref (fun _ ->
274	failwith "OCaml/CDuce interface not available")