Make Lambda invariant checking explicit

CHANGELOG.md

@@ -33,6 +33,8 @@
 
 #### :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
+
 # 13.0.0-alpha.5
 
 #### :boom: Breaking Change

analysis/dune

@@ -1,16 +1,9 @@
 (dirs bin src reactive reanalyze vendor)
 
 (env
- (dev
-  (env-vars
-   (CPPO_FLAGS -U=RELEASE)))
  (release
-  (env-vars
-   (CPPO_FLAGS -D=RELEASE))
   (ocamlopt_flags
    (:standard -O3 -unbox-closures)))
  (static
-  (env-vars
-   (CPPO_FLAGS -D=RELEASE))
   (ocamlopt_flags
    (:standard -O3 -unbox-closures))))

compiler/bsc/rescript_compiler_main.ml

@@ -410,6 +410,9 @@ let command_line_flags : (string * Bsc_args.spec * string) array =
       clear Js_config.cross_module_inline,
       "*internal* Disable cross module inlining(experimental)" );
     ("-bs-diagnose", set Js_config.diagnose, "*internal* More verbose output");
+    ( "-check-lam",
+      set Js_config.check_lam,
+      "*internal* Check Lam invariants after optimization passes" );
     ( "-bs-no-check-div-by-zero",
       clear Js_config.check_div_by_zero,
       "*internal* unsafe mode, don't check div by zero and mod by zero" );

compiler/common/js_config.ml

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

compiler/common/js_config.mli

@@ -52,6 +52,9 @@ val cross_module_inline : bool ref
 val diagnose : bool ref
 (** diagnose option *)
 
+val check_lam : bool ref
+(** check Lam invariants after optimization passes *)
+
 val no_builtin_ppx : bool ref
 (** options for builtin ppx *)
 

compiler/core/js_pass_debug.cppo.ml

@@ -26,26 +26,13 @@
 
 
 
-#if (defined BROWSER || defined RELEASE)
-let dump _ (prog : J.program) = 
-  prog
-#else
 let log_counter = ref 0 
 
 let dump name (prog : J.program) =
-  begin
-    let () = 
-      if !Js_config.diagnose
-      then 
-        begin
-          incr log_counter ; 
-          Ext_log.dwarn ~__POS__ "\n@[[TIME:]%s: %f@]@." name (Sys.time () *. 1000.);          
-          Ext_pervasives.with_file_as_chan       
-            (Ext_filename.new_extension !Location.input_name
-               (Printf.sprintf ".%02d.%s.jsx"  !log_counter name)
-            ) (fun chan -> Js_dump_program.dump_program prog chan )
-        end in
-    prog    
-  end
-#endif
-
+  incr log_counter;
+  Ext_log.dwarn ~__POS__ "\n@[[TIME:]%s: %f@]@." name (Sys.time () *. 1000.);
+  Ext_pervasives.with_file_as_chan
+    (Ext_filename.new_extension !Location.input_name
+       (Printf.sprintf ".%02d.%s.jsx" !log_counter name))
+    (fun chan -> Js_dump_program.dump_program prog chan);
+  prog

compiler/core/lam_check.ml

@@ -27,19 +27,21 @@
    1. variables are not bound twice
    2. all variables are of right scope
 *)
-let check file lam =
+let check ~file ~pass lam =
   let defined_variables = Hash_set_ident.create 1000 in
   let success = ref true in
   let use (id : Ident.t) =
     if not @@ Hash_set_ident.mem defined_variables id then (
       Format.fprintf Format.err_formatter
-        "\n[SANITY]:%s/%d used before defined in %s@." id.name id.stamp file;
+        "\n[SANITY after %s]:%s/%d used before defined in %s@." pass id.name
+        id.stamp file;
       success := false)
   in
   let def (id : Ident.t) =
     if Hash_set_ident.mem defined_variables id then (
-      Format.fprintf Format.err_formatter "\n[SANITY]:%s/%d bound twice in %s@."
-        id.name id.stamp file;
+      Format.fprintf Format.err_formatter
+        "\n[SANITY after %s]:%s/%d bound twice in %s@." pass id.name id.stamp
+        file;
       success := false)
     else Hash_set_ident.add defined_variables id
   in
@@ -84,7 +86,8 @@ let check file lam =
       Ext_option.iter default (fun x -> check_staticfails x cxt)
     | Lstaticraise (i, args) ->
       if Set_int.mem cxt i then check_list args cxt
-      else failwith ("exit " ^ string_of_int i ^ " unbound")
+      else
+        failwith (Printf.sprintf "exit %d unbound after %s in %s" i pass file)
     | Lstaticcatch (e1, (j, _vars), e2) ->
       check_staticfails e1 (Set_int.add cxt j);
       check_staticfails e2 cxt

compiler/core/lam_check.mli

@@ -22,4 +22,4 @@
  * along with this program; if not, write to the Free Software
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
 
-val check : string -> Lam.t -> Lam.t
+val check : file:string -> pass:string -> Lam.t -> Lam.t

compiler/core/lam_compile_main.cppo.ml

@@ -116,16 +116,20 @@ let no_side_effects (rest : Lam_group.t list) : string option =
         else None (* TODO :*))
 
 
-let _d  = fun  s lam -> 
-#ifndef RELEASE
-    Lam_util.dump  s lam ;
-  Ext_log.dwarn ~__POS__ "START CHECKING PASS %s@." s;
-  ignore @@ Lam_check.check !Location.input_name lam;
-  Ext_log.dwarn ~__POS__ "FINISH CHECKING PASS %s@." s;
-#endif
+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 = Js_pass_debug.dump 
+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 
@@ -136,13 +140,13 @@ let compile
     (lam : Lambda.lambda)  = 
   let export_ident_sets = Set_ident.of_list export_idents in 
   (* To make toplevel happy - reentrant for js-demo *)
-  let () = 
-#ifndef RELEASE
+  let () =
+    if !Js_config.diagnose then begin
       Ext_list.iter export_idents 
-      (fun id -> Ext_log.dwarn ~__POS__ "export idents: %s/%d"  id.name id.stamp) ;
-#endif      
-    Lam_compile_env.reset () ;
-  in 
+        (fun id -> Ext_log.dwarn ~__POS__ "export idents: %s/%d" id.name id.stamp)
+    end;
+    Lam_compile_env.reset ()
+  in
   let lam, may_required_modules = Lam_convert.convert export_ident_sets lam in 
 
 
@@ -160,12 +164,12 @@ let compile
       |> _d "flattern1"
       |>  Lam_pass_exits.simplify_exits
       |> _d "simplyf_exits"
-      |> (fun lam -> Lam_pass_collect.collect_info meta lam; 
-#ifndef RELEASE      
-      let () = 
-        Ext_log.dwarn ~__POS__ "Before simplify_alias: %a@." Lam_stats.print meta in       
-#endif      
-      lam)
+      |> (fun lam ->
+          Lam_pass_collect.collect_info meta lam;
+          if !Js_config.diagnose then
+            Ext_log.dwarn ~__POS__ "Before simplify_alias: %a@." Lam_stats.print
+              meta;
+          lam)
       |>  Lam_pass_remove_alias.simplify_alias  meta
       |> _d "simplify_alias"
       |> Lam_pass_deep_flatten.deep_flatten
@@ -201,43 +205,43 @@ let compile
        |> _d "scc" *)
     |> Lam_pass_exits.simplify_exits
     |> _d "simplify_lets"
-#ifndef RELEASE
-    |> (fun lam -> 
-        let () = 
-          Ext_log.dwarn ~__POS__ "Before coercion: %a@." Lam_stats.print meta in 
-        Lam_check.check !Location.input_name lam
-      ) 
-#endif    
+    |> (fun lam ->
+        if !Js_config.diagnose then
+          Ext_log.dwarn ~__POS__ "Before coercion: %a@." Lam_stats.print meta;
+        lam)
   in
 
   let ({Lam_coercion.groups = groups } as coerced_input , meta) = 
     Lam_coercion.coerce_and_group_big_lambda  meta lam
   in 
 
-#ifndef RELEASE
 let () =
-  Ext_log.dwarn ~__POS__ "After coercion: %a@." Lam_stats.print meta ;
-  if !Js_config.diagnose then
+  if !Js_config.diagnose 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;
+    end
+  end
 in
-#endif  
 let maybe_pure = no_side_effects groups in
-#ifndef RELEASE
-let () = Ext_log.dwarn ~__POS__ "\n@[[TIME:]Pre-compile: %f@]@."  (Sys.time () *. 1000.) in      
-#endif  
+let () =
+  if !Js_config.diagnose then
+    Ext_log.dwarn ~__POS__ "\n@[[TIME:]Pre-compile: %f@]@."
+      (Sys.time () *. 1000.)
+in
 let body  =     
   Ext_list.map groups (fun group -> compile_group output_prefix meta group)
   |> Js_output.concat
   |> Js_output.output_as_block
 in
-#ifndef RELEASE
-let () = Ext_log.dwarn ~__POS__ "\n@[[TIME:]Post-compile: %f@]@."  (Sys.time () *. 1000.) in      
-#endif    
+let () =
+  if !Js_config.diagnose then
+    Ext_log.dwarn ~__POS__ "\n@[[TIME:]Post-compile: %f@]@."
+      (Sys.time () *. 1000.)
+in
 (* The file is not big at all compared with [cmo] *)
 (* Ext_marshal.to_file (Ext_path.chop_extension filename ^ ".mj")  js; *)
 let meta_exports = meta.exports in 

compiler/core/lam_util.cppo.ml

@@ -231,25 +231,14 @@ let field_flatten_get
   | Some _
   | None -> lam ()
 
-#if (defined BROWSER || defined RELEASE)
-let dump ext  lam = 
-  ()
-#else
 let log_counter = ref 0
 let dump ext  lam = 
-  if !Js_config.diagnose
-  then 
-    (* ATTENTION: easy to introduce a bug during refactoring when forgeting `begin` `end`*)
-    begin 
-      incr log_counter;
-      Ext_log.dwarn ~__POS__ "\n@[[TIME:]%s: %f@]@." ext (Sys.time () *. 1000.);
-      Lam_print.serialize  
-        (Ext_filename.new_extension
-           !Location.input_name
-           (Printf.sprintf ".%02d%s.lam" !log_counter ext)
-        ) lam;
-    end
-#endif      
+  incr log_counter;
+  Ext_log.dwarn ~__POS__ "\n@[[TIME:]%s: %f@]@." ext (Sys.time () *. 1000.);
+  Lam_print.serialize
+    (Ext_filename.new_extension !Location.input_name
+       (Printf.sprintf ".%02d%s.lam" !log_counter ext))
+    lam
 
 
 

compiler/dune

@@ -12,21 +12,21 @@
  syntax)
 
 (env
- (dev
-  (env-vars
-   (CPPO_FLAGS -U=RELEASE)))
  (release
   (env-vars
-   (CPPO_FLAGS -D=RELEASE))
+   (CPPO_FLAGS -U=BROWSER))
   (ocamlopt_flags
    (:standard -O3 -unbox-closures)))
  (static
   (env-vars
-   (CPPO_FLAGS -D=RELEASE))
+   (CPPO_FLAGS -U=BROWSER))
   (ocamlopt_flags
    (:standard -O3 -unbox-closures)))
  (browser
   (env-vars
    (CPPO_FLAGS -D=BROWSER))
   (ocamlopt_flags
-   (:standard -O3 -unbox-closures))))
+   (:standard -O3 -unbox-closures)))
+ (_
+  (env-vars
+   (CPPO_FLAGS -U=BROWSER))))

tests/tests/rescript.json

@@ -13,6 +13,7 @@
   },
   "dependencies": ["@rescript/react"],
   "compiler-flags": [
+    "-check-lam",
     "-w -3-6-26-27-29-30-32..40-44-45-52-60-9-106+104",
     "-warn-error A"
   ]