diff --git a/compiler/lib/code.ml b/compiler/lib/code.ml
index a4455ffd7a..6bce84ed58 100644
--- a/compiler/lib/code.ml
+++ b/compiler/lib/code.ml
@@ -890,15 +890,15 @@ let return_values p =
           Var.Map.add name s rets)
     Var.Map.empty
 
+let block_equal b1 b2 =
+  phys_equal b1 b2
+  || List.equal ~eq:Var.equal b1.params b2.params
+     && Poly.equal b1.branch b2.branch
+     && List.equal ~eq:Poly.equal b1.body b2.body
+
 let equal p1 p2 =
   p1.start = p2.start
-  && Addr.Map.equal
-       (fun { params; body; branch } b ->
-         List.equal ~eq:Var.equal params b.params
-         && Poly.equal branch b.branch
-         && List.equal ~eq:Poly.equal body b.body)
-       p1.blocks
-       p2.blocks
+  && (phys_equal p1.blocks p2.blocks || Addr.Map.equal block_equal p1.blocks p2.blocks)
 
 let print_to_file p =
   let file = Filename.temp_file "jsoo" "prog" in
@@ -934,6 +934,25 @@ let check_updates ~name p1 p2 ~updates =
       print_diff p1 p2;
       assert false
 
+let print_block_sharing ~name p1 p2 =
+  let shared = ref 0 in
+  let updated = ref 0 in
+  Addr.Map.iter
+    (fun pc b2 ->
+      match Addr.Map.find_opt pc p1.blocks with
+      | Some b1 when phys_equal b1 b2 -> incr shared
+      | Some _ -> incr updated
+      | None -> incr updated)
+    p2.blocks;
+  let removed = Addr.Map.cardinal p1.blocks - !shared - !updated in
+  Format.eprintf
+    "Stats - %s sharing: %d/%d blocks shared, %d updated, %d removed@."
+    name
+    !shared
+    (Addr.Map.cardinal p2.blocks)
+    !updated
+    removed
+
 let cont_equal (pc, args) (pc', args') = pc = pc' && List.equal ~eq:Var.equal args args'
 
 let cont_compare (pc, args) (pc', args') =
@@ -942,6 +961,23 @@ let cont_compare (pc, args) (pc', args') =
 
 let with_invariant = Debug.find "invariant"
 
+let assert_block_equal ~name b_old b_new =
+  if with_invariant ()
+  then
+    if not (block_equal b_old b_new)
+    then (
+      Format.eprintf "ASSERT_BLOCK_EQUAL: %s: counter=0 but block differs.@." name;
+      assert false)
+
+let assert_program_equal ~name p_old p_new =
+  if with_invariant ()
+  then
+    if not (equal p_old p_new)
+    then (
+      Format.eprintf "ASSERT_PROGRAM_EQUAL: %s: counter=0 but program differs.@." name;
+      print_diff p_old p_new;
+      assert false)
+
 let do_compact { blocks; start; free_pc = _ } =
   let remap =
     let max = fst (Addr.Map.max_binding blocks) in
diff --git a/compiler/lib/code.mli b/compiler/lib/code.mli
index b5680dad81..a4828cfac4 100644
--- a/compiler/lib/code.mli
+++ b/compiler/lib/code.mli
@@ -315,14 +315,22 @@ val compact : program -> program
 
 val is_empty : program -> bool
 
+val block_equal : block -> block -> bool
+
 val equal : program -> program -> bool
 
 val print_diff : program -> program -> unit
 
 val check_updates : name:string -> program -> program -> updates:int -> unit
 
+val print_block_sharing : name:string -> program -> program -> unit
+
 val invariant : program -> unit
 
+val assert_block_equal : name:string -> block -> block -> unit
+
+val assert_program_equal : name:string -> program -> program -> unit
+
 val cont_equal : cont -> cont -> bool
 
 val cont_compare : cont -> cont -> int
diff --git a/compiler/lib/deadcode.ml b/compiler/lib/deadcode.ml
index fe6dec7bc6..0f06f93ee2 100644
--- a/compiler/lib/deadcode.ml
+++ b/compiler/lib/deadcode.ml
@@ -206,14 +206,17 @@ let remove_unused_blocks' p =
         b)
       p.blocks
   in
-  { p with blocks }, !count
+  if !count = 0 then p, 0 else { p with blocks }, !count
 
 let remove_unused_blocks p =
   let previous_p = p in
   let t = Timer.make () in
   let p, count = remove_unused_blocks' p in
   if times () then Format.eprintf "  dead block: %a@." Timer.print t;
-  if stats () then Format.eprintf "Stats - dead block: deleted %d@." count;
+  if stats ()
+  then (
+    Format.eprintf "Stats - dead block: deleted %d@." count;
+    Code.print_block_sharing ~name:"dead block" previous_p p);
   if debug_stats () then Code.check_updates ~name:"dead block" previous_p p ~updates:count;
   p
 
@@ -326,7 +329,10 @@ let merge_blocks p =
       Subst.Excluding_Binders.program rename p
   in
   if times () then Format.eprintf "  merge block: %a@." Timer.print t;
-  if stats () then Format.eprintf "Stats - merge block: merged %d@." !merged;
+  if stats ()
+  then (
+    Format.eprintf "Stats - merge block: merged %d@." !merged;
+    Code.print_block_sharing ~name:"merge block" previous_p p);
   if debug_stats ()
   then Code.check_updates ~name:"merge block" previous_p p ~updates:!merged;
   p
@@ -480,31 +486,58 @@ let f pure_funs ({ blocks; _ } as p : Code.program) =
             st.deleted_blocks <- st.deleted_blocks + 1;
             None)
           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
-              })
+            let saved_instrs = st.deleted_instrs in
+            let saved_params = st.deleted_params in
+            let params_changed =
+              List.exists block.params ~f:(fun x -> st.live.(Var.idx x) = 0)
+            in
+            let params =
+              if params_changed
+              then List.filter block.params ~f:(fun x -> st.live.(Var.idx x) > 0)
+              else block.params
+            in
+            let 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
+            in
+            let branch = filter_live_last all_blocks st block.branch in
+            if
+              (not params_changed)
+              && st.deleted_instrs = saved_instrs
+              && st.deleted_params = saved_params
+            then (
+              Code.assert_block_equal ~name:"deadcode" block { params; body; branch };
+              Some block)
+            else Some { params; body; branch })
         blocks
     in
-    { p with blocks }
+    if st.deleted_instrs + st.deleted_blocks + st.deleted_params = 0
+    then (
+      Code.assert_program_equal ~name:"deadcode(filter)" p { p with blocks };
+      p)
+    else { p with blocks }
+  in
+  let p =
+    let p' = remove_empty_blocks st p in
+    if st.block_shortcut = 0
+    then (
+      Code.assert_program_equal ~name:"deadcode(shortcut)" p p';
+      p)
+    else 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
+  then (
     Format.eprintf
       "Stats - dead code: deleted %d instructions, %d blocks, %d parameters, %d \
        branches@."
@@ -512,6 +545,7 @@ let f pure_funs ({ blocks; _ } as p : Code.program) =
       st.deleted_blocks
       st.deleted_params
       st.block_shortcut;
+    Code.print_block_sharing ~name:"deadcode" previous_p p);
   if debug_stats ()
   then
     Code.check_updates
diff --git a/compiler/lib/driver.ml b/compiler/lib/driver.ml
index b6b8b1c96b..7ecea10ed8 100644
--- a/compiler/lib/driver.ml
+++ b/compiler/lib/driver.ml
@@ -219,17 +219,43 @@ let rec loop max name round i (p : 'a) : 'a =
   else if Code.equal p' p
   then (
     if debug then Format.eprintf "%s#%d: fix-point reached.@." name i;
+    if stats () then Code.print_block_sharing ~name:(Printf.sprintf "%s#%d" name i) p p';
     p')
-  else loop max name round (i + 1) p'
+  else (
+    if stats () then Code.print_block_sharing ~name:(Printf.sprintf "%s#%d" name i) p p';
+    loop max name round (i + 1) p')
+
+let cached () =
+  let all_cached = ref [] in
+  fun f ->
+    let last = ref None in
+    all_cached := last :: !all_cached;
+    fun p ->
+      match !last with
+      | Some (blocks, result) when phys_equal p.Code.blocks blocks -> result
+      | _ ->
+          let result = f p in
+          List.iter !all_cached ~f:(fun r -> r := None);
+          last := Some (p.blocks, result);
+          result
 
 let round profile : 'a -> 'a =
-  print
-  +> tailcall
-  +> Ref_unboxing.f
-  +> (flow +> specialize +> eval +> fst)
-  +> inline profile
-  +> phi
-  +> deadcode
+  let cached = cached () in
+  let tailcall = cached tailcall in
+  let ref_unboxing = cached Ref_unboxing.f in
+  let flow_specialize_eval = cached (flow +> specialize +> eval +> fst) in
+  let inline = cached (inline profile) in
+  let phi = cached phi in
+  let deadcode = cached deadcode in
+  fun p ->
+    p
+    |> print
+    |> tailcall
+    |> ref_unboxing
+    |> flow_specialize_eval
+    |> inline
+    |> phi
+    |> deadcode
 
 (* o1 *)
 
diff --git a/compiler/lib/eval.ml b/compiler/lib/eval.ml
index f243150e7f..a5440f26b2 100644
--- a/compiler/lib/eval.ml
+++ b/compiler/lib/eval.ml
@@ -827,15 +827,26 @@ let drop_exception_handler drop_count blocks =
     blocks
 
 let eval update_count update_branch inline_constant ~target info blocks =
-  Addr.Map.map
-    (fun block ->
+  Addr.Map.fold
+    (fun pc block blocks ->
+      let saved_update = !update_count in
+      let saved_branch = !update_branch in
+      let saved_inline = !inline_constant in
       let body =
         List.concat_map
           block.body
           ~f:(eval_instr update_count inline_constant ~target info)
       in
       let branch = eval_branch update_branch info block.branch in
-      { block with Code.body; Code.branch })
+      if
+        !update_count = saved_update
+        && !update_branch = saved_branch
+        && !inline_constant = saved_inline
+      then (
+        Code.assert_block_equal ~name:"eval" block { block with Code.body; Code.branch };
+        blocks)
+      else Addr.Map.add pc { block with Code.body; Code.branch } blocks)
+    blocks
     blocks
 
 let f info p =
@@ -856,10 +867,16 @@ let f info p =
       p.blocks
   in
   let blocks = drop_exception_handler drop_count blocks in
-  let p = { p with blocks } in
+  let p =
+    if !update_count + !update_branch + !inline_constant + !drop_count = 0
+    then (
+      Code.assert_program_equal ~name:"eval" p { p with blocks };
+      p)
+    else { p with blocks }
+  in
   if times () then Format.eprintf "  eval: %a@." Timer.print t;
   if stats ()
-  then
+  then (
     Format.eprintf
       "Stats - eval: %d optimizations, %d inlined cst, %d dropped exception handlers, %d \
        branch updated@."
@@ -867,6 +884,7 @@ let f info p =
       !inline_constant
       !drop_count
       !update_branch;
+    Code.print_block_sharing ~name:"eval" previous_p p);
   if debug_stats ()
   then
     Code.check_updates
diff --git a/compiler/lib/flow.ml b/compiler/lib/flow.ml
index 51e292870f..535d35da9b 100644
--- a/compiler/lib/flow.ml
+++ b/compiler/lib/flow.ml
@@ -673,6 +673,7 @@ let the_shape_of ~return_values ~pure ~blocks info =
 let build_subst (info : Info.t) vars =
   let nv = Var.count () in
   let subst = Array.init nv ~f:(fun i -> Var.of_idx i) in
+  let has_subst = ref false in
   Var.ISet.iter
     (fun x ->
       let x_idx = Var.idx x in
@@ -686,9 +687,13 @@ let build_subst (info : Info.t) vars =
          match direct_approx info x with
          | None -> ()
          | Some y -> subst.(x_idx) <- y);
-      if Var.equal subst.(x_idx) x then () else Var.propagate_name x subst.(x_idx))
+      if Var.equal subst.(x_idx) x
+      then ()
+      else (
+        has_subst := true;
+        Var.propagate_name x subst.(x_idx)))
     vars;
-  subst
+  if !has_subst then Some subst else None
 
 (****)
 
@@ -731,26 +736,42 @@ let f p =
     ; info_possibly_mutable = possibly_mutable
     }
   in
-  let s = build_subst info vars in
-  let need_stats = stats () || debug_stats () in
+  let stats_needed = stats () || debug_stats () in
   let count_uniq = ref 0 in
-  let count_seen = BitSet.create' (if need_stats then Var.count () else 0) in
-  let subst v1 =
-    let idx1 = Code.Var.idx v1 in
-    let v2 = s.(idx1) in
-    if Code.Var.equal v1 v2
-    then v1
-    else (
-      if need_stats && not (BitSet.mem count_seen idx1)
-      then (
-        incr count_uniq;
-        BitSet.set count_seen idx1);
-      v2)
+  let p =
+    match build_subst info vars with
+    | None -> p
+    | Some s ->
+        let subst =
+          if stats_needed
+          then
+            let count_seen = BitSet.create' (Var.count ()) in
+            fun v1 ->
+              let idx1 = Code.Var.idx v1 in
+              let v2 = s.(idx1) in
+              if Code.Var.equal v1 v2
+              then v1
+              else (
+                if not (BitSet.mem count_seen idx1)
+                then (
+                  incr count_uniq;
+                  BitSet.set count_seen idx1);
+                v2)
+          else fun v1 -> s.(Code.Var.idx v1)
+        in
+        let p' = Subst.Excluding_Binders.program subst p in
+        if phys_equal p.blocks p'.blocks
+        then (
+          Code.assert_program_equal ~name:"flow" p p';
+          p)
+        else p'
   in
-  let p = Subst.Excluding_Binders.program subst p in
   if times () then Format.eprintf "    flow analysis 5: %a@." Timer.print t5;
   if times () then Format.eprintf "  flow analysis: %a@." Timer.print t;
-  if stats () then Format.eprintf "Stats - flow updates: %d@." !count_uniq;
+  if stats ()
+  then (
+    Format.eprintf "Stats - flow updates: %d@." !count_uniq;
+    Code.print_block_sharing ~name:"flow" previous_p p);
   if debug_stats () then Code.check_updates ~name:"flow" previous_p p ~updates:!count_uniq;
   Code.invariant p;
   p, info
diff --git a/compiler/lib/global_deadcode.ml b/compiler/lib/global_deadcode.ml
index 33b5e0843a..530801b374 100644
--- a/compiler/lib/global_deadcode.ml
+++ b/compiler/lib/global_deadcode.ml
@@ -441,6 +441,7 @@ let solver vars uses defs live_vars scoped_live_vars =
     + They are applied to a function.
  *)
 let zero prog pure_funs sentinel live_table =
+  let count = ref 0 in
   let compact_vars vars =
     let i = ref (Array.length vars - 1) in
     while !i >= 0 && Var.equal vars.(!i) sentinel do
@@ -453,7 +454,13 @@ let zero prog pure_funs sentinel live_table =
     | Domain.Dead -> false
     | Top | Live _ -> true
   in
-  let zero_var x = if is_live x then x else sentinel in
+  let zero_var x =
+    if is_live x
+    then x
+    else (
+      incr count;
+      sentinel)
+  in
   let zero_instr instr =
     match instr with
     | Let (x, e) -> (
@@ -463,7 +470,12 @@ let zero prog pure_funs sentinel live_table =
             | Live fields ->
                 let vars =
                   Array.mapi
-                    ~f:(fun i v -> if IntMap.mem i fields then v else sentinel)
+                    ~f:(fun i v ->
+                      if IntMap.mem i fields
+                      then v
+                      else (
+                        incr count;
+                        sentinel))
                     vars
                   |> compact_vars
                 in
@@ -509,7 +521,15 @@ let zero prog pure_funs sentinel live_table =
     in
     { block with body; branch }
   in
-  let blocks = prog.blocks |> Addr.Map.map zero_block in
+  let blocks =
+    Addr.Map.fold
+      (fun pc block blocks ->
+        let saved = !count in
+        let block' = zero_block block in
+        if !count = saved then blocks else Addr.Map.add pc block' blocks)
+      prog.blocks
+      prog.blocks
+  in
   { prog with blocks }
 
 module Print = struct
diff --git a/compiler/lib/inline.ml b/compiler/lib/inline.ml
index 6da3837a9f..a8798d284e 100644
--- a/compiler/lib/inline.ml
+++ b/compiler/lib/inline.ml
@@ -505,7 +505,7 @@ let trace_inlining ~context info x args =
    with an initial continuation pointing to a block belonging to
    another function. This removes these closures. *)
 
-let remove_dead_closures_from_block ~live_vars p pc block =
+let remove_dead_closures_from_block ~dead_closure_count ~live_vars p pc block =
   let is_dead_closure i =
     match i with
     | Let (f, Closure _) ->
@@ -514,7 +514,8 @@ let remove_dead_closures_from_block ~live_vars p pc block =
     | _ -> false
   in
   if List.exists ~f:is_dead_closure block.body
-  then
+  then (
+    incr dead_closure_count;
     { p with
       blocks =
         Addr.Map.add
@@ -530,15 +531,15 @@ let remove_dead_closures_from_block ~live_vars p pc block =
               |> List.rev
           }
           p.blocks
-    }
+    })
   else p
 
-let remove_dead_closures ~live_vars p pc =
+let remove_dead_closures ~dead_closure_count ~live_vars p pc =
   Code.traverse
     { fold = fold_children }
     (fun pc p ->
       let block = Addr.Map.find pc p.blocks in
-      remove_dead_closures_from_block ~live_vars p pc block)
+      remove_dead_closures_from_block ~dead_closure_count ~live_vars p pc block)
     pc
     p.blocks
     p
@@ -676,7 +677,7 @@ let inline_in_block ~context pc block p =
   in
   { p with blocks = Addr.Map.add pc { block with body; branch } p.blocks }
 
-let inline ~profile ~inline_count p ~live_vars =
+let inline ~profile ~inline_count ~dead_closure_count p ~live_vars =
   if debug () then Format.eprintf "====== inlining ======@.";
   (visit_closures
      p
@@ -719,7 +720,7 @@ let inline ~profile ~inline_count p ~live_vars =
            p.blocks
            p
        in
-       let p = remove_dead_closures ~live_vars p pc in
+       let p = remove_dead_closures ~dead_closure_count ~live_vars p pc in
        let env =
          match current_function with
          | Some f ->
@@ -759,13 +760,32 @@ let inline ~profile ~inline_count p ~live_vars =
 let f ~profile p live_vars =
   let previous_p = p in
   let inline_count = ref 0 in
+  let dead_closure_count = ref 0 in
   Code.invariant p;
   let t = Timer.make () in
-  let p = inline ~profile ~inline_count p ~live_vars in
+  let p =
+    let p' = inline ~profile ~inline_count ~dead_closure_count p ~live_vars in
+    if !inline_count + !dead_closure_count = 0
+    then (
+      Code.assert_program_equal ~name:"inline" p p';
+      p)
+    else p'
+  in
   if times () then Format.eprintf "  inlining: %a@." Timer.print t;
-  if stats () then Format.eprintf "Stats - inlining: %d inlined functions@." !inline_count;
+  if stats ()
+  then (
+    Format.eprintf
+      "Stats - inlining: %d inlined functions, %d dead closures@."
+      !inline_count
+      !dead_closure_count;
+    Code.print_block_sharing ~name:"inline" previous_p p);
   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 + !dead_closure_count);
   let p = Deadcode.remove_unused_blocks p in
   Code.invariant p;
   p
diff --git a/compiler/lib/phisimpl.ml b/compiler/lib/phisimpl.ml
index a11b6de70d..b6d3f40771 100644
--- a/compiler/lib/phisimpl.ml
+++ b/compiler/lib/phisimpl.ml
@@ -148,10 +148,16 @@ let solver1 vars deps defs =
     { G.domain = vars; G.iter_children = (fun f x -> Var.Set.iter f deps.(Var.idx x)) }
   in
   ignore (Solver1.f () g (propagate1 deps defs reprs));
-  Array.mapi reprs ~f:(fun idx y ->
-      match y with
-      | Some y -> repr reprs y
-      | None -> Var.of_idx idx)
+  let has_subst = ref false in
+  let subst =
+    Array.mapi reprs ~f:(fun idx y ->
+        match y with
+        | Some y ->
+            has_subst := true;
+            repr reprs y
+        | None -> Var.of_idx idx)
+  in
+  if !has_subst then Some subst else None
 
 let f p =
   let previous_p = p in
@@ -161,28 +167,46 @@ let f p =
   let vars, deps, defs = program_deps p in
   if times () then Format.eprintf "    phi-simpl. 1: %a@." Timer.print t';
   let t' = Timer.make () in
-  let subst = solver1 vars deps defs in
-  if times () then Format.eprintf "    phi-simpl. 2: %a@." Timer.print t';
-  Array.iteri subst ~f:(fun idx y ->
-      if Var.idx y = idx then () else Code.Var.propagate_name (Var.of_idx idx) y);
-  let need_stats = stats () || debug_stats () in
+  let stats_needed = stats () || debug_stats () in
   let count_uniq = ref 0 in
-  let count_seen = BitSet.create' (if need_stats then Var.count () else 0) in
-  let subst v1 =
-    let idx1 = Code.Var.idx v1 in
-    let v2 = subst.(idx1) in
-    if Code.Var.equal v1 v2
-    then v1
-    else (
-      if need_stats && not (BitSet.mem count_seen idx1)
-      then (
-        incr count_uniq;
-        BitSet.set count_seen idx1);
-      v2)
+  let p =
+    match solver1 vars deps defs with
+    | None ->
+        if times () then Format.eprintf "    phi-simpl. 2: %a@." Timer.print t';
+        p
+    | Some subst ->
+        if times () then Format.eprintf "    phi-simpl. 2: %a@." Timer.print t';
+        Array.iteri subst ~f:(fun idx y ->
+            if Var.idx y = idx then () else Code.Var.propagate_name (Var.of_idx idx) y);
+        let subst =
+          if stats_needed
+          then
+            let count_seen = BitSet.create' (Var.count ()) in
+            fun v1 ->
+              let idx1 = Code.Var.idx v1 in
+              let v2 = subst.(idx1) in
+              if Code.Var.equal v1 v2
+              then v1
+              else (
+                if not (BitSet.mem count_seen idx1)
+                then (
+                  incr count_uniq;
+                  BitSet.set count_seen idx1);
+                v2)
+          else fun v1 -> subst.(Code.Var.idx v1)
+        in
+        let p' = Subst.Excluding_Binders.program subst p in
+        if phys_equal p.blocks p'.blocks
+        then (
+          Code.assert_program_equal ~name:"phi" p p';
+          p)
+        else p'
   in
-  let p = Subst.Excluding_Binders.program subst p in
   if times () then Format.eprintf "  phi-simpl.: %a@." Timer.print t;
-  if stats () then Format.eprintf "Stats - phi updates: %d@." !count_uniq;
+  if stats ()
+  then (
+    Format.eprintf "Stats - phi updates: %d@." !count_uniq;
+    Code.print_block_sharing ~name:"phi" previous_p p);
   if debug_stats () then Code.check_updates ~name:"phi" previous_p p ~updates:!count_uniq;
   Code.invariant p;
   p
diff --git a/compiler/lib/ref_unboxing.ml b/compiler/lib/ref_unboxing.ml
index 38040a671b..5433b2ea71 100644
--- a/compiler/lib/ref_unboxing.ml
+++ b/compiler/lib/ref_unboxing.ml
@@ -37,6 +37,8 @@ let times = Debug.find "times"
 
 let stats = Debug.find "stats"
 
+let debug_stats = Debug.find "stats-debug"
+
 let rewrite_body unboxed_refs body ref_contents subst =
   let ref_contents, subst, l =
     List.fold_left
@@ -138,6 +140,7 @@ let rewrite_function p ~unboxed_refs pc subst =
   { p with blocks }, subst
 
 let f p =
+  let previous_p = p in
   let t = Timer.make () in
   let candidates = Var.Hashtbl.create 128 in
   let updated = Var.Hashtbl.create 128 in
@@ -225,6 +228,10 @@ let f p =
     else Subst.Excluding_Binders.program (Subst.from_map subst) p
   in
   if times () then Format.eprintf "  reference unboxing: %a@." Timer.print t;
+  let updates = Var.Hashtbl.length candidates in
   if stats ()
-  then Format.eprintf "Stats - reference unboxing: %d@." (Var.Hashtbl.length candidates);
+  then (
+    Format.eprintf "Stats - reference unboxing: %d@." updates;
+    Code.print_block_sharing ~name:"ref_unboxing" previous_p p);
+  if debug_stats () then Code.check_updates ~name:"ref_unboxing" previous_p p ~updates;
   p
diff --git a/compiler/lib/specialize.ml b/compiler/lib/specialize.ml
index 8c5cabd812..af3d760bfe 100644
--- a/compiler/lib/specialize.ml
+++ b/compiler/lib/specialize.ml
@@ -121,11 +121,20 @@ let f ~shape ~set_shape ~update_def p =
   let opt_count = ref 0 in
   let p =
     if Config.Flag.optcall ()
-    then specialize_instrs ~shape ~set_shape ~update_def opt_count p
+    then
+      let p' = specialize_instrs ~shape ~set_shape ~update_def opt_count p in
+      if !opt_count = 0
+      then (
+        Code.assert_program_equal ~name:"optcall" p p';
+        p)
+      else p'
     else p
   in
   if times () then Format.eprintf "  optcall: %a@." Timer.print t;
-  if stats () then Format.eprintf "Stats - optcall: %d@." !opt_count;
+  if stats ()
+  then (
+    Format.eprintf "Stats - optcall: %d@." !opt_count;
+    Code.print_block_sharing ~name:"optcall" previous_p p);
   if debug_stats ()
   then Code.check_updates ~name:"optcall" previous_p p ~updates:!opt_count;
   Code.invariant p;
@@ -301,71 +310,78 @@ let switches p =
   let previous_p = p in
   let t = Timer.make () in
   let opt_count = ref 0 in
+  let blocks =
+    Addr.Map.fold
+      (fun pc block blocks ->
+        match block.branch with
+        | Switch (x, l) -> (
+            match find_outlier_index l with
+            | #switch_to_cond as opt ->
+                incr opt_count;
+                let block = optimize_switch_to_cond block x l opt in
+                Addr.Map.add pc block blocks
+            | `Many_cases ->
+                let t = SBT.create 0 in
+                let rewrite = ref Addr.Set.empty in
+                let l =
+                  Array.map l ~f:(fun ((pc, _) as cont) ->
+                      let block = Code.Addr.Map.find pc blocks in
+                      if List.compare_length_with block.body ~len:7 <= 0
+                      then (
+                        let sb = Simple_block.make block in
+                        match SBT.find_opt t sb with
+                        | Some cont' when not (equal cont' cont) ->
+                            rewrite := Addr.Set.add (fst cont') !rewrite;
+                            cont'
+                        | Some _ | None ->
+                            SBT.add t sb cont;
+                            cont)
+                      else cont)
+                in
+                if not (Addr.Set.is_empty !rewrite)
+                then (
+                  incr opt_count;
+                  let blocks =
+                    Addr.Set.fold
+                      (fun pc blocks ->
+                        let block = Code.Addr.Map.find pc blocks in
+                        Addr.Map.add
+                          pc
+                          { block with
+                            body =
+                              List.filter
+                                ~f:(function
+                                  | Event _ -> false
+                                  | _ -> true)
+                                block.body
+                          }
+                          blocks)
+                      !rewrite
+                      blocks
+                  in
+                  match find_outlier_index l with
+                  | #switch_to_cond as opt ->
+                      let block = optimize_switch_to_cond block x l opt in
+                      Addr.Map.add pc block blocks
+                  | `Many_cases ->
+                      Addr.Map.add pc { block with branch = Switch (x, l) } blocks)
+                else blocks)
+        | _ -> blocks)
+      p.blocks
+      p.blocks
+  in
   let p =
-    { p with
-      blocks =
-        Addr.Map.fold
-          (fun pc block blocks ->
-            match block.branch with
-            | Switch (x, l) -> (
-                match find_outlier_index l with
-                | #switch_to_cond as opt ->
-                    incr opt_count;
-                    let block = optimize_switch_to_cond block x l opt in
-                    Addr.Map.add pc block blocks
-                | `Many_cases ->
-                    let t = SBT.create 0 in
-                    let rewrite = ref Addr.Set.empty in
-                    let l =
-                      Array.map l ~f:(fun ((pc, _) as cont) ->
-                          let block = Code.Addr.Map.find pc blocks in
-                          if List.compare_length_with block.body ~len:7 <= 0
-                          then (
-                            let sb = Simple_block.make block in
-                            match SBT.find_opt t sb with
-                            | Some cont' when not (equal cont' cont) ->
-                                rewrite := Addr.Set.add (fst cont') !rewrite;
-                                cont'
-                            | Some _ | None ->
-                                SBT.add t sb cont;
-                                cont)
-                          else cont)
-                    in
-                    if not (Addr.Set.is_empty !rewrite)
-                    then (
-                      incr opt_count;
-                      let blocks =
-                        Addr.Set.fold
-                          (fun pc blocks ->
-                            let block = Code.Addr.Map.find pc blocks in
-                            Addr.Map.add
-                              pc
-                              { block with
-                                body =
-                                  List.filter
-                                    ~f:(function
-                                      | Event _ -> false
-                                      | _ -> true)
-                                    block.body
-                              }
-                              blocks)
-                          !rewrite
-                          blocks
-                      in
-                      match find_outlier_index l with
-                      | #switch_to_cond as opt ->
-                          let block = optimize_switch_to_cond block x l opt in
-                          Addr.Map.add pc block blocks
-                      | `Many_cases ->
-                          Addr.Map.add pc { block with branch = Switch (x, l) } blocks)
-                    else blocks)
-            | _ -> blocks)
-          p.blocks
-          p.blocks
-    }
+    if !opt_count = 0
+    then (
+      Code.assert_program_equal ~name:"switches" p { p with blocks };
+      p)
+    else { p with blocks }
   in
   if times () then Format.eprintf "  switches: %a@." Timer.print t;
-  if stats () then Format.eprintf "Stats - switches: %d@." !opt_count;
+  if stats ()
+  then (
+    Format.eprintf "Stats - switches: %d@." !opt_count;
+    Code.print_block_sharing ~name:"switches" previous_p p);
   if debug_stats ()
   then Code.check_updates ~name:"switches" previous_p p ~updates:!opt_count;
   Deadcode.remove_unused_blocks p
diff --git a/compiler/lib/specialize_js.ml b/compiler/lib/specialize_js.ml
index 15b94ecca4..f101cd19e4 100644
--- a/compiler/lib/specialize_js.ml
+++ b/compiler/lib/specialize_js.ml
@@ -191,6 +191,7 @@ let specialize_instr opt_count ~target info i =
   | Let (x, Prim (Extern "caml_jsoo_runtime_value", [ nm ])), _ -> (
       match the_string_of info nm with
       | Some nm when Javascript.is_ident nm ->
+          incr opt_count;
           Let (x, Prim (Extern "caml_jsoo_runtime_value", [ Pc (String nm) ]))
       | _ -> i)
   | _, _ -> i
@@ -398,16 +399,22 @@ let specialize_instrs ~target opt_count info l =
 
 let specialize_all_instrs ~target opt_count info p =
   let blocks =
-    Addr.Map.map
-      (fun block ->
-        { block with
-          Code.body =
-            specialize_instrs
-              ~target
-              opt_count
-              info
-              (specialize_string_concat opt_count block.body)
-        })
+    Addr.Map.fold
+      (fun pc block blocks ->
+        let saved = !opt_count in
+        let body =
+          specialize_instrs
+            ~target
+            opt_count
+            info
+            (specialize_string_concat opt_count block.body)
+        in
+        if !opt_count = saved
+        then (
+          Code.assert_block_equal ~name:"specialize_js" block { block with Code.body };
+          blocks)
+        else Addr.Map.add pc { block with Code.body } blocks)
+      p.blocks
       p.blocks
   in
   { p with blocks }
@@ -419,15 +426,26 @@ let f info p =
   let previous_p = p in
   let t = Timer.make () in
   let opt_count = ref 0 in
-  let p = specialize_all_instrs ~target:(Config.target ()) opt_count info p in
+  let p' = specialize_all_instrs ~target:(Config.target ()) opt_count info p in
+  let p =
+    if !opt_count = 0
+    then (
+      Code.assert_program_equal ~name:"specialize_js" p p';
+      p)
+    else p'
+  in
   if times () then Format.eprintf "  specialize_js: %a@." Timer.print t;
-  if stats () then Format.eprintf "Stats - specialize_js: %d@." !opt_count;
+  if stats ()
+  then (
+    Format.eprintf "Stats - specialize_js: %d@." !opt_count;
+    Code.print_block_sharing ~name:"specialize_js" previous_p p);
   if debug_stats ()
   then Code.check_updates ~name:"specialize_js" previous_p p ~updates:!opt_count;
   Code.invariant p;
   p
 
 let f_once_before p =
+  let count = ref 0 in
   let rec loop acc l =
     match l with
     | [] -> List.rev acc
@@ -445,13 +463,20 @@ let f_once_before p =
                      | "caml_array_unsafe_set_float"
                      | "caml_floatarray_unsafe_set" )
                  , [ _; _; _ ] ) as p) ) ->
+            incr count;
             let x' = Code.Var.fork x in
             let acc = Let (x', p) :: Let (x, Constant (Int Targetint.zero)) :: acc in
             loop acc r
         | _ -> loop (i :: acc) r)
   in
   let blocks =
-    Addr.Map.map (fun block -> { block with Code.body = loop [] block.body }) p.blocks
+    Addr.Map.fold
+      (fun pc block blocks ->
+        let saved = !count in
+        let body = loop [] block.body in
+        if !count = saved then blocks else Addr.Map.add pc { block with Code.body } blocks)
+      p.blocks
+      p.blocks
   in
   let p = { p with blocks } in
   Code.invariant p;
@@ -470,6 +495,7 @@ let f_once_after p =
     | `JavaScript, (`Cps | `Double_translation) | `Wasm, _ -> false
     | `JavaScript, `Jspi -> assert false
   in
+  let count = ref 0 in
   let f = function
     | Let (x, Closure (l, (pc, []), _)) as i -> (
         let block = Addr.Map.find pc p.blocks in
@@ -486,7 +512,9 @@ let f_once_after p =
               Code.Var.compare y y' = 0
               && Primitive.has_arity prim len
               && args_equal l args
-            then Let (x, Special (Alias_prim prim))
+            then (
+              incr count;
+              Let (x, Special (Alias_prim prim)))
             else i
         | _ -> i)
     | i -> i
@@ -494,8 +522,14 @@ let f_once_after p =
   if first_class_primitives
   then (
     let blocks =
-      Addr.Map.map
-        (fun block -> { block with Code.body = List.map block.body ~f })
+      Addr.Map.fold
+        (fun pc block blocks ->
+          let saved = !count in
+          let body = List.map block.body ~f in
+          if !count = saved
+          then blocks
+          else Addr.Map.add pc { block with Code.body } blocks)
+        p.blocks
         p.blocks
     in
     let p = Deadcode.remove_unused_blocks { p with blocks } in
diff --git a/compiler/lib/subst.ml b/compiler/lib/subst.ml
index 0350a5e39b..5f9d20a121 100644
--- a/compiler/lib/subst.ml
+++ b/compiler/lib/subst.ml
@@ -67,7 +67,25 @@ module Excluding_Binders = struct
     { params = block.params; body = instrs s block.body; branch = last s block.branch }
 
   let program s p =
-    let blocks = Addr.Map.map (fun b -> block s b) p.blocks in
+    let count = ref 0 in
+    let s' x =
+      let y = s x in
+      if not (Code.Var.equal x y) then incr count;
+      y
+    in
+    let blocks =
+      Addr.Map.fold
+        (fun pc b blocks ->
+          let saved = !count in
+          let b' = block s' b in
+          if !count = saved
+          then (
+            Code.assert_block_equal ~name:"subst" b b';
+            blocks)
+          else Addr.Map.add pc b' blocks)
+        p.blocks
+        p.blocks
+    in
     { p with blocks }
 
   let rec cont' s pc blocks visited =
diff --git a/compiler/lib/tailcall.ml b/compiler/lib/tailcall.ml
index 3d62e1ad16..752c0cf32c 100644
--- a/compiler/lib/tailcall.ml
+++ b/compiler/lib/tailcall.ml
@@ -147,9 +147,21 @@ let f p =
       in
       if !rewrite_body then blocks := Addr.Map.add pc { block with body } !blocks)
     p.blocks;
-  let p = { p with blocks = !blocks; free_pc = !free_pc } in
+  let p =
+    if !update_count = 0
+    then (
+      Code.assert_program_equal
+        ~name:"tailcall"
+        p
+        { p with blocks = !blocks; free_pc = !free_pc };
+      p)
+    else { p with blocks = !blocks; free_pc = !free_pc }
+  in
   if times () then Format.eprintf "  tail calls: %a@." Timer.print t;
-  if stats () then Format.eprintf "Stats - tail calls: %d optimizations@." !update_count;
+  if stats ()
+  then (
+    Format.eprintf "Stats - tail calls: %d optimizations@." !update_count;
+    Code.print_block_sharing ~name:"tailcall" previous_p p);
   if debug_stats ()
   then Code.check_updates ~name:"tailcall" previous_p p ~updates:!update_count;
   Code.invariant p;