Fix method lookup cache with separate compilation

hhugo · hhugo · commit e14ca862efd2 · 2025-06-12T10:21:09.000+02:00
diff --git a/CHANGES.md b/CHANGES.md
@@ -59,7 +59,7 @@
 * Runtime: fix caml_string_concat when not using JS strings (#1874)
 * Runtime: consistent bigarray hashing across all architectures (#1977)
 * Runtime: fix caml_utf8_of_utf16 bug in high surrogate case (#2008)
-* Runtime/wasm: fix method lookup (#2034, #2038)
+* Runtime/wasm/js: fix method lookup (#2034, #2038, #2039)
 * Tools: fix jsoo_mktop and jsoo_mkcmis (#1877)
 * Toplevel: fix for when use-js-strings is disabled (#1997)
 
diff --git a/compiler/lib/parse_bytecode.ml b/compiler/lib/parse_bytecode.ml
@@ -532,6 +532,7 @@ type globals =
   ; mutable is_const : bool array
   ; mutable is_exported : bool array
   ; mutable named_value : string option array
+  ; mutable cache_ids : Var.t list
   ; constants : Code.constant array
   ; primitives : string array
   }
@@ -541,6 +542,7 @@ let make_globals size constants primitives =
   ; is_const = Array.make size false
   ; is_exported = Array.make size false
   ; named_value = Array.make size None
+  ; cache_ids = []
   ; constants
   ; primitives
   }
@@ -818,8 +820,6 @@ let tagged_blocks = ref Addr.Map.empty
 
 let compiled_blocks : (_ * instr list * last) Addr.Map.t ref = ref Addr.Map.empty
 
-let method_cache_id = ref 1
-
 let clo_offset_3 = 3
 
 type compile_info =
@@ -2353,24 +2353,20 @@ and compile infos pc state (instrs : instr list) =
           (Let (x, Prim (Ult, [ Pv z; Pv y ])) :: instrs)
     | GETPUBMET ->
         let n = gets32 code (pc + 1) in
-        let cache = !method_cache_id in
-        incr method_cache_id;
         let obj = State.accu state in
         let state = State.push state in
-        let tag, state = State.fresh_var state in
+        let cache_id = Var.fresh_n "cache_id" in
+        state.globals.cache_ids <- cache_id :: state.globals.cache_ids;
         let m, state = State.fresh_var state in
-
-        if debug_parser () then Format.printf "%a = %ld@." Var.print tag n;
         if debug_parser ()
         then
           Format.printf
-            "%a = caml_get_public_method(%a, %a)@."
+            "%a = caml_get_public_method(%a, %ld)@."
             Var.print
             m
             Var.print
             obj
-            Var.print
-            tag;
+            n;
         compile
           infos
           (pc + 3)
@@ -2379,8 +2375,7 @@ and compile infos pc state (instrs : instr list) =
              ( m
              , Prim
                  ( Extern "caml_get_public_method"
-                 , [ Pv obj; Pv tag; Pc (Int (Targetint.of_int_exn cache)) ] ) )
-          :: Let (tag, const32 n)
+                 , [ Pv obj; Pc (Int (Targetint.of_int32_exn n)); Pv cache_id ] ) )
           :: instrs)
     | GETDYNMET ->
         let tag = State.accu state in
@@ -2390,7 +2385,7 @@ and compile infos pc state (instrs : instr list) =
         if debug_parser ()
         then
           Format.printf
-            "%a = caml_get_public_method(%a, %a)@."
+            "%a = caml_get_dyn_method(%a, %a)@."
             Var.print
             m
             Var.print
@@ -2401,12 +2396,7 @@ and compile infos pc state (instrs : instr list) =
           infos
           (pc + 1)
           state
-          (Let
-             ( m
-             , Prim
-                 ( Extern "caml_get_public_method"
-                 , [ Pv obj; Pv tag; Pc (Int Targetint.zero) ] ) )
-          :: instrs)
+          (Let (m, Prim (Extern "caml_get_dyn_method", [ Pv obj; Pv tag ])) :: instrs)
     | GETMETHOD ->
         let lab = State.accu state in
         let obj = State.peek 0 state in
@@ -2537,7 +2527,12 @@ let parse_bytecode code globals debug_data =
   in
   compiled_blocks := Addr.Map.empty;
   tagged_blocks := Addr.Map.empty;
-  Code.compact p
+  let p = Code.compact p in
+  let body =
+    List.fold_left globals.cache_ids ~init:[] ~f:(fun body cache_id ->
+        Let (cache_id, Prim (Extern "caml_oo_cache_id", [])) :: body)
+  in
+  Code.prepend p body
 
 module Toc : sig
   type t
diff --git a/runtime/js/obj.js b/runtime/js/obj.js
@@ -142,19 +142,42 @@ function caml_lazy_make_forward(v) {
   return [250, v];
 }
 
+//Provides: caml_method_cache
+var caml_method_cache = [];
+
+//Provides: caml_oo_cache_id const
+//Requires: caml_method_cache
+function caml_oo_cache_id() {
+  var cacheid = caml_method_cache.length;
+  caml_method_cache[cacheid] = 0;
+  cacheid;
+}
+
 ///////////// CamlinternalOO
 //Provides: caml_get_public_method const
-var caml_method_cache = [];
+//Requires: caml_method_cache
 function caml_get_public_method(obj, tag, cacheid) {
   var meths = obj[1];
   var ofs = caml_method_cache[cacheid];
-  if (ofs === undefined) {
-    // Make sure the array is not sparse
-    for (var i = caml_method_cache.length; i < cacheid; i++)
-      caml_method_cache[i] = 0;
-  } else if (meths[ofs] === tag) {
-    return meths[ofs - 1];
+  if (meths[ofs + 4] === tag) {
+    return meths[ofs + 3];
+  }
+  var li = 3,
+    hi = meths[1] * 2 + 1,
+    mi;
+  while (li < hi) {
+    mi = ((li + hi) >> 1) | 1;
+    if (tag < meths[mi + 1]) hi = mi - 2;
+    else li = mi;
   }
+  caml_method_cache[cacheid] = li - 3;
+  /* return 0 if tag is not there */
+  return tag === meths[li + 1] ? meths[li] : 0;
+}
+
+//Provides: caml_get_dyn_method const
+function caml_get_dyn_method(obj, tag) {
+  var meths = obj[1];
   var li = 3,
     hi = meths[1] * 2 + 1,
     mi;
@@ -163,7 +186,6 @@ function caml_get_public_method(obj, tag, cacheid) {
     if (tag < meths[mi + 1]) hi = mi - 2;
     else li = mi;
   }
-  caml_method_cache[cacheid] = li + 1;
   /* return 0 if tag is not there */
   return tag === meths[li + 1] ? meths[li] : 0;
 }
diff --git a/runtime/wasm/obj.wat b/runtime/wasm/obj.wat
@@ -381,18 +381,15 @@
    (global $method_cache (mut (ref $int_array))
       (array.new $int_array (i32.const 4) (i32.const 8)))
 
-   (func (export "caml_get_public_method")
-      (param $obj (ref eq)) (param $vtag (ref eq)) (param (ref eq))
-      (result (ref eq))
-      (local $meths (ref $block))
-      (local $tag i32) (local $cacheid i32) (local $ofs i32)
-      (local $li i32) (local $mi i32) (local $hi i32)
-      (local $a (ref $int_array)) (local $len i32)
-      (local.set $meths
-         (ref.cast (ref $block)
-            (array.get $block
-               (ref.cast (ref $block) (local.get $obj)) (i32.const 1))))
-      (local.set $cacheid (i31.get_u (ref.cast (ref i31) (local.get 2))))
+
+   (global $caml_oo_cache_id_last (mut i32) (i32.const 0))
+
+   (func (export "caml_oo_cache_id") (result (ref eq))
+      (local $cacheid i32)
+      (local $a (ref $int_array))
+      (local $len i32)
+      (local.set $cacheid (global.get $caml_oo_cache_id_last))
+      (global.set $caml_oo_cache_id_last (i32.add (local.get $cacheid) (i32.const 1)))
       (local.set $len (array.len (global.get $method_cache)))
       (if (i32.ge_s (local.get $cacheid) (local.get $len))
          (then
@@ -405,6 +402,19 @@
                (global.get $method_cache) (i32.const 0)
                (array.len (global.get $method_cache)))
             (global.set $method_cache (local.get $a))))
+       (ref.i31 (local.get $cacheid)))
+
+   (func (export "caml_get_public_method")
+      (param $obj (ref eq)) (param $vtag (ref eq)) (param (ref eq))
+      (result (ref eq))
+      (local $meths (ref $block))
+      (local $tag i32) (local $cacheid i32) (local $ofs i32)
+      (local $li i32) (local $mi i32) (local $hi i32)
+      (local.set $meths
+         (ref.cast (ref $block)
+            (array.get $block
+               (ref.cast (ref $block) (local.get $obj)) (i32.const 1))))
+      (local.set $cacheid (i31.get_u (ref.cast (ref i31) (local.get 2))))
       (local.set $ofs
          (array.get $int_array (global.get $method_cache) (local.get $cacheid)))
       (if (i32.lt_u (local.get $ofs) (array.len (local.get $meths)))
@@ -456,6 +466,54 @@
          (else
             (ref.i31 (i32.const 0)))))
 
+   (func (export "caml_get_dyn_method")
+      (param $obj (ref eq)) (param $vtag (ref eq))
+      (result (ref eq))
+      (local $meths (ref $block))
+      (local $tag i32) (local $ofs i32)
+      (local $li i32) (local $mi i32) (local $hi i32)
+      (local.set $meths
+         (ref.cast (ref $block)
+            (array.get $block
+               (ref.cast (ref $block) (local.get $obj)) (i32.const 1))))
+      (local.set $tag (i31.get_s (ref.cast (ref i31) (local.get $vtag))))
+      (local.set $li (i32.const 3))
+      (local.set $hi
+         (i32.add
+            (i32.shl
+               (i31.get_u
+                  (ref.cast (ref i31)
+                     (array.get $block (local.get $meths) (i32.const 1))))
+               (i32.const 1))
+            (i32.const 1)))
+      (loop $loop
+         (if (i32.lt_u (local.get $li) (local.get $hi))
+            (then
+               (local.set $mi
+                  (i32.or (i32.shr_u (i32.add (local.get $li) (local.get $hi))
+                                     (i32.const 1))
+                          (i32.const 1)))
+               (if (i32.lt_s
+                      (local.get $tag)
+                      (i31.get_s
+                         (ref.cast (ref i31)
+                            (array.get $block
+                               (local.get $meths)
+                               (i32.add (local.get $mi) (i32.const 1))))))
+                  (then
+                     (local.set $hi (i32.sub (local.get $mi) (i32.const 2))))
+                  (else
+                     (local.set $li (local.get $mi))))
+               (br $loop))))
+      (if (result (ref eq))
+          (ref.eq (local.get $vtag)
+             (array.get $block (local.get $meths)
+                (i32.add (local.get $li) (i32.const 1))))
+         (then
+            (array.get $block (local.get $meths) (local.get $li)))
+         (else
+            (ref.i31 (i32.const 0)))))
+
    (global $caml_oo_last_id (mut i32) (i32.const 0))
 
    (func (export "caml_set_oo_id") (param (ref eq)) (result (ref eq))
