Simplify nested conditionals

When a conditional is simplified, it might be possible to simply
previous conditionals as well. Do this in one pass.

Author: vouillon

compiler/lib/deadcode.ml

@@ -349,28 +349,29 @@ let remove_empty_blocks st (p : Code.program) : Code.program =
     if not (Code.cont_equal cont cont') then st.block_shortcut <- st.block_shortcut + 1;
     cont'
   in
-  Addr.Map.iter
-    (fun pc block ->
-      match block with
-      | { params; body; branch = Branch cont; _ } when empty_body body ->
-          let args =
-            List.fold_left
-              ~f:(fun args x -> Var.Set.add x args)
-              ~init:Var.Set.empty
-              (snd cont)
-          in
-          (* We can skip an empty block if its parameters are only
+  let register_block_if_empty pc block =
+    match block with
+    | { params; body; branch = Branch cont; _ } when empty_body body ->
+        let args =
+          List.fold_left
+            ~f:(fun args x -> Var.Set.add x args)
+            ~init:Var.Set.empty
+            (snd cont)
+        in
+        (* We can skip an empty block if its parameters are only
              used as argument to the continuation *)
-          if
-            List.for_all
-              ~f:(fun x -> st.live.(Var.idx x) = 1 && Var.Set.mem x args)
-              params
-          then Addr.Hashtbl.add shortcuts pc (params, cont)
-      | _ -> ())
-    p.blocks;
+        if List.for_all ~f:(fun x -> st.live.(Var.idx x) = 1 && Var.Set.mem x args) params
+        then Addr.Hashtbl.add shortcuts pc (params, cont)
+    | _ -> ()
+  in
+  Addr.Map.iter register_block_if_empty p.blocks;
+  let addr_map_rev_fold f m acc =
+    let l = Addr.Map.fold (fun pc block rem -> (pc, block) :: rem) m [] in
+    List.fold_left ~f l ~init:acc
+  in
   let blocks =
-    Addr.Map.fold
-      (fun pc block blocks ->
+    addr_map_rev_fold
+      (fun blocks (pc, block) ->
         if
           match block.branch with
           | Branch (pc, _) | Poptrap (pc, _) -> not (Addr.Hashtbl.mem shortcuts pc)
@@ -383,22 +384,47 @@ let remove_empty_blocks st (p : Code.program) : Code.program =
         else
           Addr.Map.add
             pc
-            { block with
-              branch =
-                (let branch = block.branch in
-                 match branch with
-                 | Branch cont -> Branch (resolve cont)
-                 | Cond (x, cont1, cont2) ->
-                     let cont1' = resolve cont1 in
-                     let cont2' = resolve cont2 in
-                     if Code.cont_equal cont1' cont2'
-                     then Branch cont1'
-                     else Cond (x, cont1', cont2')
-                 | Switch (x, a1) -> Switch (x, Array.map ~f:resolve a1)
-                 | Pushtrap (cont1, x, cont2) -> Pushtrap (resolve cont1, x, resolve cont2)
-                 | Poptrap cont -> Poptrap (resolve cont)
-                 | Return _ | Raise _ | Stop -> assert false)
-            }
+            (match block with
+            | { body; branch = Cond (x, cont1, cont2); _ } ->
+                let cont1' = resolve cont1 in
+                let cont2' = resolve cont2 in
+                if Code.cont_equal cont1' cont2'
+                then (
+                  let decr_usage x = st.live.(Var.idx x) <- st.live.(Var.idx x) - 1 in
+                  decr_usage x;
+                  let body =
+                    if List.compare_length_with body ~len:100 > 0
+                    then body
+                    else
+                      List.fold_right
+                        ~f:(fun i rem ->
+                          if live_instr st i
+                          then
+                            match i, rem with
+                            | Event _, Event _ :: _ -> rem
+                            | _ -> i :: rem
+                          else (
+                            Freevars.iter_instr_free_vars decr_usage i;
+                            rem))
+                        block.body
+                        ~init:[]
+                  in
+                  let block = { block with body; branch = Branch cont1' } in
+                  register_block_if_empty pc block;
+                  block)
+                else { block with branch = Cond (x, cont1', cont2') }
+            | _ ->
+                { block with
+                  branch =
+                    (let branch = block.branch in
+                     match branch with
+                     | Branch cont -> Branch (resolve cont)
+                     | Switch (x, a1) -> Switch (x, Array.map ~f:resolve a1)
+                     | Pushtrap (cont1, x, cont2) ->
+                         Pushtrap (resolve cont1, x, resolve cont2)
+                     | Poptrap cont -> Poptrap (resolve cont)
+                     | Cond _ | Return _ | Raise _ | Stop -> assert false)
+                })
             blocks)
       p.blocks
       p.blocks