diff --git a/CHANGES.md b/CHANGES.md index cab802e21e..edc3c603e4 100644 --- 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/bin-js_of_ocaml/check_runtime.ml b/compiler/bin-js_of_ocaml/check_runtime.ml index 12ebf6cf4a..2501c30e6c 100644 --- a/compiler/bin-js_of_ocaml/check_runtime.ml +++ b/compiler/bin-js_of_ocaml/check_runtime.ml @@ -91,16 +91,30 @@ let f (runtime_files, bytecode, target_env) = in let needed = StringSet.of_list (List.map ~f:fst needed) in let needed = - (* this list was copied from parse_bytecode *) List.fold_left ~f:(fun acc x -> StringSet.remove x acc) ~init:needed - [ "caml_ensure_stack_capacity" + [ (* this list was copied from parse_bytecode *) + "caml_ensure_stack_capacity" ; "caml_process_pending_actions_with_root" ; "caml_make_array" ; "caml_array_of_uniform_array" ] in + let needed = + (* internal primitives *) + List.fold_left + ~f:(fun acc x -> StringSet.add x acc) + ~init:needed + [ "caml_register_global" + ; "caml_js_set" + ; "caml_js_get" + ; "caml_get_global_data" + ; "caml_oo_cache_id" + ; "caml_get_public_method" + ; "caml_get_cached_method" + ] + in let from_runtime1 = Linker.list_all () in let from_runtime2 = Primitive.get_external () in (* [from_runtime2] is a superset of [from_runtime1]. diff --git a/compiler/lib/parse_bytecode.ml b/compiler/lib/parse_bytecode.ml index 0ce79a4f6e..e6bb26b7cf 100644 --- 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_cached_method(%a, %ld)@." Var.print m Var.print obj - Var.print - tag; + n; compile infos (pc + 3) @@ -2378,9 +2374,8 @@ and compile infos pc state (instrs : instr list) = (Let ( m , Prim - ( Extern "caml_get_public_method" - , [ Pv obj; Pv tag; Pc (Int (Targetint.of_int_exn cache)) ] ) ) - :: Let (tag, const32 n) + ( Extern "caml_get_cached_method" + , [ Pv obj; Pc (Int (Targetint.of_int32_exn n)); Pv cache_id ] ) ) :: instrs) | GETDYNMET -> let tag = State.accu state in @@ -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_public_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/compiler/tests-check-prim/main.4.14.output b/compiler/tests-check-prim/main.4.14.output index cbfefa3a6f..ab33327cc1 100644 --- a/compiler/tests-check-prim/main.4.14.output +++ b/compiler/tests-check-prim/main.4.14.output @@ -116,11 +116,8 @@ caml_string_concat caml_to_js_string (deprecated) From +stdlib.js: -caml_build_symbols caml_is_printable caml_maybe_print_stats -caml_register_global -jsoo_toplevel_reloc From +sync.js: MlMutex diff --git a/compiler/tests-check-prim/main.5.2.output b/compiler/tests-check-prim/main.5.2.output index 6aff797f81..69114aeae7 100644 --- a/compiler/tests-check-prim/main.5.2.output +++ b/compiler/tests-check-prim/main.5.2.output @@ -118,11 +118,8 @@ caml_runtime_events_read_poll caml_runtime_events_user_resolve From +stdlib.js: -caml_build_symbols caml_is_printable caml_maybe_print_stats -caml_register_global -jsoo_toplevel_reloc From +sys.js: caml_fatal_uncaught_exception diff --git a/compiler/tests-check-prim/main.5.3.output b/compiler/tests-check-prim/main.5.3.output index 471517932a..1c15928731 100644 --- a/compiler/tests-check-prim/main.5.3.output +++ b/compiler/tests-check-prim/main.5.3.output @@ -117,11 +117,8 @@ caml_runtime_events_read_poll caml_runtime_events_user_resolve From +stdlib.js: -caml_build_symbols caml_is_printable caml_maybe_print_stats -caml_register_global -jsoo_toplevel_reloc From +sys.js: caml_fatal_uncaught_exception diff --git a/compiler/tests-check-prim/main.5.4.output b/compiler/tests-check-prim/main.5.4.output index ba68876cd2..cdf0e8e638 100644 --- a/compiler/tests-check-prim/main.5.4.output +++ b/compiler/tests-check-prim/main.5.4.output @@ -116,11 +116,8 @@ caml_runtime_events_read_poll caml_runtime_events_user_resolve From +stdlib.js: -caml_build_symbols caml_is_printable caml_maybe_print_stats -caml_register_global -jsoo_toplevel_reloc From +sys.js: caml_fatal_uncaught_exception diff --git a/compiler/tests-check-prim/unix-Unix.4.14.output b/compiler/tests-check-prim/unix-Unix.4.14.output index c6bbcdf91f..56edc949c1 100644 --- a/compiler/tests-check-prim/unix-Unix.4.14.output +++ b/compiler/tests-check-prim/unix-Unix.4.14.output @@ -192,11 +192,8 @@ caml_string_concat caml_to_js_string (deprecated) From +stdlib.js: -caml_build_symbols caml_is_printable caml_maybe_print_stats -caml_register_global -jsoo_toplevel_reloc From +sync.js: MlMutex diff --git a/compiler/tests-check-prim/unix-Unix.5.2.output b/compiler/tests-check-prim/unix-Unix.5.2.output index 6e1c8ba8e5..fa882e7115 100644 --- a/compiler/tests-check-prim/unix-Unix.5.2.output +++ b/compiler/tests-check-prim/unix-Unix.5.2.output @@ -194,11 +194,8 @@ caml_runtime_events_read_poll caml_runtime_events_user_resolve From +stdlib.js: -caml_build_symbols caml_is_printable caml_maybe_print_stats -caml_register_global -jsoo_toplevel_reloc From +sys.js: caml_fatal_uncaught_exception diff --git a/compiler/tests-check-prim/unix-Unix.5.3.output b/compiler/tests-check-prim/unix-Unix.5.3.output index df95281669..05731d98ef 100644 --- a/compiler/tests-check-prim/unix-Unix.5.3.output +++ b/compiler/tests-check-prim/unix-Unix.5.3.output @@ -193,11 +193,8 @@ caml_runtime_events_read_poll caml_runtime_events_user_resolve From +stdlib.js: -caml_build_symbols caml_is_printable caml_maybe_print_stats -caml_register_global -jsoo_toplevel_reloc From +sys.js: caml_fatal_uncaught_exception diff --git a/compiler/tests-check-prim/unix-Unix.5.4.output b/compiler/tests-check-prim/unix-Unix.5.4.output index 92dd7fd24e..b9602558b4 100644 --- a/compiler/tests-check-prim/unix-Unix.5.4.output +++ b/compiler/tests-check-prim/unix-Unix.5.4.output @@ -193,11 +193,8 @@ caml_runtime_events_read_poll caml_runtime_events_user_resolve From +stdlib.js: -caml_build_symbols caml_is_printable caml_maybe_print_stats -caml_register_global -jsoo_toplevel_reloc From +sys.js: caml_fatal_uncaught_exception diff --git a/compiler/tests-check-prim/unix-Win32.4.14.output b/compiler/tests-check-prim/unix-Win32.4.14.output index dd90ad4b34..d150e12345 100644 --- a/compiler/tests-check-prim/unix-Win32.4.14.output +++ b/compiler/tests-check-prim/unix-Win32.4.14.output @@ -164,11 +164,8 @@ caml_string_concat caml_to_js_string (deprecated) From +stdlib.js: -caml_build_symbols caml_is_printable caml_maybe_print_stats -caml_register_global -jsoo_toplevel_reloc From +sync.js: MlMutex diff --git a/compiler/tests-check-prim/unix-Win32.5.2.output b/compiler/tests-check-prim/unix-Win32.5.2.output index 2cf4eaf5ac..4ccf572bc5 100644 --- a/compiler/tests-check-prim/unix-Win32.5.2.output +++ b/compiler/tests-check-prim/unix-Win32.5.2.output @@ -167,11 +167,8 @@ caml_runtime_events_read_poll caml_runtime_events_user_resolve From +stdlib.js: -caml_build_symbols caml_is_printable caml_maybe_print_stats -caml_register_global -jsoo_toplevel_reloc From +sys.js: caml_fatal_uncaught_exception diff --git a/compiler/tests-check-prim/unix-Win32.5.3.output b/compiler/tests-check-prim/unix-Win32.5.3.output index 8fc788cc78..8497f5dacf 100644 --- a/compiler/tests-check-prim/unix-Win32.5.3.output +++ b/compiler/tests-check-prim/unix-Win32.5.3.output @@ -166,11 +166,8 @@ caml_runtime_events_read_poll caml_runtime_events_user_resolve From +stdlib.js: -caml_build_symbols caml_is_printable caml_maybe_print_stats -caml_register_global -jsoo_toplevel_reloc From +sys.js: caml_fatal_uncaught_exception diff --git a/compiler/tests-compiler/dune.inc b/compiler/tests-compiler/dune.inc index c5cc6d8aff..0d8a74e6c4 100644 --- a/compiler/tests-compiler/dune.inc +++ b/compiler/tests-compiler/dune.inc @@ -689,6 +689,21 @@ (preprocess (pps ppx_expect))) +(library + ;; compiler/tests-compiler/oo.ml + (name oo_15) + (enabled_if true) + (modules oo) + (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) + (inline_tests + (enabled_if true) + (deps + (file %{project_root}/compiler/bin-js_of_ocaml/js_of_ocaml.exe) + (file %{project_root}/compiler/bin-jsoo_minify/jsoo_minify.exe))) + (flags (:standard -open Jsoo_compiler_expect_tests_helper)) + (preprocess + (pps ppx_expect))) + (library ;; compiler/tests-compiler/rec.ml (name rec_15) diff --git a/compiler/tests-compiler/oo.ml b/compiler/tests-compiler/oo.ml new file mode 100644 index 0000000000..b0c5ec7396 --- /dev/null +++ b/compiler/tests-compiler/oo.ml @@ -0,0 +1,54 @@ +(* Js_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * Copyright (C) 2025 Hugo Heuzard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +let%expect_test _ = + let prog = + {| + + let f o = o#a + + let o1 = object + method a = print_endline "a from o1" + end + + let o2 = object + method b = () + method a = print_endline "a from o2" + end + + let () = f o1; f o2 +|} + in + Util.compile_and_run prog; + [%expect {| + a from o1 + a from o2 + |}]; + let program = Util.compile_and_parse prog in + Util.print_var_decl program "cache_id"; + Util.print_fun_decl program (Some "f"); + [%expect + {| + var cache_id = runtime.caml_oo_cache_id(); + //end + function f(o){ + return caml_call1(runtime.caml_get_cached_method(o, 97, cache_id), o); + } + //end + |}] diff --git a/compiler/tests-full/stdlib.cma.expected.js b/compiler/tests-full/stdlib.cma.expected.js index c2828d554d..838afc7814 100644 --- a/compiler/tests-full/stdlib.cma.expected.js +++ b/compiler/tests-full/stdlib.cma.expected.js @@ -31666,7 +31666,7 @@ /*<>*/ new_cache(table); /*<>*/ return function(obj){ /*<>*/ return caml_call1 - (caml_get_public_method(x$9, m$2, 0), x$9) /*<>*/ ;} /*<>*/ ; + (caml_get_public_method(x$9, m$2), x$9) /*<>*/ ;} /*<>*/ ; case 21: var m$3 = /*<>*/ next(0), @@ -31674,7 +31674,7 @@ /*<>*/ new_cache(table); /*<>*/ return function(obj){ var _g_ = /*<>*/ obj[n$16 + 1]; - return caml_call1(caml_get_public_method(_g_, m$3, 0), _g_) /*<>*/ ;} /*<>*/ ; + return caml_call1(caml_get_public_method(_g_, m$3), _g_) /*<>*/ ;} /*<>*/ ; case 22: var m$4 = /*<>*/ next(0), @@ -31683,7 +31683,7 @@ /*<>*/ new_cache(table); /*<>*/ return function(obj){ var _g_ = /*<>*/ obj[e$4 + 1][n$17 + 1]; - return caml_call1(caml_get_public_method(_g_, m$4, 0), _g_) /*<>*/ ;} /*<>*/ ; + return caml_call1(caml_get_public_method(_g_, m$4), _g_) /*<>*/ ;} /*<>*/ ; default: var m$5 = /*<>*/ next(0), @@ -31695,7 +31695,7 @@ /*<>*/ caml_call1 (obj[1][n$18 + 1], obj); /*<>*/ return caml_call1 - (caml_get_public_method(_g_, m$5, 0), _g_) /*<>*/ ;} /*<>*/ ; + (caml_get_public_method(_g_, m$5), _g_) /*<>*/ ;} /*<>*/ ; } /*<>*/ return clo; /*<>*/ } diff --git a/runtime/js/obj.js b/runtime/js/obj.js index e6578211c9..1c17c3420a 100644 --- a/runtime/js/obj.js +++ b/runtime/js/obj.js @@ -142,19 +142,41 @@ function caml_lazy_make_forward(v) { return [250, v]; } -///////////// CamlinternalOO -//Provides: caml_get_public_method const +//Provides: caml_method_cache var caml_method_cache = []; -function caml_get_public_method(obj, tag, cacheid) { + +//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_cached_method const +//Requires: caml_method_cache +function caml_get_cached_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 meths[li]; +} + +//Provides: caml_get_public_method const +function caml_get_public_method(obj, tag) { + var meths = obj[1]; var li = 3, hi = meths[1] * 2 + 1, mi; @@ -163,7 +185,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 index 5e06a4a5ed..5e6a96ea5f 100644 --- 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_cached_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))) @@ -447,6 +457,48 @@ (br $loop)))) (array.set $int_array (global.get $method_cache) (local.get $cacheid) (i32.add (local.get $li) (i32.const 1))) + (array.get $block (local.get $meths) (local.get $li)) + ) + + (func (export "caml_get_public_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)