Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 450 lines (404 sloc) 14.557 kB
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18
f3fef85 [cleanup] fixme: remove some of them
Mathieu Barbin authored
19 (* depends *)
20 module String = BaseString
21 module Marshal = BaseMarshal
fccc685 Initial open-source release
MLstate authored
22
23 let error fmt = OManager.error ("OpaTracker."^^fmt^^"\n")
24
25 type index = int
26 type info = string
27 type passname = string
28 type printer_id = string
29 type tracker_id = string
30 type filename = string
31 type 'a printer = Format.formatter -> 'a -> unit
32 type 'a outputer = Pervasives.out_channel -> 'a -> unit
33 type tag = int
34 type t =
35 {
36 index : index ;
37 info : info ;
38 mutable tags : (tag, Obj.t) Hashtbl.t option (* majority of case: None, better than empty hashtbl *)
39 }
40 type iter_tracker = {
41 track : 'tracked. (filename -> 'tracked printer -> 'tracked -> unit) ;
42 }
43 type 'env tracker = iter_tracker -> 'env -> unit
44
45 let info t = t.info
46 let next =
47 let i = ref (-1) in
48 (fun info -> incr(i); { index = !i ; info = info ; tags = None})
49
50 let next_tag =
51 let i = ref (-1) in
52 (fun () -> incr(i); !i)
53
54 let embed () =
55 let tag = next_tag () in
56 let set t alpha =
57 let obj = Obj.repr alpha in
58 match t.tags with
59 | None ->
60 let ht = Hashtbl.create 5 in
61 Hashtbl.add ht tag obj;
62 t.tags <- Some ht
63 | Some ht -> Hashtbl.replace ht tag obj (* GC *)
64 and get t =
65 match t.tags with
66 | None -> None
67 | Some ht -> (
68 try Some (Obj.obj (Hashtbl.find ht tag))
69 with Not_found -> None
70 )
71 in set, get
72
73 let started = ref false
74 let directory_name = ref "_tracks"
75 let directory = ref (!directory_name)
76
77 let handle_open_out ?(append=false) file =
78 try
79 if append
80 then
81 Pervasives.open_out_gen
82 [Open_wronly; Open_creat; Open_append; Open_text]
83 0o666
84 file
85 else
86 Pervasives.open_out file
87 with
88 | Sys_error s ->
89 error "Output.start: cannot open_out %s : %s" file s
90
91 let handle_open_in file =
92 try open_in file
93 with
94 | Sys_error s ->
95 error "Input.start: cann open_int %s: %s" file s
96
97 let handle_close_out oc =
98 try close_out oc
99 with
100 | Sys_error s ->
101 error "Output.start: cannot close_out in %s : %s" !directory s
102
103 let handle_close_in ic =
104 try close_in ic
105 with
106 | Sys_error s ->
107 error "Input.start: cannot close_int in %s : %s" !directory s
108
109 let handle_mkdir path =
110 if not (File.check_create_path path) then
111 error "Output.start: cannot create directory %s" path
112
113 (* Conventions over name of files and directories. *)
114 (* <!> Keep it synchronized with 'opatrack.sh' and documentation *)
115 let name_passes_list = "passes.list"
116 let name_printers_list = "printers.list"
117 let name_trackers_list = "trackers.list"
118 let name_printers_dir = "printers"
119 let name_trackers_dir = "trackers"
120 let name_internal_dir = "internal"
121 let name_files_dir = "files"
122 let name_check_dir = "check"
123 let name_time_dir = "time"
124 let name_all_time = "all.time"
125 let marshal_filename = "marshal"
126
127 let passes_list = ref stdout
128 let printers_list = ref stdout
129 let trackers_list = ref stdout
130
131 (* caching everything for a image of the system file *)
132 let passes = ( ( Hashtbl.create 10 ) : (passname, unit) Hashtbl.t )
133 (* association between passes and printers *)
134 let pass_printer = ( ( ListHashtbl.create 10 ) : (passname, printer_id) ListHashtbl.t )
135 let printer_pass = ( ( ListHashtbl.create 10 ) : (printer_id, passname) ListHashtbl.t )
136 (* association between passes and trackers *)
137 let pass_tracker = ( ( ListHashtbl.create 10 ) : (passname, tracker_id) ListHashtbl.t )
138 let tracker_pass = ( ( ListHashtbl.create 10 ) : (tracker_id, passname) ListHashtbl.t )
139 (* association between tracker_id and filenames *)
140 let tracker_oc = ( (Hashtbl.create 10 ) : (tracker_id, out_channel) Hashtbl.t )
141 let tracker_filename = ( ( ListHashtbl.create 10 ) : (tracker_id, filename) ListHashtbl.t )
142
143 (* names generation *)
144 let build_passname_filename pass = Printf.sprintf "pass_%s" pass
145 let build_passtime_filename pass = Printf.sprintf "pass_%s.time" pass
146 let build_printer_id_filename printer_id = printer_id
147 let build_tracker_id_filename tracker_id = tracker_id
148 let build_internal_filename file index = Printf.sprintf "%s.%d" file index
149 let build_check_filename file index = Printf.sprintf "%s.%d" file index
150 let build_tracker_id_list tracker_id = Printf.sprintf "%s.list" (build_tracker_id_filename tracker_id)
151
152 (* for the `tracker directive *)
153 let build_track_name t = Printf.sprintf "index.%d" t.index
154
155 (*
156 Clear hashtbl for restart
157 *)
158 let clear_tables () =
159 Hashtbl.clear passes ;
160 ListHashtbl.clear pass_printer ;
161 ListHashtbl.clear printer_pass ;
162 ListHashtbl.clear pass_tracker ;
163 ListHashtbl.clear tracker_pass ;
164 Hashtbl.clear tracker_oc ;
165 ListHashtbl.clear tracker_filename ;
166 ()
167
168 (* keep list files coherent online *)
169 let output_pass passname =
170 if not ( Hashtbl.mem passes passname )
171 then (
172 Printf.fprintf !passes_list "%s\n%!" (build_passname_filename passname);
173 Hashtbl.add passes passname ()
174 )
175
176 let output_printer passname printer_id =
177 output_pass passname;
178 if not ( ListHashtbl.mem printer_pass printer_id )
179 then (
180 Printf.fprintf !printers_list "%s\n%!" (build_printer_id_filename printer_id);
181 ListHashtbl.add printer_pass printer_id passname;
182 ListHashtbl.add pass_printer passname printer_id
183 )
184
185 let output_tracker passname tracker_id =
186 output_pass passname;
187 if not ( Hashtbl.mem tracker_oc tracker_id )
188 then (
189 let path = Filename.concat !directory name_trackers_dir in
190 let file = Filename.concat path (build_tracker_id_list tracker_id) in
191 let oc = handle_open_out file in
192 Hashtbl.add tracker_oc tracker_id oc
193 );
194 if not ( ListHashtbl.mem tracker_pass tracker_id )
195 then (
196 Printf.fprintf !trackers_list "%s\n%!" (build_tracker_id_filename tracker_id);
197 ListHashtbl.add tracker_pass tracker_id passname;
198 ListHashtbl.add pass_tracker passname tracker_id;
199 )
200
201 let output_tracked tracker_id filename =
202 let oc =
203 try
204 Hashtbl.find tracker_oc tracker_id
205 with
206 | Not_found -> error "Output.output_tracked: no channel available for tracker: %s" tracker_id
207 in
208 if not ( ListHashtbl.mem_cp tracker_filename (tracker_id, filename) )
209 then (
210 Printf.fprintf oc "%s\n%!" filename;
211 ListHashtbl.add tracker_filename tracker_id filename
212 )
213
214 let set_directory dirname =
215 if !started then error "Output.set_directory: already started"
216 else directory_name := dirname
217
218 let get_directory () = !directory
219
220 let finalize () =
221 if not !started then () else (
222 handle_close_out !passes_list;
223 handle_close_out !printers_list;
224 handle_close_out !trackers_list;
225 Hashtbl.iter (fun _ oc -> handle_close_out oc) tracker_oc
226 )
227
228 let all_time = ref 0.0
229
230 let start () =
231 let new_directory =
232 let directory mode =
233 match mode with
234 | `prelude -> Filename.concat !directory_name "prelude"
235 | `init -> Filename.concat !directory_name "init"
236 | `linking -> !directory_name
237 | `compilation ->
238 let compilation_directory = Option.default "" (ObjectFiles.get_compilation_directory ()) in
239 Filename.concat compilation_directory !directory_name
240 in
241 let mode = ObjectFiles.compilation_mode () in
242 if ObjectFiles.Arg.is_separated () then directory mode
243 else if mode = `prelude then directory `linking else directory mode
244 in
245 let new_directory =
246 if Filename.is_relative new_directory then
247 Filename.concat (Sys.getcwd ()) new_directory
248 else new_directory
249 in
250 let same_directory = new_directory = !directory in
251 directory := new_directory ;
252 if !started && same_directory then () else (
253 if !started then (
254 clear_tables () ;
255 finalize () ;
256 ) ;
257 all_time := 0.0 ;
258 handle_mkdir !directory ;
259 let handle_open_out file = handle_open_out (Filename.concat !directory file) in
260 started := true ;
261 passes_list := handle_open_out name_passes_list ;
262 printers_list := handle_open_out name_printers_list ;
263 trackers_list := handle_open_out name_trackers_list ;
264 let directory_trackers = Filename.concat !directory name_trackers_dir in
265 handle_mkdir directory_trackers;
266 let directory_time = Filename.concat !directory name_time_dir in
267 handle_mkdir directory_time
268 )
269
270 (*
271 + should not be used, because printer_id and tracker_id should rather be abstract
272 types, with a constructor storing id in a table for PassHandler.Arg to be smart.
273 + is used for filename generation of trackers
274 *)
275 let digest s = String.sub (Digest.to_hex (Digest.string s)) 0 8
276 let protect_filename s =
277 if s <> "" && Base.String.is_word s then s else digest s
278
279 let print ~passname ~printer_id printer env =
280 start () ;
281 output_printer passname printer_id;
282 let oc =
283 let pass = build_passname_filename passname in
284 let path = Filename.concat !directory pass in
285 let path = Filename.concat path name_printers_dir in
286 handle_mkdir path ;
287 let file = Filename.concat path (build_printer_id_filename printer_id) in
288 handle_open_out file
289 in
290 let fmt = Format.formatter_of_out_channel oc in
291 printer fmt env ;
292 Format.pp_print_flush fmt () ;
293 handle_close_out oc
294
295 let track ~passname ~tracker_id tracker env =
296 start () ;
297 output_tracker passname tracker_id;
298 let pass = build_passname_filename passname in
299 let path = Filename.concat !directory pass in
300 let path = Filename.concat path name_trackers_dir in
301 let path = Filename.concat path (build_tracker_id_filename tracker_id) in
302 handle_mkdir path ;
303 let track filename printer tracked =
304 let filename = protect_filename filename in
305 (* add the filename to the list of tracked for this tracker_id *)
306 output_tracked tracker_id filename;
307 let file = Filename.concat path filename in
308 let oc = handle_open_out file in
309 let fmt = Format.formatter_of_out_channel oc in
310 printer fmt tracked ;
311 Format.pp_print_flush fmt () ;
312 handle_close_out oc
313 in
314 tracker { track = track } env
315
316 let time ~passname time =
317 start () ;
318 output_pass passname;
319 let oc =
320 let path = Filename.concat !directory name_time_dir in
321 handle_mkdir path ;
322 let file = Filename.concat path (build_passtime_filename passname) in
323 handle_open_out file
324 in
325 Printf.fprintf oc "%f\n%!" time;
326 handle_close_out oc ;
327 all_time := !all_time +. time ;
328 let oc =
329 let path = Filename.concat !directory name_time_dir in
330 let file = Filename.concat path name_all_time in
331 handle_open_out file
332 in
333 Printf.fprintf oc "%f\n%!" !all_time;
334 handle_close_out oc
335
336 let global_env_stack : ((Obj.t -> unit) * (unit -> Obj.t)) list ref = ref []
337 let register_global_env (cap : ('a -> unit) * (unit -> 'a)) = global_env_stack := Obj.magic cap :: !global_env_stack
338 let register_global_ref r = register_global_env ((fun v -> r := v), (fun () -> !r))
339 let get_global_values () = List.map (fun (_,reader) -> Obj.obj (reader ())) !global_env_stack
340 let set_global_values values = List.iter2 (fun (writer,_) value -> writer (Obj.repr value)) !global_env_stack values
341
342 let marshal ~passname env =
343 let (/) = Filename.concat in
344 start ();
345 output_pass passname;
346 let pass = build_passname_filename passname in
347 let oc =
348 let path = !directory/pass in
349 handle_mkdir path;
350 let file = path/marshal_filename in
351 handle_open_out file in
352 Marshal.marshal_no_fun oc (env :: get_global_values ());
353 handle_close_out oc
354
355 let unmarshal ~passname =
356 let (/) = Filename.concat in
357 start ();
358 output_pass passname;
359 let pass = build_passname_filename passname in
360 let ic =
361 let file = !directory/pass/marshal_filename in
362 handle_open_in file in
363 match Marshal.unmarshal_no_fun ic with
364 | [] -> assert false
365 | v :: values -> set_global_values values;
366 handle_close_in ic;
367 v
368
369 let current_passname = ref "default"
370 let set_current_passname passname = current_passname := passname
371 let make_fresh () =
372 let t = Hashtbl.create 10 in
373 (fun passname filename ->
374 let key = passname, filename in
375 let index = try Hashtbl.find t key with Not_found -> 0 in
376 Hashtbl.add t key (succ index);
377 index)
378 let internal_fresh = make_fresh ()
379 let internal ~filename fmt env =
380 start () ;
381 output_pass !current_passname ;
382 let oc =
383 let pass = build_passname_filename !current_passname in
384 let path = Filename.concat !directory pass in
385 let path = Filename.concat path name_internal_dir in
386 handle_mkdir path ;
387 let index = internal_fresh !current_passname filename in
388 let filename = Filename.concat path (build_internal_filename filename index) in
389 handle_open_out filename
390 in
391 let ff = Format.formatter_of_out_channel oc in
392 fmt ff env ;
393 Format.pp_print_flush ff () ;
394 handle_close_out oc
395
396 let append_file =
397 let table = Hashtbl.create 16 in
398 (fun filename ->
399 if Hashtbl.mem table filename
400 then true
401 else (
402 Hashtbl.add table filename ();
403 false
404 ))
405
406 let file ~filename fmt env =
407 start () ;
408 output_pass !current_passname ;
409 let filename =
410 let pass = build_passname_filename !current_passname in
411 let path = Filename.concat !directory pass in
412 let path = Filename.concat path name_files_dir in
413 handle_mkdir path ;
414 let filename = Filename.concat path filename in
415 filename
416 in
417 let oc =
418 let append = append_file filename in
419 handle_open_out ~append filename
420 in
421 fmt oc env ;
422 Pervasives.flush oc ;
423 handle_close_out oc ;
424 filename
425
426
427 let check_fresh = make_fresh ()
428 let check_fail ~filename fmt env =
429 start () ;
430 output_pass !current_passname ;
431 let oc =
432 let pass = build_passname_filename !current_passname in
433 let path = Filename.concat !directory pass in
434 let path = Filename.concat path name_check_dir in
435 handle_mkdir path ;
436 let index = check_fresh !current_passname filename in
437 let filename = Filename.concat path (build_check_filename filename index) in
438 handle_open_out filename
439 in
440 let ff = Format.formatter_of_out_channel oc in
441 fmt ff env ;
442 Format.pp_print_flush ff () ;
443 handle_close_out oc
444
445 (* exported in mli *)
446 let filename = build_track_name
447
448 let _ =
449 Pervasives.at_exit finalize
Something went wrong with that request. Please try again.