Add exclusive compiler phase tracing for OCaml rewatch

compiler/bsc/rescript_compiler_driver.ml

@@ -55,48 +55,52 @@ let setup_outcome_printer () = Lazy.force Res_outcome_printer.setup
 let setup_runtime_path path = Runtime_package.set_path path
 
 let process_file sourcefile ?kind ppf =
-  (* The input name must identify the source when writing the binary AST. *)
-  setup_outcome_printer ();
-  Error_message_utils_support.setup ();
-  let kind =
-    match kind with
-    | None ->
-      Ext_file_extensions.classify_input
-        (Ext_filename.get_extension_maybe sourcefile)
-    | Some kind -> kind
-  in
-  let res =
-    match kind with
-    | Res ->
-      let sourcefile = set_abs_input_name sourcefile in
-      Js_implementation.implementation
-        ~parser:
-          (Res_driver.parse_implementation
-             ~ignore_parse_errors:!((Clflags.current ()).ignore_parse_errors))
-        ppf sourcefile
-    | Resi ->
-      let sourcefile = set_abs_input_name sourcefile in
-      Js_implementation.interface
-        ~parser:
-          (Res_driver.parse_interface
-             ~ignore_parse_errors:!((Clflags.current ()).ignore_parse_errors))
-        ppf sourcefile
-    | Intf_ast -> Js_implementation.interface_mliast ppf sourcefile
-    (* The printer setup is done in the runtime depends on
+  Compiler_phase_trace.section "request.other" (fun () ->
+      (* The input name must identify the source when writing the binary AST. *)
+      setup_outcome_printer ();
+      Error_message_utils_support.setup ();
+      let kind =
+        match kind with
+        | None ->
+          Ext_file_extensions.classify_input
+            (Ext_filename.get_extension_maybe sourcefile)
+        | Some kind -> kind
+      in
+      let res =
+        match kind with
+        | Res ->
+          let sourcefile = set_abs_input_name sourcefile in
+          Js_implementation.implementation
+            ~parser:
+              (Res_driver.parse_implementation
+                 ~ignore_parse_errors:
+                   !((Clflags.current ()).ignore_parse_errors))
+            ppf sourcefile
+        | Resi ->
+          let sourcefile = set_abs_input_name sourcefile in
+          Js_implementation.interface
+            ~parser:
+              (Res_driver.parse_interface
+                 ~ignore_parse_errors:
+                   !((Clflags.current ()).ignore_parse_errors))
+            ppf sourcefile
+        | Intf_ast -> Js_implementation.interface_mliast ppf sourcefile
+        (* The printer setup is done in the runtime depends on
        the content of ast
     *)
-    | Impl_ast -> Js_implementation.implementation_mlast ppf sourcefile
-    | Mlmap ->
-      Location.set_input_name sourcefile;
-      Js_implementation.implementation_map ppf sourcefile
-    | Cmi ->
-      let cmi_sign = (Cmi_format.read_cmi sourcefile).cmi_sign in
-      let output = Compiler_request_output.stdout_formatter () in
-      Printtyp.signature output cmi_sign;
-      Format.pp_print_newline output ()
-    | Unknown -> Bsc_args.bad_arg ("don't know what to do with " ^ sourcefile)
-  in
-  res
+        | Impl_ast -> Js_implementation.implementation_mlast ppf sourcefile
+        | Mlmap ->
+          Location.set_input_name sourcefile;
+          Js_implementation.implementation_map ppf sourcefile
+        | Cmi ->
+          let cmi_sign = (Cmi_format.read_cmi sourcefile).cmi_sign in
+          let output = Compiler_request_output.stdout_formatter () in
+          Printtyp.signature output cmi_sign;
+          Format.pp_print_newline output ()
+        | Unknown ->
+          Bsc_args.bad_arg ("don't know what to do with " ^ sourcefile)
+      in
+      res)
 
 let reprint_source_file sourcefile =
   let kind =
@@ -597,50 +601,53 @@ let with_fresh_request_states ~cwd action =
                                                       .with_fresh ~cwd action)))))))))))))
 
 let run_argv ?run_external ~cwd argv =
-  with_fresh_request_states ~cwd (fun () ->
-      reset_state ~new_request:true ();
-      Cmt_format.set_args argv;
-      let execute () =
-        try
-          Bsc_args.parse_exn ~argv (command_line_flags ()) anonymous ~usage;
-          0
-        with
-        | Request_exit code -> code
-        | Bsc_args.Help message ->
-          Compiler_request_output.write_stdout message;
-          0
-        | Res_driver.Already_reported -> 1
-        | Bsc_args.Bad msg ->
-          Format.fprintf (ppf ()) "%s@." msg;
-          2
-        | x ->
-          Location.report_exception (ppf ()) x;
-          2
-      in
-      let run_with_external_owner action =
-        match run_external with
-        | None -> action ()
-        | Some run_external ->
-          Ccomp.with_command_runner
-            (fun command ->
-              let status, stdout, stderr = run_external command in
-              Compiler_request_output.write_stdout stdout;
-              Format.pp_print_string (ppf ()) stderr;
-              status)
-            action
-      in
-      let exit_code, stdout, stderr =
-        Fun.protect
-          (fun () ->
-            Compiler_request_output.with_capture (fun () ->
-                Misc.Color.set_color_tag_handling
-                  (Compiler_request_output.stdout_formatter ());
-                Misc.Color.set_color_tag_handling
-                  (Compiler_request_output.stderr_formatter ());
-                run_with_external_owner execute))
-          ~finally:reset_state
-      in
-      {exit_code; stdout; stderr})
+  let input = argv.(Array.length argv - 1) in
+  Compiler_phase_trace.request ~cwd ~input (fun () ->
+      with_fresh_request_states ~cwd (fun () ->
+          Compiler_phase_trace.section "request.reset" (fun () ->
+              reset_state ~new_request:true ());
+          Cmt_format.set_args argv;
+          let execute () =
+            try
+              Bsc_args.parse_exn ~argv (command_line_flags ()) anonymous ~usage;
+              0
+            with
+            | Request_exit code -> code
+            | Bsc_args.Help message ->
+              Compiler_request_output.write_stdout message;
+              0
+            | Res_driver.Already_reported -> 1
+            | Bsc_args.Bad msg ->
+              Format.fprintf (ppf ()) "%s@." msg;
+              2
+            | x ->
+              Location.report_exception (ppf ()) x;
+              2
+          in
+          let run_with_external_owner action =
+            match run_external with
+            | None -> action ()
+            | Some run_external ->
+              Ccomp.with_command_runner
+                (fun command ->
+                  let status, stdout, stderr = run_external command in
+                  Compiler_request_output.write_stdout stdout;
+                  Format.pp_print_string (ppf ()) stderr;
+                  status)
+                action
+          in
+          let exit_code, stdout, stderr =
+            Fun.protect
+              (fun () ->
+                Compiler_request_output.with_capture (fun () ->
+                    Misc.Color.set_color_tag_handling
+                      (Compiler_request_output.stdout_formatter ());
+                    Misc.Color.set_color_tag_handling
+                      (Compiler_request_output.stderr_formatter ());
+                    run_with_external_owner execute))
+              ~finally:reset_state
+          in
+          {exit_code; stdout; stderr}))
 
 let run_request ~run_external ~cwd ~argv ~input =
   let logical_argv = Array.of_list ("bsc" :: (argv @ [input])) in

compiler/core/bs_cmi_load.ml

@@ -23,33 +23,36 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
 
 let load_cmi ~unit_name : Env.Persistent_signature.t option =
-  (* On case-insensitive filesystems a lowercase alias can remain visible to
+  Compiler_phase_trace.dependency ("dependency.search_open:" ^ unit_name)
+    (fun () ->
+      (* On case-insensitive filesystems a lowercase alias can remain visible to
      [Sys.file_exists] briefly after its CMI is removed. Open each candidate
      once and parse that descriptor, so a vanished CMI is a missing module. *)
-  let name = unit_name ^ ".cmi" in
-  let lower_name = String.uncapitalize_ascii name in
-  let rec find = function
-    | [] -> None
-    | directory :: rest ->
-      let rec try_names = function
-        | [] -> find rest
-        | name :: names -> (
-          let filename = Filename.concat directory name in
-          let path = Compiler_request_state.resolve_path filename in
-          match Unix.openfile path [Unix.O_RDONLY] 0 with
-          | descriptor ->
-            let channel = Unix.in_channel_of_descr descriptor in
-            let cmi =
-              Fun.protect
-                (fun () -> Cmi_format.read_cmi_channel filename channel)
-                ~finally:(fun () -> close_in_noerr channel)
-            in
-            Some Env.Persistent_signature.{filename; cmi}
-          | exception Unix.Unix_error ((Unix.ENOENT | Unix.ENOTDIR), _, _) ->
-            try_names names
-          | exception Unix.Unix_error (error, _, _) ->
-            raise (Sys_error (path ^ ": " ^ Unix.error_message error)))
+      let name = unit_name ^ ".cmi" in
+      let lower_name = String.uncapitalize_ascii name in
+      let rec find = function
+        | [] -> None
+        | directory :: rest ->
+          let rec try_names = function
+            | [] -> find rest
+            | name :: names -> (
+              let filename = Filename.concat directory name in
+              let path = Compiler_request_state.resolve_path filename in
+              match Unix.openfile path [Unix.O_RDONLY] 0 with
+              | descriptor ->
+                let channel = Unix.in_channel_of_descr descriptor in
+                let cmi =
+                  Fun.protect
+                    (fun () -> Cmi_format.read_cmi_channel filename channel)
+                    ~finally:(fun () -> close_in_noerr channel)
+                in
+                Some Env.Persistent_signature.{filename; cmi}
+              | exception Unix.Unix_error ((Unix.ENOENT | Unix.ENOTDIR), _, _)
+                ->
+                try_names names
+              | exception Unix.Unix_error (error, _, _) ->
+                raise (Sys_error (path ^ ": " ^ Unix.error_message error)))
+          in
+          try_names (if lower_name = name then [name] else [lower_name; name])
       in
-      try_names (if lower_name = name then [name] else [lower_name; name])
-  in
-  find (Config.get_load_path ())
+      find (Config.get_load_path ()))

compiler/core/js_implementation.ml

@@ -54,13 +54,17 @@ let after_parsing_sig ppf outputprefix ast =
       Lam_compile_env.reset ();
       let initial_env = Res_compmisc.initial_env ~modulename () in
       Env.set_unit_name modulename;
-      let tsg = Typemod.transl_signature initial_env ast in
+      let tsg =
+        Compiler_phase_trace.section "source.check" (fun () ->
+            Typemod.transl_signature initial_env ast)
+      in
       if !((Clflags.current ()).dump_typedtree) then
         fprintf ppf "%a@." Printtyped.interface tsg;
       let sg = tsg.sig_type in
-      ignore (Includemod.signatures initial_env sg sg);
-      Delayed_checks.force_delayed_checks ();
-      Warnings.check_fatal ();
+      Compiler_phase_trace.section "source.check" (fun () ->
+          ignore (Includemod.signatures initial_env sg sg);
+          Delayed_checks.force_delayed_checks ();
+          Warnings.check_fatal ());
       let deprecated = Builtin_attributes.deprecated_of_sig ast in
       let sg =
         Env.save_signature ~deprecated sg modulename (outputprefix ^ ".cmi")
@@ -76,7 +80,7 @@ let interface ~parser ppf ?outputprefix fname =
     | None -> Config_util.output_prefix fname
     | Some x -> x
   in
-  Res_compmisc.init_path ();
+  Compiler_phase_trace.section "setup.path" Res_compmisc.init_path;
   parser fname
   |> Cmd_ppx_apply.apply_rewriters ~restore:false ~tool_name:Js_config.tool_name
        Mli
@@ -86,7 +90,7 @@ let interface ~parser ppf ?outputprefix fname =
   |> after_parsing_sig ppf outputprefix
 
 let interface_mliast ppf fname =
-  Res_compmisc.init_path ();
+  Compiler_phase_trace.section "setup.path" Res_compmisc.init_path;
   Binary_ast.read_ast_exn ~fname Mli
   |> print_if_pipe ppf (Clflags.current ()).dump_parsetree Printast.interface
   |> print_if_pipe ppf (Clflags.current ()).dump_source Pprintast.signature
@@ -170,7 +174,7 @@ let implementation ~parser ppf ?outputprefix fname =
     | None -> Config_util.output_prefix fname
     | Some x -> x
   in
-  Res_compmisc.init_path ();
+  Compiler_phase_trace.section "setup.path" Res_compmisc.init_path;
   parser fname
   |> Cmd_ppx_apply.apply_rewriters ~restore:false ~tool_name:Js_config.tool_name
        Ml
@@ -181,7 +185,7 @@ let implementation ~parser ppf ?outputprefix fname =
   |> after_parsing_impl ppf outputprefix
 
 let implementation_mlast ppf fname =
-  Res_compmisc.init_path ();
+  Compiler_phase_trace.section "setup.path" Res_compmisc.init_path;
   Binary_ast.read_ast_exn ~fname Ml
   |> print_if_pipe ppf (Clflags.current ()).dump_parsetree
        Printast.implementation

compiler/core/res_compmisc.ml

@@ -46,22 +46,23 @@ let open_implicit_module m env =
   snd (Typemod.type_open_ Override env lid.loc lid)
 
 let initial_env ?modulename () =
-  Ident.reinit ();
-  let open_modules =
-    match modulename with
-    | None -> !((Clflags.current ()).open_modules)
-    | Some modulename ->
-      !((Clflags.current ()).open_modules)
-      |> List.filter (fun m -> m <> modulename)
-  in
-  let initial = Env.initial_safe_string () in
-  let env =
-    if !((Clflags.current ()).nopervasives) then initial
-    else
-      initial
-      |> open_implicit_module "Pervasives"
-      |> open_implicit_module "Stdlib"
-  in
-  List.fold_left
-    (fun env m -> open_implicit_module m env)
-    env (List.rev open_modules)
+  Compiler_phase_trace.section "setup.initial_env" (fun () ->
+      Ident.reinit ();
+      let open_modules =
+        match modulename with
+        | None -> !((Clflags.current ()).open_modules)
+        | Some modulename ->
+          !((Clflags.current ()).open_modules)
+          |> List.filter (fun m -> m <> modulename)
+      in
+      let initial = Env.initial_safe_string () in
+      let env =
+        if !((Clflags.current ()).nopervasives) then initial
+        else
+          initial
+          |> open_implicit_module "Pervasives"
+          |> open_implicit_module "Stdlib"
+      in
+      List.fold_left
+        (fun env m -> open_implicit_module m env)
+        env (List.rev open_modules))