Number unboxing

CHANGES.md

@@ -2,6 +2,7 @@
 
 ## Features/Changes
 * Compiler: exit-loop-early in more cases (#2077)
+* Compiler/wasm: omit code pointer from closures when not used (#2059)
 
 # 6.1.1 (2025-07-07) - Lille
 

compiler/lib-wasm/call_graph_analysis.ml

@@ -0,0 +1,63 @@
+open! Stdlib
+open Code
+
+let debug = Debug.find "call-graph"
+
+let times = Debug.find "times"
+
+let block_deps ~info ~non_escaping ~ambiguous ~blocks pc =
+  let block = Addr.Map.find pc blocks in
+  List.iter block.body ~f:(fun i ->
+      match i with
+      | Let (_, Apply { f; _ }) -> (
+          try
+            match Var.Tbl.get info.Global_flow.info_approximation f with
+            | Top -> ()
+            | Values { known; others } ->
+                if others || Var.Set.cardinal known > 1
+                then Var.Set.iter (fun x -> Var.Hashtbl.replace ambiguous x ()) known;
+                if debug ()
+                then
+                  Format.eprintf
+                    "CALL others:%b known:%d@."
+                    others
+                    (Var.Set.cardinal known)
+          with Invalid_argument _ -> ())
+      | Let (x, Closure _) -> (
+          match Var.Tbl.get info.Global_flow.info_approximation x with
+          | Top -> ()
+          | Values { known; others } ->
+              if Var.Set.cardinal known = 1 && (not others) && Var.Set.mem x known
+              then (
+                let may_escape = Var.ISet.mem info.Global_flow.info_may_escape x in
+                if debug () then Format.eprintf "CLOSURE may-escape:%b@." may_escape;
+                if not may_escape then Var.Hashtbl.replace non_escaping x ()))
+      | Let (_, (Prim _ | Block _ | Constant _ | Field _ | Special _))
+      | Event _ | Assign _ | Set_field _ | Offset_ref _ | Array_set _ -> ())
+
+type t = { unambiguous_non_escaping : unit Var.Hashtbl.t }
+
+let direct_calls_only info f =
+  Config.Flag.optcall () && Var.Hashtbl.mem info.unambiguous_non_escaping f
+
+let f p info =
+  let t = Timer.make () in
+  let non_escaping = Var.Hashtbl.create 128 in
+  let ambiguous = Var.Hashtbl.create 128 in
+  fold_closures
+    p
+    (fun _ _ (pc, _) _ () ->
+      traverse
+        { fold = Code.fold_children }
+        (fun pc () -> block_deps ~info ~non_escaping ~ambiguous ~blocks:p.blocks pc)
+        pc
+        p.blocks
+        ())
+    ();
+  if debug ()
+  then Format.eprintf "SUMMARY non-escaping:%d" (Var.Hashtbl.length non_escaping);
+  Var.Hashtbl.iter (fun x () -> Var.Hashtbl.remove non_escaping x) ambiguous;
+  if debug ()
+  then Format.eprintf " unambiguous-non-escaping:%d@." (Var.Hashtbl.length non_escaping);
+  if times () then Format.eprintf "  call graph analysis: %a@." Timer.print t;
+  { unambiguous_non_escaping = non_escaping }

compiler/lib-wasm/call_graph_analysis.mli

@@ -0,0 +1,5 @@
+type t
+
+val direct_calls_only : t -> Code.Var.t -> bool
+
+val f : Code.program -> Global_flow.info -> t

compiler/lib-wasm/curry.ml

@@ -293,14 +293,7 @@ module Make (Target : Target_sig.S) = struct
         (fun ~typ closure ->
           let* l = expression_list load l in
           call ?typ ~cps:true ~arity closure l)
-        (let* args =
-           (* We don't need the deadcode sentinal when the tag is 0 *)
-           Memory.allocate
-             ~tag:0
-             ~deadcode_sentinal:(Code.Var.fresh ())
-             ~load
-             (List.map ~f:(fun x -> `Var x) (List.tl l))
-         in
+        (let* args = Memory.allocate ~tag:0 (expression_list load (List.tl l)) in
          let* make_iterator =
            register_import ~name:"caml_apply_continuation" (Fun (Type.primitive_type 1))
          in