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
55
56
57
58
59
60
61
62
63
64
65
66
67
|
(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
(***********************************************************************)
(* $Id$ *)
let cslargs = ref ([] : string list)
let profargs = ref ([] : string list)
let toremove = ref ([] : string list)
let remove_file name =
try Sys.remove name with Sys_error _ -> ()
let option opt () = cslargs := opt :: !cslargs
let option_with_arg opt arg = cslargs := arg :: opt :: !cslargs
let process_file filename =
if Filename.check_suffix filename ".ml" then begin
let instrname = filename ^ "t" in
toremove := instrname :: !toremove;
let status =
Sys.command
(Printf.sprintf "cslprof -instrument %s %s > %s"
(String.concat " " (List.rev !profargs))
filename instrname) in
if status <> 0 then begin
List.iter remove_file !toremove;
exit 2
end;
cslargs := instrname :: !cslargs
end else begin
cslargs := filename :: !cslargs
end
let _ =
Arg.parse
(* Same options as the compiler cslc *)
["-I", Arg.String(option_with_arg "-I");
"-c", Arg.Unit(option "-c");
"-o", Arg.String(option_with_arg "-o");
"-i", Arg.Unit(option "-i");
"-a", Arg.Unit(option "-a");
"-unsafe", Arg.Unit(option "-unsafe");
"-nopervasives", Arg.Unit(option "-nopervasives");
"-custom", Arg.Unit(option "-custom");
"-ccopt", Arg.String(option_with_arg "-ccopt");
"-cclib", Arg.String(option_with_arg "-cclib");
"-linkall", Arg.Unit(option "-linkall");
"-drawlambda", Arg.Unit(option "-drawlambda");
"-dlambda", Arg.Unit(option "-dlambda");
"-dinstr", Arg.Unit(option "-dinstr");
"-v", Arg.Unit(option "-v");
"-", Arg.String process_file;
(* Options specific to the profiler *)
"-p", Arg.String(fun s -> profargs := s :: "-m" :: !profargs)]
process_file;
let status =
Sys.command ("cslc " ^ String.concat " " (List.rev !cslargs)) in
List.iter remove_file !toremove;
exit status
|
