Merge pull request #1027 from sliquister/fix-dtimings2

Various fixes for -dtimings

Changes

@@ -224,6 +224,9 @@ Next version (4.05.0):
 
 ### Internal/compiler-libs changes:
 
+- GPR#673: distinguish initialization of block fields from mutation in lambda.
+  (Frédéric Bour, review by Xavier Leroy, Stephen Dolan and Mark Shinwell)
+
 - GPR#744, GPR#781: fix duplicate self-reference in imported cmi_crcs
   list in .cmti files + avoid rebuilding cmi_info record when creating
   .cmti files
@@ -235,15 +238,16 @@ Next version (4.05.0):
   include(struct ... end : sig ... end)
   (Alain Frisch, report by Hongbo Zhang, review by Jacques Garrigue)
 
-- GPR#908: refactor PIC-handling in the s390x backend
-  (Gabriel Scherer)
-
 - GPR#881: change `Outcometree.out_variant` to be more general.
   `Ovar_name of out_ident * out_type list` becomes `Ovar_type of out_type`.
   (Valentin Gatien-Baron)
 
-- GPR#673: distinguish initialization of block fields from mutation in lambda.
-  (Frédéric Bour, review by Xavier Leroy, Stephen Dolan and Mark Shinwell)
+- GPR#908: refactor PIC-handling in the s390x backend
+  (Gabriel Scherer)
+
+- GPR#1027: various improvements to -dtimings, mostly including time
+  spent in subprocesses like preprocessors
+  (Valentin Gatien-Baron, review by Gabriel Scherer)
 
 ### Bug fixes
 

byterun/sys.c

@@ -382,14 +382,23 @@ CAMLprim value caml_sys_system_command(value command)
   CAMLreturn (Val_int(retcode));
 }
 
-double caml_sys_time_unboxed(value unit)
+double caml_sys_time_include_children_unboxed(value include_children)
 {
 #ifdef HAS_GETRUSAGE
   struct rusage ru;
+  double acc = 0.;
 
   getrusage (RUSAGE_SELF, &ru);
-  return ru.ru_utime.tv_sec + ru.ru_utime.tv_usec / 1e6
+  acc += ru.ru_utime.tv_sec + ru.ru_utime.tv_usec / 1e6
     + ru.ru_stime.tv_sec + ru.ru_stime.tv_usec / 1e6;
+
+  if (Bool_val(include_children)) {
+    getrusage (RUSAGE_CHILDREN, &ru);
+    acc += ru.ru_utime.tv_sec + ru.ru_utime.tv_usec / 1e6
+      + ru.ru_stime.tv_sec + ru.ru_stime.tv_usec / 1e6;
+  }
+
+  return acc;
 #else
   #ifdef HAS_TIMES
     #ifndef CLK_TCK
@@ -400,15 +409,30 @@ double caml_sys_time_unboxed(value unit)
       #endif
     #endif
     struct tms t;
+    clock_t acc = 0;
     times(&t);
-    return (double)(t.tms_utime + t.tms_stime) / CLK_TCK;
+    acc += t.tms_utime + t.tms_stime;
+    if (Bool_val(include_children)) {
+      acc += t.tms_cutime + t.tms_cstime;
+    }
+    return (double)acc / CLK_TCK;
   #else
-    /* clock() is standard ANSI C */
+    /* clock() is standard ANSI C. We have no way of getting
+       subprocess times in this branch. */
     return (double)clock() / CLOCKS_PER_SEC;
   #endif
 #endif
 }
 
+CAMLprim value caml_sys_time_include_children(value include_children)
+{
+  return caml_copy_double(caml_sys_time_include_children_unboxed(include_children));
+}
+
+double caml_sys_time_unboxed(value unit) {
+  return caml_sys_time_include_children_unboxed(Val_false);
+}
+
 CAMLprim value caml_sys_time(value unit)
 {
   return caml_copy_double(caml_sys_time_unboxed(unit));

driver/compile.ml

@@ -35,24 +35,26 @@ let interface ppf sourcefile outputprefix =
 
   if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast;
   if !Clflags.dump_source then fprintf ppf "%a@." Pprintast.signature ast;
-  let tsg = Typemod.type_interface sourcefile initial_env ast in
-  if !Clflags.dump_typedtree then fprintf ppf "%a@." Printtyped.interface tsg;
-  let sg = tsg.sig_type in
-  if !Clflags.print_types then
-    Printtyp.wrap_printing_env initial_env (fun () ->
-        fprintf std_formatter "%a@."
-          Printtyp.signature (Typemod.simplify_signature sg));
-  ignore (Includemod.signatures initial_env sg sg);
-  Typecore.force_delayed_checks ();
-  Warnings.check_fatal ();
-  if not !Clflags.print_types then begin
-    let deprecated = Builtin_attributes.deprecated_of_sig ast in
-    let sg =
-      Env.save_signature ~deprecated sg modulename (outputprefix ^ ".cmi")
-    in
-    Typemod.save_signature modulename tsg outputprefix sourcefile
-      initial_env sg ;
-  end
+  Timings.(time_call (Typing sourcefile)) (fun () ->
+    let tsg = Typemod.type_interface sourcefile initial_env ast in
+    if !Clflags.dump_typedtree then fprintf ppf "%a@." Printtyped.interface tsg;
+    let sg = tsg.sig_type in
+    if !Clflags.print_types then
+      Printtyp.wrap_printing_env initial_env (fun () ->
+          fprintf std_formatter "%a@."
+            Printtyp.signature (Typemod.simplify_signature sg));
+    ignore (Includemod.signatures initial_env sg sg);
+    Typecore.force_delayed_checks ();
+    Warnings.check_fatal ();
+    if not !Clflags.print_types then begin
+      let deprecated = Builtin_attributes.deprecated_of_sig ast in
+      let sg =
+        Env.save_signature ~deprecated sg modulename (outputprefix ^ ".cmi")
+      in
+      Typemod.save_signature modulename tsg outputprefix sourcefile
+        initial_env sg ;
+    end
+  )
 
 (* Compile a .ml file *)
 

driver/optcompile.ml

@@ -35,24 +35,26 @@ let interface ppf sourcefile outputprefix =
   let ast = Pparse.parse_interface ~tool_name ppf sourcefile in
   if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast;
   if !Clflags.dump_source then fprintf ppf "%a@." Pprintast.signature ast;
-  let tsg = Typemod.type_interface sourcefile initial_env ast in
-  if !Clflags.dump_typedtree then fprintf ppf "%a@." Printtyped.interface tsg;
-  let sg = tsg.sig_type in
-  if !Clflags.print_types then
-    Printtyp.wrap_printing_env initial_env (fun () ->
-        fprintf std_formatter "%a@."
-          Printtyp.signature (Typemod.simplify_signature sg));
-  ignore (Includemod.signatures initial_env sg sg);
-  Typecore.force_delayed_checks ();
-  Warnings.check_fatal ();
-  if not !Clflags.print_types then begin
-    let deprecated = Builtin_attributes.deprecated_of_sig ast in
-    let sg =
-      Env.save_signature ~deprecated sg modulename (outputprefix ^ ".cmi")
-    in
-    Typemod.save_signature modulename tsg outputprefix sourcefile
-      initial_env sg ;
-  end
+  Timings.(time_call (Typing sourcefile)) (fun () ->
+    let tsg = Typemod.type_interface sourcefile initial_env ast in
+    if !Clflags.dump_typedtree then fprintf ppf "%a@." Printtyped.interface tsg;
+    let sg = tsg.sig_type in
+    if !Clflags.print_types then
+      Printtyp.wrap_printing_env initial_env (fun () ->
+          fprintf std_formatter "%a@."
+            Printtyp.signature (Typemod.simplify_signature sg));
+    ignore (Includemod.signatures initial_env sg sg);
+    Typecore.force_delayed_checks ();
+    Warnings.check_fatal ();
+    if not !Clflags.print_types then begin
+      let deprecated = Builtin_attributes.deprecated_of_sig ast in
+      let sg =
+        Env.save_signature ~deprecated sg modulename (outputprefix ^ ".cmi")
+      in
+      Typemod.save_signature modulename tsg outputprefix sourcefile
+        initial_env sg ;
+    end
+  )
 
 (* Compile a .ml file *)
 

driver/pparse.ml

@@ -38,7 +38,7 @@ let preprocess sourcefile =
   match !Clflags.preprocessor with
     None -> sourcefile
   | Some pp ->
-      Timings.(time (Preprocessing sourcefile))
+      Timings.(time (Dash_pp sourcefile))
         (call_external_preprocessor sourcefile) pp
 
 
@@ -166,6 +166,7 @@ let parse (type a) (kind : a ast_kind) lexbuf : a =
 let file_aux ppf ~tool_name inputfile (type a) parse_fun invariant_fun
              (kind : a ast_kind) =
   let ast_magic = magic_of_kind kind in
+  let source_file = !Location.input_name in
   let (ic, is_ast_file) = open_and_check_magic inputfile ast_magic in
   let ast =
     try
@@ -181,12 +182,15 @@ let file_aux ppf ~tool_name inputfile (type a) parse_fun invariant_fun
         Location.input_name := inputfile;
         let lexbuf = Lexing.from_channel ic in
         Location.init lexbuf inputfile;
-        parse_fun lexbuf
+        Timings.(time_call (Parser source_file)) (fun () ->
+          parse_fun lexbuf)
       end
     with x -> close_in ic; raise x
   in
   close_in ic;
-  let ast = apply_rewriters ~restore:false ~tool_name kind ast in
+  let ast =
+    Timings.(time_call (Dash_ppx source_file)) (fun () ->
+      apply_rewriters ~restore:false ~tool_name kind ast) in
   if is_ast_file || !Clflags.all_ppx <> [] then invariant_fun ast;
   ast
 
@@ -212,8 +216,7 @@ let parse_file ~tool_name invariant_fun apply_hooks kind ppf sourcefile =
   Location.input_name := sourcefile;
   let inputfile = preprocess sourcefile in
   let ast =
-    let parse_fun = Timings.(time (Parsing sourcefile)) (parse kind) in
-    try file_aux ppf ~tool_name inputfile parse_fun invariant_fun kind
+    try file_aux ppf ~tool_name inputfile (parse kind) invariant_fun kind
     with exn ->
       remove_preprocessed inputfile;
       raise exn
@@ -230,8 +233,10 @@ module InterfaceHooks = Misc.MakeHooks(struct
   end)
 
 let parse_implementation ppf ~tool_name sourcefile =
-  parse_file ~tool_name Ast_invariants.structure
-    ImplementationHooks.apply_hooks Structure ppf sourcefile
+  Timings.(time_call (Parsing sourcefile)) (fun () ->
+    parse_file ~tool_name Ast_invariants.structure
+      ImplementationHooks.apply_hooks Structure ppf sourcefile)
 let parse_interface ppf ~tool_name sourcefile =
-  parse_file ~tool_name Ast_invariants.signature
-    InterfaceHooks.apply_hooks Signature ppf sourcefile
+  Timings.(time_call (Parsing sourcefile)) (fun () ->
+    parse_file ~tool_name Ast_invariants.signature
+      InterfaceHooks.apply_hooks Signature ppf sourcefile)

utils/timings.ml

@@ -24,7 +24,9 @@ type source_provenance =
 type compiler_pass =
   | All
   | Parsing of file
-  | Preprocessing of file
+  | Parser of file
+  | Dash_pp of file
+  | Dash_ppx of file
   | Typing of file
   | Transl of file
   | Generate of file
@@ -48,40 +50,45 @@ type compiler_pass =
 let timings : (compiler_pass, float * float option) Hashtbl.t =
   Hashtbl.create 20
 
+external time_include_children: bool -> float = "caml_sys_time_include_children"
+let cpu_time () = time_include_children true
+
 let reset () = Hashtbl.clear timings
 
 let start pass =
   (* Cannot assert it is not here: a source file can be compiled
      multiple times on the same command line *)
   (* assert(not (Hashtbl.mem timings pass)); *)
-  let time = Sys.time () in
+  let time = cpu_time () in
   Hashtbl.add timings pass (time, None)
 
 let stop pass =
   assert(Hashtbl.mem timings pass);
-  let time = Sys.time () in
+  let time = cpu_time () in
   let (start, stop) = Hashtbl.find timings pass in
   assert(stop = None);
   Hashtbl.replace timings pass (start, Some (time -. start))
 
-let time pass f x =
+let time_call pass f =
   start pass;
-  let r = f x in
+  let r = f () in
   stop pass;
   r
 
+let time pass f x = time_call pass (fun () -> f x)
+
 let restart pass =
   let previous_duration =
     match Hashtbl.find timings pass with
     | exception Not_found -> 0.
     | (_, Some duration) -> duration
     | _, None -> assert false
   in
-  let time = Sys.time () in
+  let time = cpu_time () in
   Hashtbl.replace timings pass (time, Some previous_duration)
 
 let accumulate pass =
-  let time = Sys.time () in
+  let time = cpu_time () in
   match Hashtbl.find timings pass with
   | exception Not_found -> assert false
   | _, None -> assert false
@@ -110,7 +117,9 @@ let kind_name = function
 let pass_name = function
   | All -> "all"
   | Parsing file -> Printf.sprintf "parsing(%s)" file
-  | Preprocessing file -> Printf.sprintf "preprocessing(%s)" file
+  | Parser file -> Printf.sprintf "parser(%s)" file
+  | Dash_pp file -> Printf.sprintf "-pp(%s)" file
+  | Dash_ppx file -> Printf.sprintf "-ppx(%s)" file
   | Typing file -> Printf.sprintf "typing(%s)" file
   | Transl file -> Printf.sprintf "transl(%s)" file
   | Generate file -> Printf.sprintf "generate(%s)" file
@@ -134,15 +143,16 @@ let pass_name = function
 
 let timings_list () =
   let l = Hashtbl.fold (fun pass times l -> (pass, times) :: l) timings [] in
-  List.sort (fun (_, (start1, _)) (_, (start2, _)) -> compare start1 start2) l
+  List.sort (fun (pass1, (start1, _)) (pass2, (start2, _)) ->
+    compare (start1, pass1) (start2, pass2)) l
 
 let print ppf =
-  let current_time = Sys.time () in
+  let current_time = cpu_time () in
   List.iter (fun (pass, (start, stop)) ->
       match stop with
       | Some duration ->
         Format.fprintf ppf "%s: %.03fs@." (pass_name pass) duration
       | None ->
-        Format.fprintf ppf "%s: running since %.03fs@." (pass_name pass)
+        Format.fprintf ppf "%s: running for %.03fs@." (pass_name pass)
           (current_time -. start))
     (timings_list ())

utils/timings.mli

@@ -26,7 +26,9 @@ type source_provenance =
 type compiler_pass =
   | All
   | Parsing of file
-  | Preprocessing of file
+  | Parser of file
+  | Dash_pp of file
+  | Dash_ppx of file
   | Typing of file
   | Transl of file
   | Generate of file
@@ -53,8 +55,11 @@ val reset : unit -> unit
 val get : compiler_pass -> float option
 (** returns the runtime in seconds of a completed pass *)
 
+val time_call : compiler_pass -> (unit -> 'a) -> 'a
+(** [time_call pass f] calls [f] and records its runtime. *)
+
 val time : compiler_pass -> ('a -> 'b) -> 'a -> 'b
-(** [time pass f arg] Record the runtime of [f arg] *)
+(** [time pass f arg] records the runtime of [f arg] *)
 
 val accumulate_time : compiler_pass -> ('a -> 'b) -> 'a -> 'b
 (** Like time for passes that can run multiple times *)