librarian.ml 7.51 KB
Newer Older
1
2
3
open Location
open Ident

4
5
6
7
type stub_ml
let stub_ml = ref (fun cu ty_env c_env -> None, [| |])


8
9
module C = Types.CompUnit

10
11
12
13
14
15
exception InconsistentCrc of C.t
exception Loop of C.t
exception InvalidObject of string
exception CannotOpen of string
exception NoImplementation of C.t

16
17
18
19
type t = {
  typing: Typer.t;
  compile: Compile.env;
  code: Lambda.code_item list;
20
  types: Types.t array;
21
  has_ext: bool;
22

23
  mutable digest: Digest.t option;
24
  vals: Value.t array;
25
  mutable exts: Value.t array;
26
  mutable depends: C.t list;
27
28
29
  mutable status: [ `Evaluating | `Unevaluated | `Evaluated ];

  mutable stub : stub_ml option
30
31
}

32
let mk ((typing,compile,code),types,ext) =
33
34
35
  { typing = typing;
    compile = compile;
    code = code;
36
    types = types;
37
    has_ext = ext;
38
    digest = None;
39
    vals = Array.make (Compile.global_size compile) Value.Absent;
40
    exts = [| |];
41
    depends = [];
42
    status = `Unevaluated;
43
    stub = None
44
45
  }

46
let magic = "CDUCE:compunit:00004"
47

48
49
let obj_path = ref [ "" ]

50
51
52
53
54
55
56
57
58
59
let tbl = C.Tbl.create ()

let find id =
  try C.Tbl.find tbl id
  with Not_found -> assert false

let serialize s cu =
  Serialize.Put.magic s magic;
  Typer.serialize s cu.typing;
  Compile.serialize s cu.compile;
60
  Lambda.Put.codes s cu.code;
61
62
  Serialize.Put.array Types.serialize s cu.types;
  Serialize.Put.bool s cu.has_ext
63
64
65
66
67
68

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
69
  let types = Serialize.Get.array Types.deserialize s in
70
71
  let ext = Serialize.Get.bool s in
  mk ((typing,compile,code),types,ext)
72

73
(*
74
75
76
77
78
79
80
let serialize_dep=
  Serialize.Put.list 
    (Serialize.Put.pair Encodings.Utf8.serialize Serialize.Put.string)

let deserialize_dep =
  Serialize.Get.list
    (Serialize.Get.pair Encodings.Utf8.deserialize Serialize.Get.string)
81
*)
82
83


84
85
86
87
let has_obj n =
  let base = Encodings.Utf8.to_string n ^ ".cdo" in
  List.exists (fun p -> Sys.file_exists (Filename.concat p base)) !obj_path

88
89
90
91
92
let find_obj id = 
  let base = Encodings.Utf8.to_string (C.value id) ^ ".cdo" in
  let p = 
    List.find (fun p -> Sys.file_exists (Filename.concat p base)) !obj_path in
  Filename.concat p base
93

94
let save name id out =
95
  protect_op "Save compilation unit";
96

97
  let cu = find id in
98

99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
  C.enter id;
  let raw = Serialize.Put.run serialize cu in
  let depend = C.close_serialize () in
  C.leave ();

(*
  print_endline "Dependencies:";
  List.iter (fun x -> print_endline (object_filename x)) depend;
  flush stdout;
*)
  let depend = 
    try List.map 
      (fun id ->
	 match (C.Tbl.find tbl id).digest with
	   | Some d -> (C.value id, d)
	   | None -> assert false
      ) depend
    with Not_found -> assert false in

118
(*  let depend = Serialize.Put.run serialize_dep depend in *)
119
  let digest = Digest.string raw in
120
  let oc = open_out out in
121
  Marshal.to_channel oc (name,digest,depend,raw,cu.stub) [];
122
123
124
  close_out oc
  
  
125
let check_digest id exp digest =
126
127
  match digest with
    | Some x ->
128
129
	if exp <> x then 
	  raise (InconsistentCrc id)
130
131
132
133
134
135
136
    | None -> 
	assert false

let loop = C.Tbl.create ()
let check_loop id = 
  try 
    C.Tbl.find loop id;
137
    raise (Loop id)
138
139
140
141
142
143
  with Not_found -> 
    C.Tbl.add loop id ()

let depends = ref []
let during_compile = ref false

144
145
146
147
let show ppf id t v =
  match id with
    | Some id ->
	Format.fprintf ppf "@[val %a : @[%a@]@."
148
	Ident.print id
149
150
151
	Types.Print.print t 
    | None -> ()

152
153
154


let rec compile verbose name id src =
155
  check_loop id;
156
157
  protect_op "Compile external file";
  let ic = 
158
    if src = "" then (Location.push_source `Stream; stdin)
159
    else
160
      try Location.push_source (`File src); open_in src
161
      with Sys_error _ -> raise (CannotOpen src) in
162
163
164
165
166
  let input = Stream.of_channel ic in
  let p = 
    try Parser.prog input 
    with
    | Stdpp.Exc_located (_, (Location _ as e)) -> raise e
167
168
    | Stdpp.Exc_located ((i,j), e) -> 
	raise_loc i.Lexing.pos_cnum j.Lexing.pos_cnum e
169
  in
170
  if src <> "" then close_in ic;
171
172
  during_compile := true;
  C.enter id;
173
174
175
176
  let show =
    if verbose 
    then Some (show Format.std_formatter)
    else None in
177
  let (ty_env,c_env,_) as cu =
178
179
    Compile.comp_unit 
      ?show
180
      Builtin.env
181
      (Compile.empty id)
182
183
      p
  in
184
  let stub,types = !stub_ml name ty_env c_env in
185
  let ext = Externals.has () in
186
  let cu = mk (cu,types,ext) in
187
  cu.stub <- stub;
188
189
190
191
192
193
194
  C.Tbl.add tbl id cu;
  C.leave ();
  during_compile := false;
  cu.depends <- !depends;
  depends := []

let rec load id =
195
  protect_op "Load compiled compilation unit";
196
197
198
199
200
  try 
    C.Tbl.find tbl id
  with Not_found ->
(*    Printf.eprintf "load %s: start\n" (object_filename id);
    flush stderr; *)
201
202
203
204

    let obj = 
      try find_obj id
      with Not_found -> raise (NoImplementation id) in
205
    let ic = 
206
207
208
      try open_in obj
      with Sys_error _ -> raise (CannotOpen obj) in

209
    let (name, dig, depend, raw, stub) = 
210
211
212
      try Marshal.from_channel ic
      with Failure _ | End_of_file -> raise (InvalidObject obj) in

213
    close_in ic;
214
(*    let depend = Serialize.Get.run deserialize_dep depend in *)
215
216
    check_loop id;
    if !during_compile then depends := id :: !depends;
217
    load_from_string id raw dig depend
218
219
220

and load_check id exp =
  let cu = load id in
221
  check_digest id exp cu.digest
222

223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
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
241
242
243
244
245
246
247
  ignore (load_from_string id raw dig depend);
  id

let load_unit id dig =
  let id = C.mk (Ident.U.mk id) in
  ignore (load_check id dig);
  id
248

249
let rec run id =
250
  let cu = find id in
251
252
  match cu.status with
    | `Unevaluated -> 
253
254
255
256
	if cu.has_ext && (Array.length cu.exts = 0) then
	  failwith
	    ("Librarian.run. This module needs externals:" ^ 
	     (U.to_string (C.value id)));
257
258
259
260
	List.iter run cu.depends;
	cu.status <- `Evaluating;
	Eval.code_items cu.code;
	cu.status <- `Evaluated
261
262
263
264
265
266
(*
	Compile.dump Format.std_formatter cu.compile;
	Array.iter (fun v ->
		      Format.fprintf Format.std_formatter "%a@."
		      Value.print v) vals;
*)
267
268
269
270
271
272
273
    | `Evaluating -> 
(*
	failwith 
	("Librarian.run. Already running:" ^ (U.to_string (C.value id)))
*)
	()
    | `Evaluated -> ()
274
275
276
  
let import id = ignore (load id)

277
278
let import_check id chk = ignore (load_check id chk)

279
280
let import_and_run id = import id; run id

281
let import_from_string id str dig dep = ignore (load_from_string id str dig dep)
282
283
284
let static_externals = Hashtbl.create 17
let register_static_external n v = 
  Hashtbl.add static_externals n v
285

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

290
291
let () =
  Typer.from_comp_unit := (fun cu -> (load cu).typing);
292
  Typer.has_comp_unit := has_obj;
293
  Typer.has_static_external :=  Hashtbl.mem static_externals;
294
  Compile.from_comp_unit := (fun cu -> (load cu).compile);
295
  Eval.get_global := (fun cu i -> import_and_run cu; (load cu).vals.(i));
296
  Eval.set_global := (fun cu i v -> import cu; (load cu).vals.(i) <- v);
297
298
  Eval.get_external := (fun cu i -> (load cu).exts.(i));
  Eval.get_builtin := Hashtbl.find static_externals
299
300
    

301
302
let set_externals cu a = (load cu).exts <- a

303
let registered_types cu = (load cu).types
304