Clean up IR diagnostics

CHANGELOG.md

@@ -34,6 +34,7 @@
 #### :house: Internal
 
 - Add the `-check-lam` compiler option, enable Lambda invariant checking in compiler tests, and remove build-profile-dependent checking. https://github.com/rescript-lang/rescript/pull/8534
+- Replace `-bs-diagnose` with `-debug-ir` and make IR diagnostic artifacts deterministic, compilation-local, and easy to clean. https://github.com/rescript-lang/rescript/pull/8535
 
 # 13.0.0-alpha.5
 

compiler/bsc/rescript_compiler_main.ml

@@ -409,7 +409,9 @@ let command_line_flags : (string * Bsc_args.spec * string) array =
     ( "-bs-no-cross-module-opt",
       clear Js_config.cross_module_inline,
       "*internal* Disable cross module inlining(experimental)" );
-    ("-bs-diagnose", set Js_config.diagnose, "*internal* More verbose output");
+    ( "-debug-ir",
+      set Js_config.debug_ir,
+      "*internal* Dump compiler IR and enable Lam invariant checks" );
     ( "-check-lam",
       set Js_config.check_lam,
       "*internal* Check Lam invariants after optimization passes" );

compiler/common/ext_log.ml

@@ -26,7 +26,7 @@ type 'a logging = ('a, Format.formatter, unit, unit, unit, unit) format6 -> 'a
 
 (* TODO: add {[@.]} later for all *)
 let dwarn ?(__POS__ : (string * int * int * int) option) f =
-  if !Js_config.diagnose then
+  if !Js_config.debug_ir then
     match __POS__ with
     | None -> Format.fprintf Format.err_formatter ("WARN: " ^^ f ^^ "@.")
     | Some (file, line, _, _) ->

compiler/common/js_config.ml

@@ -32,7 +32,7 @@ let no_version_header = ref false
 
 let directives = ref []
 let cross_module_inline = ref false
-let diagnose = ref false
+let debug_ir = ref false
 let check_lam = ref false
 
 (* let (//) = Filename.concat *)

compiler/common/js_config.mli

@@ -49,8 +49,8 @@ val directives : string list ref
 val cross_module_inline : bool ref
 (** cross module inline option *)
 
-val diagnose : bool ref
-(** diagnose option *)
+val debug_ir : bool ref
+(** dump intermediate representations and related diagnostics *)
 
 val check_lam : bool ref
 (** check Lam invariants after optimization passes *)

compiler/core/dune

@@ -13,20 +13,8 @@
  (action
   (run %{bin:cppo} %{env:CPPO_FLAGS=} %{deps} -o %{target})))
 
-(rule
- (target js_pass_debug.ml)
- (deps js_pass_debug.cppo.ml)
- (action
-  (run %{bin:cppo} %{env:CPPO_FLAGS=} %{deps} -o %{target})))
-
 (rule
  (target lam_compile_main.ml)
  (deps lam_compile_main.cppo.ml)
  (action
   (run %{bin:cppo} %{env:CPPO_FLAGS=} %{deps} -o %{target})))
-
-(rule
- (target lam_util.ml)
- (deps lam_util.cppo.ml)
- (action
-  (run %{bin:cppo} %{env:CPPO_FLAGS=} %{deps} -o %{target})))

compiler/core/ir_diagnostics.ml

@@ -0,0 +1,48 @@
+type t = {directory: string; mutable next_index: int}
+
+let is_artifact filename =
+  match Ext_filename.get_extension_maybe filename with
+  | ".lam" | ".lambda" | ".jsx" -> true
+  | _ -> false
+
+let remove_stale_artifacts directory =
+  Sys.readdir directory
+  |> Array.iter (fun filename ->
+         if is_artifact filename then
+           Misc.remove_file (Filename.concat directory filename))
+
+let create ~output_prefix =
+  let directory = output_prefix ^ ".debug-ir" in
+  if Sys.file_exists directory then (
+    if not (Ext_sys.is_directory_no_exn directory) then
+      failwith (Printf.sprintf "%s exists and is not a directory" directory);
+    remove_stale_artifacts directory)
+  else Sys.mkdir directory 0o755;
+  Ext_log.dwarn ~__POS__ "Writing IR diagnostics to %s" directory;
+  {directory; next_index = 1}
+
+let next_path diagnostics ~kind ~pass ~extension =
+  let index = diagnostics.next_index in
+  diagnostics.next_index <- index + 1;
+  Filename.concat diagnostics.directory
+    (Printf.sprintf "%02d-%s-%s%s" index kind pass extension)
+
+let dump_lam diagnostics ~pass lam =
+  let path = next_path diagnostics ~kind:"lam" ~pass ~extension:".lam" in
+  Ext_log.dwarn ~__POS__ "Dumping Lam pass %s to %s" pass path;
+  Lam_print.serialize path lam
+
+let dump_groups diagnostics groups =
+  let path =
+    next_path diagnostics ~kind:"lam" ~pass:"groups" ~extension:".lambda"
+  in
+  Ext_log.dwarn ~__POS__ "Dumping Lam groups to %s" path;
+  Ext_fmt.with_file_as_pp path (fun fmt ->
+      Format.pp_print_list ~pp_sep:Format.pp_print_newline Lam_group.pp_group
+        fmt groups)
+
+let dump_js diagnostics ~pass program =
+  let path = next_path diagnostics ~kind:"js" ~pass ~extension:".jsx" in
+  Ext_log.dwarn ~__POS__ "Dumping JS pass %s to %s" pass path;
+  Ext_pervasives.with_file_as_chan path (fun channel ->
+      Js_dump_program.dump_program program channel)

compiler/core/ir_diagnostics.mli

@@ -0,0 +1,6 @@
+type t
+
+val create : output_prefix:string -> t
+val dump_lam : t -> pass:string -> Lam.t -> unit
+val dump_groups : t -> Lam_group.t list -> unit
+val dump_js : t -> pass:string -> J.program -> unit

compiler/core/lam_compile_main.cppo.ml

@@ -116,32 +116,38 @@ let no_side_effects (rest : Lam_group.t list) : string option =
         else None (* TODO :*))
 
 
-let _d = fun s lam ->
-  let diagnose = !Js_config.diagnose in
-  if diagnose then begin
-    Lam_util.dump s lam;
-    Ext_log.dwarn ~__POS__ "START CHECKING PASS %s@." s
-  end;
-  if !Js_config.check_lam || diagnose then begin
-    ignore @@ Lam_check.check ~file:!Location.input_name ~pass:s lam;
-    if diagnose then Ext_log.dwarn ~__POS__ "FINISH CHECKING PASS %s@." s
-  end;
-  lam
-
-let _j name program =
-  if !Js_config.diagnose then Js_pass_debug.dump name program else program
-
 (** Actually simplify_lets is kind of global optimization since it requires you to know whether 
     it's used or not 
 *)
 let compile  
     (output_prefix : string)
     export_idents
     (lam : Lambda.lambda)  = 
+  let debug_ir = !Js_config.debug_ir in
+  let diagnostics =
+    if debug_ir then Some (Ir_diagnostics.create ~output_prefix) else None
+  in
+  let d pass lam =
+    (match diagnostics with
+    | Some diagnostics ->
+      Ir_diagnostics.dump_lam diagnostics ~pass lam;
+      Ext_log.dwarn ~__POS__ "START CHECKING PASS %s@." pass
+    | None -> ());
+    if !Js_config.check_lam || debug_ir then begin
+      ignore @@ Lam_check.check ~file:!Location.input_name ~pass lam;
+      if debug_ir then Ext_log.dwarn ~__POS__ "FINISH CHECKING PASS %s@." pass
+    end;
+    lam
+  in
+  let j pass program =
+    Ext_option.iter diagnostics (fun diagnostics ->
+        Ir_diagnostics.dump_js diagnostics ~pass program);
+    program
+  in
   let export_ident_sets = Set_ident.of_list export_idents in 
   (* To make toplevel happy - reentrant for js-demo *)
   let () =
-    if !Js_config.diagnose then begin
+    if debug_ir then begin
       Ext_list.iter export_idents 
         (fun id -> Ext_log.dwarn ~__POS__ "export idents: %s/%d" id.name id.stamp)
     end;
@@ -150,9 +156,9 @@ let compile
   let lam, may_required_modules = Lam_convert.convert export_ident_sets lam in 
 
 
-  let lam = _d "initial"  lam in
+  let lam = d "initial"  lam in
   let lam  = Lam_pass_deep_flatten.deep_flatten lam in
-  let lam = _d  "flatten0" lam in
+  let lam = d  "flatten0" lam in
   let meta  : Lam_stats.t = 
     Lam_stats.make 
       ~export_idents
@@ -161,19 +167,19 @@ let compile
   let lam = 
     let lam =  
       lam
-      |> _d "flattern1"
+      |> d "flatten1"
       |>  Lam_pass_exits.simplify_exits
-      |> _d "simplyf_exits"
+      |> d "simplify_exits"
       |> (fun lam ->
           Lam_pass_collect.collect_info meta lam;
-          if !Js_config.diagnose then
+          if debug_ir then
             Ext_log.dwarn ~__POS__ "Before simplify_alias: %a@." Lam_stats.print
               meta;
           lam)
       |>  Lam_pass_remove_alias.simplify_alias  meta
-      |> _d "simplify_alias"
+      |> d "simplify_alias"
       |> Lam_pass_deep_flatten.deep_flatten
-      |> _d  "flatten2"
+      |> d  "flatten2"
     in  (* Inling happens*)
 
     let ()  = Lam_pass_collect.collect_info meta lam in
@@ -182,31 +188,31 @@ let compile
     let ()  = Lam_pass_collect.collect_info meta lam in
     let lam = 
       lam
-      |> _d "alpha_before"
+      |> d "alpha_before"
       |> Lam_pass_alpha_conversion.alpha_conversion meta
-      |> _d "alpha_after"
+      |> d "alpha_after"
       |> Lam_pass_exits.simplify_exits in    
     let () = Lam_pass_collect.collect_info meta lam in
 
 
     lam
-    |> _d "simplify_alias_before"
+    |> d "simplify_alias_before"
     |>  Lam_pass_remove_alias.simplify_alias meta 
-    |> _d "alpha_conversion"
+    |> d "alpha_conversion"
     |>  Lam_pass_alpha_conversion.alpha_conversion meta
-    |> _d  "before-simplify_lets"
+    |> d  "before-simplify_lets"
     (* we should investigate a better way to put different passes : )*)
     |> Lam_pass_lets_dce.simplify_lets 
 
-    |> _d "before-simplify-exits"
+    |> d "before-simplify-exits"
     (* |> (fun lam -> Lam_pass_collect.collect_info meta lam 
        ; Lam_pass_remove_alias.simplify_alias meta lam) *)
     (* |> Lam_group_pass.scc_pass
-       |> _d "scc" *)
+       |> d "scc" *)
     |> Lam_pass_exits.simplify_exits
-    |> _d "simplify_lets"
+    |> d "simplify_lets"
     |> (fun lam ->
-        if !Js_config.diagnose then
+        if debug_ir then
           Ext_log.dwarn ~__POS__ "Before coercion: %a@." Lam_stats.print meta;
         lam)
   in
@@ -216,19 +222,15 @@ let compile
   in 
 
 let () =
-  if !Js_config.diagnose then begin
+  if debug_ir then begin
     Ext_log.dwarn ~__POS__ "After coercion: %a@." Lam_stats.print meta;
-    let f =
-      Ext_filename.new_extension !Location.input_name  ".lambda" in
-    Ext_fmt.with_file_as_pp f begin fun fmt ->
-      Format.pp_print_list ~pp_sep:Format.pp_print_newline
-        Lam_group.pp_group  fmt (coerced_input.groups) 
-    end
+    Ext_option.iter diagnostics (fun diagnostics ->
+        Ir_diagnostics.dump_groups diagnostics coerced_input.groups)
   end
 in
 let maybe_pure = no_side_effects groups in
 let () =
-  if !Js_config.diagnose then
+  if debug_ir then
     Ext_log.dwarn ~__POS__ "\n@[[TIME:]Pre-compile: %f@]@."
       (Sys.time () *. 1000.)
 in
@@ -238,7 +240,7 @@ let body  =
   |> Js_output.output_as_block
 in
 let () =
-  if !Js_config.diagnose then
+  if debug_ir then
     Ext_log.dwarn ~__POS__ "\n@[[TIME:]Post-compile: %f@]@."
       (Sys.time () *. 1000.)
 in
@@ -253,22 +255,22 @@ let js : J.program =
     block = body}
 in
 js 
-|> _j "initial"
+|> j "initial"
 |> Js_pass_flatten.program
-|> _j "flatten"
+|> j "flatten"
 |> Js_pass_external_shadow.program
-|> _j "external_shadow"
+|> j "external_shadow"
 |> Js_pass_tailcall_inline.tailcall_inline
-|> _j "inline_and_shake"
+|> j "inline_and_shake"
 |> Js_pass_record_rest.program
-|> _j "record_rest"
+|> j "record_rest"
 |> Js_pass_flatten_and_mark_dead.program
-|> _j "flatten_and_mark_dead"
+|> j "flatten_and_mark_dead"
 (* |> Js_inline_and_eliminate.inline_and_shake *)
-(* |> _j "inline_and_shake" *)
+(* |> j "inline_and_shake" *)
 |> (fun js -> ignore @@ Js_pass_scope.program  js ; js )
 |> Js_shake.shake_program
-|> _j "shake"
+|> j "shake"
 |> ( fun (program:  J.program) -> 
     let external_module_ids : Lam_module_ident.t list = 
       if !Js_config.all_module_aliases then []