WIP

Author: hhugo

compiler/lib/deadcode.ml

@@ -49,6 +49,8 @@ type t =
   ; mutable deleted_instrs : int
   ; mutable deleted_blocks : int
   ; mutable deleted_params : int
+  ; mutable block_shortcut : int
+  ; mutable cond_to_branch : int
   }
 
 (****)
@@ -185,10 +187,27 @@ let annot st pc xi =
 
 (****)
 
-let remove_unused_blocks p =
+let remove_unused_blocks' p =
   let visited = Code.mark_unused_blocks p in
-  { p with blocks = Addr.Map.filter (fun pc _ -> BitSet.mem visited pc) p.blocks }
+  let count = ref 0 in
+  let blocks =
+    Addr.Map.filter
+      (fun pc _ ->
+        match BitSet.mem visited pc with
+        | true -> true
+        | false ->
+            incr count;
+            false)
+      p.blocks
+  in
+  { p with blocks }, !count
 
+let remove_unused_blocks p =
+  let t = Timer.make () in
+  let p, count = remove_unused_blocks' p in
+  if times () then Format.eprintf "  dead block elim.: %a@." Timer.print t;
+  if stats () then Format.eprintf "Stats - dead block: %d unused blocks@." count;
+  p, count
 (****)
 
 let rec add_arg_dep defs params args =
@@ -209,24 +228,24 @@ let empty_body b =
   | [] | [ Event _ ] -> true
   | _ -> false
 
-let remove_empty_blocks ~live_vars (p : Code.program) : Code.program =
-  let previous_p = p in
-  let t = Timer.make () in
-  let count = ref 0 in
+let remove_empty_blocks st (p : Code.program) : Code.program =
   let shortcuts = Hashtbl.create 16 in
   let rec resolve_rec visited ((pc, args) as cont) =
     if Addr.Set.mem pc visited
     then cont
     else
       match Hashtbl.find_opt shortcuts pc with
       | Some (params, cont) ->
-          incr count;
           let pc', args' = resolve_rec (Addr.Set.add pc visited) cont in
           let s = Subst.from_map (Subst.build_mapping params args) in
           pc', List.map ~f:s args'
       | None -> cont
   in
-  let resolve cont = resolve_rec Addr.Set.empty cont in
+  let resolve cont =
+    let cont' = resolve_rec Addr.Set.empty cont in
+    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
@@ -241,7 +260,7 @@ let remove_empty_blocks ~live_vars (p : Code.program) : Code.program =
              used as argument to the continuation *)
           if
             List.for_all
-              ~f:(fun x -> live_vars.(Var.idx x) = 1 && Var.Set.mem x args)
+              ~f:(fun x -> st.live.(Var.idx x) = 1 && Var.Set.mem x args)
               params
           then Hashtbl.add shortcuts pc (params, cont)
       | _ -> ())
@@ -258,20 +277,19 @@ let remove_empty_blocks ~live_vars (p : Code.program) : Code.program =
                  let cont1' = resolve cont1 in
                  let cont2' = resolve cont2 in
                  if Code.cont_equal cont1' cont2'
-                 then Branch cont1'
-                 else Cond (x, resolve cont1, resolve cont2)
+                 then (
+                   st.cond_to_branch <- st.cond_to_branch + 1;
+                   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 -> branch)
         })
       p.blocks
   in
-  let p = remove_unused_blocks { p with blocks } in
-  if times () then Format.eprintf "  dead code elim. empty blocks: %a@." Timer.print t;
-  if stats () then Format.eprintf "Stats - dead code empty blocks: %d@." !count;
-  if debug_stats ()
-  then Code.check_updates ~name:"emptyblock" previous_p p ~updates:!count;
+  let p, deleted_blocks = remove_unused_blocks' { p with blocks } in
+  st.deleted_blocks <- deleted_blocks;
   p
 
 let f ({ blocks; _ } as p : Code.program) =
@@ -310,53 +328,60 @@ let f ({ blocks; _ } as p : Code.program) =
     ; deleted_instrs = 0
     ; deleted_blocks = 0
     ; deleted_params = 0
+    ; block_shortcut = 0
+    ; cond_to_branch = 0
     }
   in
   mark_reachable st p.start;
   if debug () then Print.program Format.err_formatter (fun pc xi -> annot st pc xi) p;
   let all_blocks = blocks in
   let blocks =
-    Addr.Map.filter_map
+    Addr.Map.mapi
       (fun pc block ->
         if not (BitSet.mem st.reachable_blocks pc)
-        then (
-          st.deleted_blocks <- st.deleted_blocks + 1;
-          None)
+        then block
         else
-          Some
-            { params = List.filter block.params ~f:(fun x -> st.live.(Var.idx x) > 0)
-            ; body =
-                List.fold_left block.body ~init:[] ~f:(fun acc i ->
-                    match i, acc with
-                    | Event _, Event _ :: prev ->
-                        (* Avoid consecutive events (keep just the last one) *)
-                        i :: prev
-                    | _ ->
-                        if live_instr st i
-                        then filter_closure all_blocks st i :: acc
-                        else (
-                          st.deleted_instrs <- st.deleted_instrs + 1;
-                          acc))
-                |> List.rev
-            ; branch = filter_live_last all_blocks st block.branch
-            })
+          { params = List.filter block.params ~f:(fun x -> st.live.(Var.idx x) > 0)
+          ; body =
+              List.fold_left block.body ~init:[] ~f:(fun acc i ->
+                  match i, acc with
+                  | Event _, Event _ :: prev ->
+                      (* Avoid consecutive events (keep just the last one) *)
+                      i :: prev
+                  | _ ->
+                      if live_instr st i
+                      then filter_closure all_blocks st i :: acc
+                      else (
+                        st.deleted_instrs <- st.deleted_instrs + 1;
+                        acc))
+              |> List.rev
+          ; branch = filter_live_last all_blocks st block.branch
+          })
       blocks
   in
   let p = { p with blocks } in
-  let p = remove_empty_blocks ~live_vars:st.live p in
+  let p = remove_empty_blocks st p in
   if times () then Format.eprintf "  dead code elim.: %a@." Timer.print t;
   if stats ()
   then
     Format.eprintf
-      "Stats - dead code: deleted %d instructions, %d blocks, %d parameters@."
+      "Stats - dead code: deleted %d instructions, %d blocks, %d parameters, %d \
+       branches, %d conds@."
       st.deleted_instrs
       st.deleted_blocks
-      st.deleted_params;
+      st.deleted_params
+      st.block_shortcut
+      st.cond_to_branch;
   if debug_stats ()
   then
     Code.check_updates
       ~name:"deadcode"
       previous_p
       p
-      ~updates:(st.deleted_instrs + st.deleted_blocks + st.deleted_params);
+      ~updates:
+        (st.deleted_instrs
+        + st.deleted_blocks
+        + st.deleted_params
+        + st.block_shortcut
+        + st.cond_to_branch);
   p, st.live

compiler/lib/deadcode.mli

@@ -23,4 +23,4 @@ type variable_uses =
 
 val f : Code.program -> Code.program * variable_uses
 
-val remove_unused_blocks : Code.program -> Code.program
+val remove_unused_blocks : Code.program -> Code.program * int

compiler/lib/driver.ml

@@ -142,16 +142,19 @@ let print p =
   if debug () then Code.Print.program Format.err_formatter (fun _ _ -> "") p;
   p
 
+let stats = Debug.find "stats"
+
 let rec loop max name round i (p : 'a) : 'a =
-  if times () then Format.eprintf "%s#%d...@." name i;
+  let debug = times () || stats () in
+  if debug then Format.eprintf "%s#%d...@." name i;
   let p' = round p in
   if i >= max
   then (
-    if times () then Format.eprintf "%s#%d: couldn't reach fix point.@." name i;
+    if debug then Format.eprintf "%s#%d: couldn't reach fix point.@." name i;
     p')
   else if Code.equal p' p
   then (
-    if times () then Format.eprintf "%s#%d: fix-point reached.@." name i;
+    if debug then Format.eprintf "%s#%d: fix-point reached.@." name i;
     p')
   else loop max name round (i + 1) p'
 

compiler/lib/eval.ml

@@ -791,7 +791,6 @@ let f info p =
       p.blocks
   in
   let blocks = drop_exception_handler drop_count blocks in
-  let p = Deadcode.remove_unused_blocks { p with blocks } in
   if times () then Format.eprintf "  eval: %a@." Timer.print t;
   if stats ()
   then
@@ -802,11 +801,13 @@ let f info p =
       !inline_constant
       !drop_count
       !update_branch;
+  let p, deadblock = Deadcode.remove_unused_blocks { p with blocks } in
   if debug_stats ()
   then
     Code.check_updates
       ~name:"eval"
       previous_p
       p
-      ~updates:(!update_count + !inline_constant + !drop_count + !update_branch);
+      ~updates:
+        (deadblock + !update_count + !inline_constant + !drop_count + !update_branch);
   p

compiler/lib/inline.ml

@@ -341,10 +341,10 @@ let f p live_vars =
       (closures, p)
   in
   (* Inlining a raising function can result in empty blocks *)
-  let p = Deadcode.remove_unused_blocks p in
   if times () then Format.eprintf "  inlining: %a@." Timer.print t;
   if stats () then Format.eprintf "Stats - inline: %d optimizations@." !inline_count;
+  let p, deadblock = Deadcode.remove_unused_blocks p in
   if debug_stats ()
-  then Code.check_updates ~name:"inline" previous_p p ~updates:!inline_count;
+  then Code.check_updates ~name:"inline" previous_p p ~updates:(!inline_count + deadblock);
   Code.invariant p;
   p

compiler/lib/specialize_js.ml

@@ -475,5 +475,5 @@ let f_once_after p =
         (fun block -> { block with Code.body = List.map block.body ~f })
         p.blocks
     in
-    Deadcode.remove_unused_blocks { p with blocks }
+    fst (Deadcode.remove_unused_blocks { p with blocks })
   else p

dune-workspace

@@ -7,5 +7,5 @@
    (runtest_alias runtest-wasm))
   (js_of_ocaml
 ;; enable for debugging
-;; (flags (:standard --debug stats-debug))
+;; (flags (:standard --debug stats-debug --debug invariant))
    (runtest_alias runtest-js))))