librarian.ml 4.79 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
open Location
open Ident


module C = Types.CompUnit

type t = {
  typing: Typer.t;
  compile: Compile.env;
  code: Lambda.code_item list;
  mutable digest: Digest.t option;
  mutable vals: Value.t array option;
  mutable depends: C.t list
}

let mk (typing,compile,code) =
  { typing = typing;
    compile = compile;
    code = code;
    digest = None;
    vals = None;
    depends = [];
  }

let magic = "CDUCE:compunit:00001"

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;
  Lambda.Put.codes s cu.code

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 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)


55
56
57
let source_filename id = 
    let filename = Encodings.Utf8.to_string (C.value id) 
     in if (Filename.check_suffix filename "cd") then filename else filename^ ".cd"
58
59
60

(* if we add an option for the user to specify the output file then we probably *)
(* should not add the .cdo at the end                                           *)
61
62
63
let object_filename id = 
    let filename = Encodings.Utf8.to_string (C.value id) 
     in if (Filename.check_suffix filename "cd") then filename else filename ^ ".cdo"
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168


let save id =
  let cu = find id in
  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

  let depend = Serialize.Put.run serialize_dep depend in
  let digest = Digest.string raw in
  let oc = open_out (object_filename id) in
  output_value oc (digest,depend,raw);
  close_out oc
  
  
let check_digest exp digest =
  match digest with
    | Some x ->
	if exp <> x then failwith "Inconsistent checksum"
    | None -> 
	assert false

let loop = C.Tbl.create ()
let check_loop id = 
  try 
    C.Tbl.find loop id;
    failwith "Loop between compilation units"
  with Not_found -> 
    C.Tbl.add loop id ()

let depends = ref []
let during_compile = ref false

let rec compile id =
  check_loop id;
  let src = source_filename id in
  let ic = open_in src in
  Location.push_source (`File src);
  let input = Stream.of_channel ic in
  let p = 
    try Parser.prog input 
    with
    | Stdpp.Exc_located (_, (Location _ as e)) -> raise e
    | Stdpp.Exc_located ((i,j), e) -> raise_loc i j e
  in
  close_in ic;
  let argv = ident (U.mk "argv") in
  during_compile := true;
  C.enter id;
  let cu = mk 
	     (
	       Compile.comp_unit 
		(Typer.enter_value argv (Sequence.star Sequence.string)
		   Builtin.env)
		(Compile.enter_global Compile.empty argv)
		p
	     ) in
  C.Tbl.add tbl id cu;
  C.leave ();
  during_compile := false;
  cu.depends <- !depends;
  depends := []

let rec load id =
  try 
    C.Tbl.find tbl id
  with Not_found ->
    check_loop id;
    if !during_compile then depends := id :: !depends;
(*    Printf.eprintf "load %s: start\n" (object_filename id);
    flush stderr; *)
    let ic = open_in (object_filename id) in
    let (dig, depend, raw) = input_value ic in
    close_in ic;
    let depend = Serialize.Get.run deserialize_dep depend in
    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;
    cu

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

let rec run argv id =
  let cu = find id in
169
170
171
172
173
174
175
  match cu.vals with
    | None -> 
	List.iter (run argv) cu.depends;
	Eval.L.push argv;
	List.iter Eval.L.eval cu.code;
	cu.vals <- Some (Eval.L.comp_unit ())
    | Some _ -> ()
176
177
178
179
180
181
  
let import id = ignore (load id)

let () =
  Typer.from_comp_unit := (fun cu -> (load cu).typing);
  Compile.from_comp_unit := (fun cu -> (load cu).compile);
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
  Eval.L.from_comp_unit := 
  (fun cu i ->
     match (load cu).vals with
       | None -> assert false
       | Some a -> a.(i));
  Eval.from_comp_unit := 
  (fun cu id ->
     let c = load cu in
     let pos = 
       match Compile.find id c.compile with
	 | Lambda.Global i -> i
	 | _ -> assert false in
     run Value.nil cu;
     match c.vals with
       | None -> assert false
       | Some a -> a.(pos))
198
199