l4/pkg/ocaml/contrib/tools/ocamlprof.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*      Damien Doligez and Francois Rouaix, INRIA Rocquencourt         *)
   6 (*          Ported to Caml Special Light by John Malecki               *)
   7 (*                                                                     *)
   8 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
   9 (*  en Automatique.  All rights reserved.  This file is distributed    *)
  10 (*  under the terms of the Q Public License version 1.0.               *)
  11 (*                                                                     *)
  12 (***********************************************************************)
  13
  14 (* $Id: ocamlprof.ml 8705 2007-12-04 13:38:58Z doligez $ *)
  15
  16 open Printf
  17
  18 open Clflags
  19 open Config
  20 open Location
  21 open Misc
  22 open Parsetree
  23
  24 (* User programs must not use identifiers that start with these prefixes. *)
  25 let idprefix = "__ocaml_prof_";;
  26 let modprefix = "OCAML__prof_";;
  27
  28 (* Errors specific to the profiler *)
  29 exception Profiler of string
  30
  31 (* Modes *)
  32 let instr_fun    = ref false
  33 and instr_match  = ref false
  34 and instr_if     = ref false
  35 and instr_loops  = ref false
  36 and instr_try    = ref false
  37
  38 let cur_point = ref 0
  39 and inchan = ref stdin
  40 and outchan = ref stdout
  41
  42 (* To copy source fragments *)
  43 let copy_buffer = String.create 256
  44
  45 let copy_chars_unix nchars =
  46   let n = ref nchars in
  47   while !n > 0 do
  48     let m = input !inchan copy_buffer 0 (min !n 256) in
  49     if m = 0 then raise End_of_file;
  50     output !outchan copy_buffer 0 m;
  51     n := !n - m
  52   done
  53
  54 let copy_chars_win32 nchars =
  55   for i = 1 to nchars do
  56     let c = input_char !inchan in
  57     if c <> '\r' then output_char !outchan c
  58   done
  59
  60 let copy_chars =
  61   match Sys.os_type with
  62     "Win32" | "Cygwin" -> copy_chars_win32
  63   | _       -> copy_chars_unix
  64
  65 let copy next =
  66   assert (next >= !cur_point);
  67   seek_in !inchan !cur_point;
  68   copy_chars (next - !cur_point);
  69   cur_point := next;
  70 ;;
  71
  72 let prof_counter = ref 0;;
  73
  74 let instr_mode = ref false
  75
  76 type insert = Open | Close;;
  77 let to_insert = ref ([] : (insert * int) list);;
  78
  79 let insert_action st en =
  80   to_insert := (Open, st) :: (Close, en) :: !to_insert
  81 ;;
  82
  83 (* Producing instrumented code *)
  84 let add_incr_counter modul (kind,pos) =
  85    copy pos;
  86    match kind with
  87    | Open ->
  88          fprintf !outchan "(%sProfiling.incr %s%s_cnt %d; "
  89                  modprefix idprefix modul !prof_counter;
  90          incr prof_counter;
  91    | Close -> fprintf !outchan ")";
  92 ;;
  93
  94 let counters = ref (Array.create 0 0)
  95
  96 (* User defined marker *)
  97 let special_id = ref ""
  98
  99 (* Producing results of profile run *)
 100 let add_val_counter (kind,pos) =
 101   if kind = Open then begin
 102     copy pos;
 103     fprintf !outchan "(* %s%d *) " !special_id !counters.(!prof_counter);
 104     incr prof_counter;
 105   end
 106 ;;
 107
 108 (* ************* rewrite ************* *)
 109
 110 let insert_profile rw_exp ex =
 111   let st = ex.pexp_loc.loc_start.Lexing.pos_cnum
 112   and en = ex.pexp_loc.loc_end.Lexing.pos_cnum
 113   and gh = ex.pexp_loc.loc_ghost
 114   in
 115   if gh || st = en then
 116     rw_exp true ex
 117   else begin
 118     insert_action st en;
 119     rw_exp false ex;
 120   end
 121 ;;
 122
 123
 124 let pos_len = ref 0
 125
 126 let init_rewrite modes mod_name =
 127   cur_point := 0;
 128   if !instr_mode then begin
 129     fprintf !outchan "module %sProfiling = Profiling;; " modprefix;
 130     fprintf !outchan "let %s%s_cnt = Array.create 000000000" idprefix mod_name;
 131     pos_len := pos_out !outchan;
 132     fprintf !outchan
 133             " 0;; Profiling.counters := \
 134               (\"%s\", (\"%s\", %s%s_cnt)) :: !Profiling.counters;; "
 135             mod_name modes idprefix mod_name;
 136   end
 137
 138 let final_rewrite add_function =
 139   to_insert := Sort.list (fun x y -> snd x < snd y) !to_insert;
 140   prof_counter := 0;
 141   List.iter add_function !to_insert;
 142   copy (in_channel_length !inchan);
 143   if !instr_mode then begin
 144     let len = string_of_int !prof_counter in
 145     if String.length len > 9 then raise (Profiler "too many counters");
 146     seek_out !outchan (!pos_len - String.length len);
 147     output_string !outchan len
 148   end;
 149   (* Cannot close because outchan is stdout and Format doesn't like
 150      a closed stdout.
 151     close_out !outchan;
 152   *)
 153 ;;
 154
 155 let rec rewrite_patexp_list iflag l =
 156   rewrite_exp_list iflag (List.map snd l)
 157
 158 and rewrite_patlexp_list iflag l =
 159   rewrite_exp_list iflag (List.map snd l)
 160
 161 and rewrite_labelexp_list iflag l =
 162   rewrite_exp_list iflag (List.map snd l)
 163
 164 and rewrite_exp_list iflag l =
 165   List.iter (rewrite_exp iflag) l
 166
 167 and rewrite_exp iflag sexp =
 168   if iflag then insert_profile rw_exp sexp
 169            else rw_exp false sexp
 170
 171 and rw_exp iflag sexp =
 172   match sexp.pexp_desc with
 173     Pexp_ident lid -> ()
 174   | Pexp_constant cst -> ()
 175
 176   | Pexp_let(_, spat_sexp_list, sbody) ->
 177     rewrite_patexp_list iflag spat_sexp_list;
 178     rewrite_exp iflag sbody
 179
 180   | Pexp_function (_, _, caselist) ->
 181     if !instr_fun then
 182       rewrite_function iflag caselist
 183     else
 184       rewrite_patlexp_list iflag caselist
 185
 186   | Pexp_match(sarg, caselist) ->
 187     rewrite_exp iflag sarg;
 188     if !instr_match && not sexp.pexp_loc.loc_ghost then
 189       rewrite_funmatching caselist
 190     else
 191       rewrite_patlexp_list iflag caselist
 192
 193   | Pexp_try(sbody, caselist) ->
 194     rewrite_exp iflag sbody;
 195     if !instr_try && not sexp.pexp_loc.loc_ghost then
 196       rewrite_trymatching caselist
 197     else
 198       rewrite_patexp_list iflag caselist
 199
 200   | Pexp_apply(sfunct, sargs) ->
 201     rewrite_exp iflag sfunct;
 202     rewrite_exp_list iflag (List.map snd sargs)
 203
 204   | Pexp_tuple sexpl ->
 205     rewrite_exp_list iflag sexpl
 206
 207   | Pexp_construct(_, None, _) -> ()
 208   | Pexp_construct(_, Some sarg, _) ->
 209     rewrite_exp iflag sarg
 210
 211   | Pexp_variant(_, None) -> ()
 212   | Pexp_variant(_, Some sarg) ->
 213     rewrite_exp iflag sarg
 214
 215   | Pexp_record(lid_sexp_list, None) ->
 216     rewrite_labelexp_list iflag lid_sexp_list
 217   | Pexp_record(lid_sexp_list, Some sexp) ->
 218     rewrite_exp iflag sexp;
 219     rewrite_labelexp_list iflag lid_sexp_list
 220
 221   | Pexp_field(sarg, _) ->
 222     rewrite_exp iflag sarg
 223
 224   | Pexp_setfield(srecord, _, snewval) ->
 225     rewrite_exp iflag srecord;
 226     rewrite_exp iflag snewval
 227
 228   | Pexp_array(sargl) ->
 229     rewrite_exp_list iflag sargl
 230
 231   | Pexp_ifthenelse(scond, sifso, None) ->
 232       rewrite_exp iflag scond;
 233       rewrite_ifbody iflag sexp.pexp_loc.loc_ghost sifso
 234   | Pexp_ifthenelse(scond, sifso, Some sifnot) ->
 235       rewrite_exp iflag scond;
 236       rewrite_ifbody iflag sexp.pexp_loc.loc_ghost sifso;
 237       rewrite_ifbody iflag sexp.pexp_loc.loc_ghost sifnot
 238
 239   | Pexp_sequence(sexp1, sexp2) ->
 240     rewrite_exp iflag sexp1;
 241     rewrite_exp iflag sexp2
 242
 243   | Pexp_while(scond, sbody) ->
 244     rewrite_exp iflag scond;
 245     if !instr_loops && not sexp.pexp_loc.loc_ghost
 246     then insert_profile rw_exp sbody
 247     else rewrite_exp iflag sbody
 248
 249   | Pexp_for(_, slow, shigh, _, sbody) ->
 250     rewrite_exp iflag slow;
 251     rewrite_exp iflag shigh;
 252     if !instr_loops && not sexp.pexp_loc.loc_ghost
 253     then insert_profile rw_exp sbody
 254     else rewrite_exp iflag sbody
 255
 256   | Pexp_constraint(sarg, _, _) ->
 257     rewrite_exp iflag sarg
 258
 259   | Pexp_when(scond, sbody) ->
 260     rewrite_exp iflag scond;
 261     rewrite_exp iflag sbody
 262
 263   | Pexp_send (sobj, _) ->
 264     rewrite_exp iflag sobj
 265
 266   | Pexp_new _ -> ()
 267
 268   | Pexp_setinstvar (_, sarg) ->
 269     rewrite_exp iflag sarg
 270
 271   | Pexp_override l ->
 272       List.iter (fun (_, sexp) -> rewrite_exp iflag sexp) l
 273
 274   | Pexp_letmodule (_, smod, sexp) ->
 275       rewrite_mod iflag smod;
 276       rewrite_exp iflag sexp
 277
 278   | Pexp_assert (cond) -> rewrite_exp iflag cond
 279   | Pexp_assertfalse -> ()
 280
 281   | Pexp_lazy (expr) -> rewrite_exp iflag expr
 282
 283   | Pexp_poly (sexp, _) -> rewrite_exp iflag sexp
 284
 285   | Pexp_object (_, fieldl) ->
 286       List.iter (rewrite_class_field iflag) fieldl
 287
 288 and rewrite_ifbody iflag ghost sifbody =
 289   if !instr_if && not ghost then
 290     insert_profile rw_exp sifbody
 291   else
 292     rewrite_exp iflag sifbody
 293
 294 (* called only when !instr_fun *)
 295 and rewrite_annotate_exp_list l =
 296   List.iter
 297     (function
 298      | {pexp_desc = Pexp_when(scond, sbody)}
 299         -> insert_profile rw_exp scond;
 300            insert_profile rw_exp sbody;
 301      | {pexp_desc = Pexp_constraint(sbody, _, _)} (* let f x : t = e *)
 302         -> insert_profile rw_exp sbody
 303      | sexp -> insert_profile rw_exp sexp)
 304     l
 305
 306 and rewrite_function iflag = function
 307   | [spat, ({pexp_desc = Pexp_function _} as sexp)] -> rewrite_exp iflag sexp
 308   | l -> rewrite_funmatching l
 309
 310 and rewrite_funmatching l =
 311   rewrite_annotate_exp_list (List.map snd l)
 312
 313 and rewrite_trymatching l =
 314   rewrite_annotate_exp_list (List.map snd l)
 315
 316 (* Rewrite a class definition *)
 317
 318 and rewrite_class_field iflag =
 319   function
 320     Pcf_inher (cexpr, _)     -> rewrite_class_expr iflag cexpr
 321   | Pcf_val (_, _, sexp, _)  -> rewrite_exp iflag sexp
 322   | Pcf_meth (_, _, ({pexp_desc = Pexp_function _} as sexp), _) ->
 323       rewrite_exp iflag sexp
 324   | Pcf_meth (_, _, sexp, loc) ->
 325       if !instr_fun && not loc.loc_ghost then insert_profile rw_exp sexp
 326       else rewrite_exp iflag sexp
 327   | Pcf_let(_, spat_sexp_list, _) ->
 328       rewrite_patexp_list iflag spat_sexp_list
 329   | Pcf_init sexp ->
 330       rewrite_exp iflag sexp
 331   | Pcf_valvirt _ | Pcf_virt _ | Pcf_cstr _  -> ()
 332
 333 and rewrite_class_expr iflag cexpr =
 334   match cexpr.pcl_desc with
 335     Pcl_constr _ -> ()
 336   | Pcl_structure (_, fields) ->
 337       List.iter (rewrite_class_field iflag) fields
 338   | Pcl_fun (_, _, _, cexpr) ->
 339       rewrite_class_expr iflag cexpr
 340   | Pcl_apply (cexpr, exprs) ->
 341       rewrite_class_expr iflag cexpr;
 342       List.iter (rewrite_exp iflag) (List.map snd exprs)
 343   | Pcl_let (_, spat_sexp_list, cexpr) ->
 344       rewrite_patexp_list iflag spat_sexp_list;
 345       rewrite_class_expr iflag cexpr
 346   | Pcl_constraint (cexpr, _) ->
 347       rewrite_class_expr iflag cexpr
 348
 349 and rewrite_class_declaration iflag cl =
 350   rewrite_class_expr iflag cl.pci_expr
 351
 352 (* Rewrite a module expression or structure expression *)
 353
 354 and rewrite_mod iflag smod =
 355   match smod.pmod_desc with
 356     Pmod_ident lid -> ()
 357   | Pmod_structure sstr -> List.iter (rewrite_str_item iflag) sstr
 358   | Pmod_functor(param, smty, sbody) -> rewrite_mod iflag sbody
 359   | Pmod_apply(smod1, smod2) -> rewrite_mod iflag smod1; rewrite_mod iflag smod2
 360   | Pmod_constraint(smod, smty) -> rewrite_mod iflag smod
 361
 362 and rewrite_str_item iflag item =
 363   match item.pstr_desc with
 364     Pstr_eval exp -> rewrite_exp iflag exp
 365   | Pstr_value(_, exps)
 366      -> List.iter (function (_,exp) -> rewrite_exp iflag exp) exps
 367   | Pstr_module(name, smod) -> rewrite_mod iflag smod
 368   | Pstr_class classes -> List.iter (rewrite_class_declaration iflag) classes
 369   | _ -> ()
 370
 371 (* Rewrite a .ml file *)
 372 let rewrite_file srcfile add_function =
 373   inchan := open_in_bin srcfile;
 374   let lb = Lexing.from_channel !inchan in
 375   Location.input_name := srcfile;
 376   Location.init lb srcfile;
 377   List.iter (rewrite_str_item false) (Parse.implementation lb);
 378   final_rewrite add_function;
 379   close_in !inchan
 380
 381 (* Copy a non-.ml file without change *)
 382 let null_rewrite srcfile =
 383   inchan := open_in_bin srcfile;
 384   copy (in_channel_length !inchan);
 385   close_in !inchan
 386 ;;
 387
 388 (* Setting flags from saved config *)
 389 let set_flags s =
 390   for i = 0 to String.length s - 1 do
 391     match String.get s i with
 392       'f' -> instr_fun := true
 393     | 'm' -> instr_match := true
 394     | 'i' -> instr_if := true
 395     | 'l' -> instr_loops := true
 396     | 't' -> instr_try := true
 397     | 'a' -> instr_fun := true; instr_match := true;
 398              instr_if := true; instr_loops := true;
 399              instr_try := true
 400     | _ -> ()
 401     done
 402
 403 (* Command-line options *)
 404
 405 let modes = ref "fm"
 406 let dumpfile = ref "ocamlprof.dump"
 407
 408 (* Process a file *)
 409
 410 let process_intf_file filename = null_rewrite filename;;
 411
 412 let process_impl_file filename =
 413    let modname = Filename.basename(Filename.chop_extension filename) in
 414        (* FIXME should let modname = String.capitalize modname *)
 415    if !instr_mode then begin
 416      (* Instrumentation mode *)
 417      set_flags !modes;
 418      init_rewrite !modes modname;
 419      rewrite_file filename (add_incr_counter modname);
 420    end else begin
 421      (* Results mode *)
 422      let ic = open_in_bin !dumpfile in
 423      let allcounters =
 424        (input_value ic : (string * (string * int array)) list) in
 425      close_in ic;
 426      let (modes, cv) =
 427        try
 428          List.assoc modname allcounters
 429        with Not_found ->
 430          raise(Profiler("Module " ^ modname ^ " not used in this profile."))
 431      in
 432      counters := cv;
 433      set_flags modes;
 434      init_rewrite modes modname;
 435      rewrite_file filename add_val_counter;
 436    end
 437 ;;
 438
 439 let process_anon_file filename =
 440   if Filename.check_suffix filename ".ml" then
 441     process_impl_file filename
 442   else
 443     process_intf_file filename
 444 ;;
 445
 446 (* Main function *)
 447
 448 open Format
 449
 450 let usage = "Usage: ocamlprof <options> <files>\noptions are:"
 451
 452 let print_version () =
 453   printf "ocamlprof, version %s@." Sys.ocaml_version;
 454   exit 0;
 455 ;;
 456
 457 let main () =
 458   try
 459     Warnings.parse_options false "a";
 460     Arg.parse [
 461        "-f", Arg.String (fun s -> dumpfile := s),
 462              "<file>     Use <file> as dump file (default ocamlprof.dump)";
 463        "-F", Arg.String (fun s -> special_id := s),
 464              "<s>        Insert string <s> with the counts";
 465        "-impl", Arg.String process_impl_file,
 466                 "<file>  Process <file> as a .ml file";
 467        "-instrument", Arg.Set instr_mode, "  (undocumented)";
 468        "-intf", Arg.String process_intf_file,
 469                 "<file>  Process <file> as a .mli file";
 470        "-m", Arg.String (fun s -> modes := s), "<flags>    (undocumented)";
 471        "-version", Arg.Unit print_version,
 472                    "     Print version and exit";
 473       ] process_anon_file usage;
 474     exit 0
 475   with x ->
 476     let report_error ppf = function
 477     | Lexer.Error(err, range) ->
 478         fprintf ppf "@[%a%a@]@."
 479         Location.print_error range  Lexer.report_error err
 480     | Syntaxerr.Error err ->
 481         fprintf ppf "@[%a@]@."
 482         Syntaxerr.report_error err
 483     | Profiler msg ->
 484         fprintf ppf "@[%s@]@." msg
 485     | Sys_error msg ->
 486         fprintf ppf "@[I/O error:@ %s@]@." msg
 487     | x -> raise x in
 488     report_error Format.err_formatter x;
 489     exit 2
 490
 491 let _ = main ()