1(**************************************************************************)
2(*                                                                        *)
3(*                                 OCaml                                  *)
4(*                                                                        *)
5(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
6(*                                                                        *)
7(*   Copyright 1998 Institut National de Recherche en Informatique et     *)
8(*     en Automatique.                                                    *)
9(*                                                                        *)
10(*   All rights reserved.  This file is distributed under the terms of    *)
11(*   the GNU Lesser General Public License version 2.1, with the          *)
12(*   special exception on linking described in the file LICENSE.          *)
13(*                                                                        *)
14(**************************************************************************)
15
16open Printf
17
18let compargs = ref ([] : string list)
19let profargs = ref ([] : string list)
20let toremove = ref ([] : string list)
21
22let option opt () = compargs := opt :: !compargs
23let option_with_arg opt arg =
24  compargs := (Filename.quote arg) :: opt :: !compargs
25;;
26
27let make_archive = ref false;;
28let with_impl = ref false;;
29let with_intf = ref false;;
30let with_mli = ref false;;
31let with_ml = ref false;;
32
33let process_file filename =
34  if Filename.check_suffix filename ".ml" then with_ml := true;
35  if Filename.check_suffix filename ".mli" then with_mli := true;
36  compargs := (Filename.quote filename) :: !compargs
37;;
38
39let usage = "Usage: ocamlcp <options> <files>\noptions are:"
40
41let incompatible o =
42  fprintf stderr "ocamlcp: profiling is incompatible with the %s option\n" o;
43  exit 2
44
45module Options = Main_args.Make_bytecomp_options (struct
46  let _a () = make_archive := true; option "-a" ()
47  let _absname = option "-absname"
48  let _annot = option "-annot"
49  let _binannot = option "-bin-annot"
50  let _c = option "-c"
51  let _cc s = option_with_arg "-cc" s
52  let _cclib s = option_with_arg "-cclib" s
53  let _ccopt s = option_with_arg "-ccopt" s
54  let _config = option "-config"
55  let _compat_32 = option "-compat-32"
56  let _custom = option "-custom"
57  let _dllib = option_with_arg "-dllib"
58  let _dllpath = option_with_arg "-dllpath"
59  let _dtypes = option "-dtypes"
60  let _for_pack = option_with_arg "-for-pack"
61  let _g = option "-g"
62  let _i = option "-i"
63  let _I s = option_with_arg "-I" s
64  let _impl s = with_impl := true; option_with_arg "-impl" s
65  let _intf s = with_intf := true; option_with_arg "-intf" s
66  let _intf_suffix s = option_with_arg "-intf-suffix" s
67  let _keep_docs = option "-keep-docs"
68  let _no_keep_docs = option "-no-keep-docs"
69  let _keep_locs = option "-keep-locs"
70  let _no_keep_locs = option "-no-keep-locs"
71  let _labels = option "-labels"
72  let _linkall = option "-linkall"
73  let _make_runtime = option "-make-runtime"
74  let _alias_deps = option "-alias-deps"
75  let _no_alias_deps = option "-no-alias-deps"
76  let _app_funct = option "-app-funct"
77  let _no_app_funct = option "-no-app-funct"
78  let _no_check_prims = option "-no-check-prims"
79  let _noassert = option "-noassert"
80  let _nolabels = option "-nolabels"
81  let _noautolink = option "-noautolink"
82  let _nostdlib = option "-nostdlib"
83  let _o s = option_with_arg "-o" s
84  let _opaque = option "-opaque"
85  let _open s = option_with_arg "-open" s
86  let _output_obj = option "-output-obj"
87  let _output_complete_obj = option "-output-complete-obj"
88  let _pack = option "-pack"
89  let _plugin = option_with_arg "-plugin"
90  let _pp _s = incompatible "-pp"
91  let _ppx _s = incompatible "-ppx"
92  let _principal = option "-principal"
93  let _no_principal = option "-no-principal"
94  let _rectypes = option "-rectypes"
95  let _no_rectypes = option "-no-rectypes"
96  let _runtime_variant s = option_with_arg "-runtime-variant" s
97  let _safe_string = option "-safe-string"
98  let _short_paths = option "-short-paths"
99  let _strict_sequence = option "-strict-sequence"
100  let _no_strict_sequence = option "-no-strict-sequence"
101  let _strict_formats = option "-strict-formats"
102  let _no_strict_formats = option "-no-strict-formats"
103  let _thread () = option "-thread" ()
104  let _vmthread () = option "-vmthread" ()
105  let _unboxed_types = option "-unboxed-types"
106  let _no_unboxed_types = option "-no-unboxed-types"
107  let _unsafe = option "-unsafe"
108  let _unsafe_string = option "-unsafe-string"
109  let _use_prims s = option_with_arg "-use-prims" s
110  let _use_runtime s = option_with_arg "-use-runtime" s
111  let _v = option "-v"
112  let _version = option "-version"
113  let _vnum = option "-vnum"
114  let _verbose = option "-verbose"
115  let _w = option_with_arg "-w"
116  let _warn_error = option_with_arg "-warn-error"
117  let _warn_help = option "-warn-help"
118  let _color s = option_with_arg "-color" s
119  let _where = option "-where"
120  let _nopervasives = option "-nopervasives"
121  let _dsource = option "-dsource"
122  let _dparsetree = option "-dparsetree"
123  let _dtypedtree = option "-dtypedtree"
124  let _drawlambda = option "-drawlambda"
125  let _dlambda = option "-dlambda"
126  let _dflambda = option "-dflambda"
127  let _dinstr = option "-dinstr"
128  let _dtimings = option "-dtimings"
129  let _args = Arg.read_arg
130  let _args0 = Arg.read_arg0
131  let anonymous = process_file
132end);;
133
134let add_profarg s =
135  profargs := (Filename.quote s) :: "-m" :: !profargs
136;;
137
138let optlist =
139    ("-P", Arg.String add_profarg,
140           "[afilmt]  Profile constructs specified by argument (default fm):\n\
141        \032     a  Everything\n\
142        \032     f  Function calls and method calls\n\
143        \032     i  if ... then ... else\n\
144        \032     l  while and for loops\n\
145        \032     m  match ... with\n\
146        \032     t  try ... with")
147    :: ("-p", Arg.String add_profarg, "[afilmt]  Same as option -P")
148    :: Options.list
149in
150Arg.parse_expand optlist process_file usage;
151if !with_impl && !with_intf then begin
152  fprintf stderr "ocamlcp cannot deal with both \"-impl\" and \"-intf\"\n";
153  fprintf stderr "please compile interfaces and implementations separately\n";
154  exit 2;
155end else if !with_impl && !with_mli then begin
156  fprintf stderr "ocamlcp cannot deal with both \"-impl\" and .mli files\n";
157  fprintf stderr "please compile interfaces and implementations separately\n";
158  exit 2;
159end else if !with_intf && !with_ml then begin
160  fprintf stderr "ocamlcp cannot deal with both \"-intf\" and .ml files\n";
161  fprintf stderr "please compile interfaces and implementations separately\n";
162  exit 2;
163end;
164if !with_impl then profargs := "-impl" :: !profargs;
165if !with_intf then profargs := "-intf" :: !profargs;
166let status =
167  Sys.command
168    (Printf.sprintf "ocamlc -pp \"ocamlprof -instrument %s\" %s %s"
169        (String.concat " " (List.rev !profargs))
170        (if !make_archive then "" else "profiling.cmo")
171        (String.concat " " (List.rev !compargs)))
172in
173exit status
174;;
175