More invariant checks

Author: hhugo

compiler/lib/lambda_lifting.ml

@@ -225,15 +225,16 @@ let rec traverse var_depth (program, functions) pc depth limit =
     program.blocks
     (program, functions)
 
-let f program =
+let f p =
   let t = Timer.make () in
   let nv = Var.count () in
   let var_depth = Array.make nv (-1) in
-  let program, functions =
+  let p, functions =
     let threshold = Config.Param.lambda_lifting_threshold () in
     let baseline = Config.Param.lambda_lifting_baseline () in
-    traverse var_depth (program, []) program.start 0 (baseline + threshold)
+    traverse var_depth (p, []) p.start 0 (baseline + threshold)
   in
   assert (List.is_empty functions);
   if Debug.find "times" () then Format.eprintf "  lambda lifting: %a@." Timer.print t;
-  program
+  Code.invariant p;
+  p

compiler/lib/specialize_js.ml

@@ -448,7 +448,9 @@ let f_once_before p =
   let blocks =
     Addr.Map.map (fun block -> { block with Code.body = loop [] block.body }) p.blocks
   in
-  { p with blocks }
+  let p = { p with blocks } in
+  Code.invariant p;
+  p
 
 let rec args_equal xs ys =
   match xs, ys with
@@ -485,11 +487,13 @@ let f_once_after p =
     | i -> i
   in
   if first_class_primitives
-  then
+  then (
     let blocks =
       Addr.Map.map
         (fun block -> { block with Code.body = List.map block.body ~f })
         p.blocks
     in
-    Deadcode.remove_unused_blocks { p with blocks }
+    let p = Deadcode.remove_unused_blocks { p with blocks } in
+    Code.invariant p;
+    p)
   else p

dune

@@ -2,13 +2,18 @@
  (dev
   (flags
    (:standard -w +a-4-40-41-42-44-48-58-66-70))
+  (js_of_ocaml
+   (flags
+    (:include ci.flags)
+    (:standard)))
   (binaries
    (tools/node_wrapper.exe as node)
    (tools/node_wrapper.exe as node.exe)))
  (with-effects
   (js_of_ocaml
    (compilation_mode separate)
    (flags
+    (:include ci.flags)
     (:standard --effects cps)))
   (wasm_of_ocaml
    (compilation_mode separate)
@@ -21,6 +26,7 @@
   (js_of_ocaml
    (compilation_mode separate)
    (flags
+    (:include ci.flags)
     (:standard --effects double-translation))
    (build_runtime_flags
     (:standard --effects double-translation)))
@@ -55,6 +61,23 @@
     %{dep:VERSION}
     %{dep:tools/version/GIT-VERSION}))))
 
+(rule
+ (target ci.flags)
+ (enabled_if
+  (not %{env:CI=false}))
+ (action
+  (with-stdout-to
+   %{target}
+   (echo "()"))))
+
+(rule
+ (target ci.flags)
+ (enabled_if %{env:CI=false})
+ (action
+  (with-stdout-to
+   %{target}
+   (echo "(--debug invariant)"))))
+
 (data_only_dirs _wikidoc doc-dev janestreet)
 
 (vendored_dirs)