From 68baff3e0d94985324882dfb5cbaed8a9a7ec573 Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Fri, 29 Sep 2023 10:12:09 +0200 Subject: [PATCH] Compiler: fix for 12500 --- compiler/lib-dynlink/dune | 7 +++- .../js_of_ocaml_compiler_dynlink.ml | 42 +++++++++++++------ compiler/lib-dynlink/stubs.c | 6 +++ compiler/lib/parse_bytecode.ml | 30 +++++++------ compiler/tests-check-prim/main.output5 | 1 + compiler/tests-check-prim/unix-unix.output5 | 1 + runtime/stdlib.js | 18 +++----- runtime/toplevel.js | 35 +++++++++++++++- 8 files changed, 95 insertions(+), 45 deletions(-) create mode 100644 compiler/lib-dynlink/stubs.c diff --git a/compiler/lib-dynlink/dune b/compiler/lib-dynlink/dune index 4965e7c38f..09467efc6a 100644 --- a/compiler/lib-dynlink/dune +++ b/compiler/lib-dynlink/dune @@ -3,7 +3,12 @@ (public_name js_of_ocaml-compiler.dynlink) (synopsis "Js_of_ocaml compiler dynlink support") (library_flags (-linkall)) + (foreign_stubs + (language c) + (names stubs)) (libraries js_of_ocaml-compiler js_of_ocaml-compiler.runtime - compiler-libs.bytecomp)) + compiler-libs.bytecomp) + (preprocess + (pps ppx_optcomp_light))) diff --git a/compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml b/compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml index 5b7e6f3708..edf6defd79 100644 --- a/compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml +++ b/compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml @@ -2,18 +2,34 @@ open Js_of_ocaml_compiler.Stdlib open Js_of_ocaml_compiler module J = Jsoo_runtime.Js -let split_primitives p = - let len = String.length p in - let rec split beg cur = - if cur >= len - then [] - else if Char.equal p.[cur] '\000' - then String.sub p ~pos:beg ~len:(cur - beg) :: split (cur + 1) (cur + 1) - else split beg (cur + 1) +let all_primitives () : string list = + let split_primitives p = + let len = String.length p in + let rec split beg cur = + if cur >= len + then [] + else if Char.equal p.[cur] '\000' + then String.sub p ~pos:beg ~len:(cur - beg) :: split (cur + 1) (cur + 1) + else split beg (cur + 1) + in + split 0 0 in - Array.of_list (split 0 0) + split_primitives (Symtable.data_primitive_names ()) +[@@if ocaml_version < (5, 3)] + +let all_primitives () : string list = Symtable.data_primitive_names () +[@@if ocaml_version >= (5, 3)] + +type bytecode_sections = + { symb : Ocaml_compiler.Symtable.GlobalMap.t + ; crcs : (string * Digest.t option) list + ; prim : string list + ; dlpt : string list + } +[@@ocaml.warning "-unused-field"] -external get_section_table : unit -> (string * Obj.t) list = "caml_get_section_table" +external get_bytecode_sections : unit -> bytecode_sections + = "caml_dynlink_get_bytecode_sections" let () = let global = J.pure_js_expr "globalThis" in @@ -22,7 +38,7 @@ let () = (* this needs to stay synchronized with toplevel.js *) let toplevel_compile (s : string) (debug : Instruct.debug_event list array) : unit -> J.t = - let prims = split_primitives (Symtable.data_primitive_names ()) in + let prims = Array.of_list (all_primitives ()) in let b = Buffer.create 100 in let fmt = Pretty_print.to_buffer b in Driver.configure fmt; @@ -47,9 +63,9 @@ let () = flush stderr; res in - let toc = get_section_table () in + let toc = get_bytecode_sections () in let sym = - let t : Ocaml_compiler.Symtable.GlobalMap.t = Obj.obj (List.assoc "SYMB" toc) in + let t : Ocaml_compiler.Symtable.GlobalMap.t = toc.symb in Ocaml_compiler.Symtable.GlobalMap.fold (fun i n acc -> StringMap.add (Ocaml_compiler.Symtable.Global.name i) n acc) t diff --git a/compiler/lib-dynlink/stubs.c b/compiler/lib-dynlink/stubs.c new file mode 100644 index 0000000000..47d9f67eef --- /dev/null +++ b/compiler/lib-dynlink/stubs.c @@ -0,0 +1,6 @@ +#include +#include +void caml_dynlink_get_bytecode_sections () { + fprintf(stderr, "Unimplemented Javascript primitive caml_dynlink_get_bytecode_sections!\n"); + exit(1); +} diff --git a/compiler/lib/parse_bytecode.ml b/compiler/lib/parse_bytecode.ml index 43ccd11af9..d001e2ed64 100644 --- a/compiler/lib/parse_bytecode.ml +++ b/compiler/lib/parse_bytecode.ml @@ -2647,6 +2647,14 @@ let read_primitives toc ic = assert (Char.equal (String.get prim (String.length prim - 1)) '\000'); String.split_char ~sep:'\000' (String.sub prim ~pos:0 ~len:(String.length prim - 1)) +type bytesections = + { symb : Ocaml_compiler.Symtable.GlobalMap.t + ; crcs : (string * Digest.t option) list + ; prim : string list + ; dlpt : string list + } +[@@ocaml.warning "-unused-field"] + let from_exe ?(includes = []) ~linkall @@ -2736,7 +2744,7 @@ let from_exe let body = if link_info then - let symtable_js = + let symbols_array = Ocaml_compiler.Symtable.GlobalMap.fold (fun i p acc -> (Ocaml_compiler.Symtable.Global.name i, p) :: acc) symbols @@ -2744,17 +2752,12 @@ let from_exe |> Array.of_list in (* Include linking information *) - let toc = - [ "SYMB", Obj.repr symbols - ; "SYJS", Obj.repr symtable_js - ; "CRCS", Obj.repr crcs - ; "PRIM", Obj.repr (String.concat ~sep:"\000" primitives ^ "\000") - ] - in + let sections = { symb = symbols; crcs; prim = primitives; dlpt = [] } in let gdata = Var.fresh () in let need_gdata = ref false in let infos = - [ "toc", Constants.parse (Obj.repr toc) + [ "sections", Constants.parse (Obj.repr sections) + ; "symbols", Constants.parse (Obj.repr symbols_array) ; "prim_count", Int (Int32.of_int (Array.length globals.primitives)) ] in @@ -3168,15 +3171,10 @@ let link_info ~symtable ~primitives ~crcs = let body = [] in let body = (* Include linking information *) - let toc = - [ "SYMB", Obj.repr symtable - ; "SYJS", Obj.repr symtable_js - ; "CRCS", Obj.repr crcs - ; "PRIM", Obj.repr (String.concat ~sep:"\000" primitives ^ "\000") - ] - in + let toc = { symb = symtable; crcs; prim = primitives; dlpt = [] } in let infos = [ "toc", Constants.parse (Obj.repr toc) + ; "tocjs", Constants.parse (Obj.repr symtable_js) ; "prim_count", Int (Int32.of_int (List.length primitives)) ] in diff --git a/compiler/tests-check-prim/main.output5 b/compiler/tests-check-prim/main.output5 index e5d57d6baf..7c943e2531 100644 --- a/compiler/tests-check-prim/main.output5 +++ b/compiler/tests-check-prim/main.output5 @@ -7,6 +7,7 @@ caml_continuation_use caml_drop_continuation caml_dynlink_add_primitive caml_dynlink_close_lib +caml_dynlink_get_bytecode_sections caml_dynlink_get_current_libs caml_dynlink_lookup_symbol caml_dynlink_open_lib diff --git a/compiler/tests-check-prim/unix-unix.output5 b/compiler/tests-check-prim/unix-unix.output5 index baf80c9f04..ec18cd16a8 100644 --- a/compiler/tests-check-prim/unix-unix.output5 +++ b/compiler/tests-check-prim/unix-unix.output5 @@ -7,6 +7,7 @@ caml_continuation_use caml_drop_continuation caml_dynlink_add_primitive caml_dynlink_close_lib +caml_dynlink_get_bytecode_sections caml_dynlink_get_current_libs caml_dynlink_lookup_symbol caml_dynlink_open_lib diff --git a/runtime/stdlib.js b/runtime/stdlib.js index 4029305135..01285c96ec 100644 --- a/runtime/stdlib.js +++ b/runtime/stdlib.js @@ -146,15 +146,7 @@ var caml_global_data = [0]; //Provides: caml_build_symbols //Requires: caml_jsstring_of_string -function caml_build_symbols(toc) { - var symb; - while(toc) { - if(caml_jsstring_of_string(toc[1][1]) == "SYJS") { - symb = toc[1][2]; - break; - } - else toc = toc[2] - } +function caml_build_symbols(symb) { var r = {}; if(symb) { for(var i = 1; i < symb.length; i++){ @@ -173,11 +165,11 @@ function caml_register_global (n, v, name_opt) { if(globalThis.toplevelReloc) { n = caml_callback(globalThis.toplevelReloc, [name]); } - else if (caml_global_data.toc) { - if(!caml_global_data.symbols) { - caml_global_data.symbols = caml_build_symbols(caml_global_data.toc) + else if (caml_global_data.symbols) { + if(!caml_global_data.symidx) { + caml_global_data.symidx = caml_build_symbols(caml_global_data.symbols) } - var nid = caml_global_data.symbols[name] + var nid = caml_global_data.symidx[name] if(nid >= 0) n = nid else { diff --git a/runtime/toplevel.js b/runtime/toplevel.js index 4f9feb1515..65cd5c3635 100644 --- a/runtime/toplevel.js +++ b/runtime/toplevel.js @@ -41,11 +41,42 @@ function caml_get_current_environment() { //Provides: caml_get_section_table //Requires: caml_global_data, caml_failwith +//Requires: caml_string_of_jsbytes, caml_jsbytes_of_string +//Requires: caml_list_of_js_array +//Version: < 5.3 function caml_get_section_table () { - if(!caml_global_data.toc) { + if(!caml_global_data.sections) { caml_failwith("Program not compiled with --toplevel"); } - return caml_global_data.toc; + var symb = caml_global_data.sections[1]; + var crcs = caml_global_data.sections[2]; + var prim = caml_global_data.sections[3]; + var dlpt = caml_global_data.sections[4]; + function sl(l) { + var x = "" + while(l){ + x += caml_jsbytes_of_string(l[1]); + x += "\0"; + l = l[2]; + } + return caml_string_of_jsbytes(x); + } + var res = caml_list_of_js_array([ + [0, caml_string_of_jsbytes("SYMB"), symb], + [0, caml_string_of_jsbytes("CRCS"), crcs], + [0, caml_string_of_jsbytes("PRIM"), sl(prim)], + [0, caml_string_of_jsbytes("DLPT"), sl(dlpt)] + ]); + return res +} + +//Provides: caml_dynlink_get_bytecode_sections +//Requires: caml_global_data, caml_failwith +function caml_dynlink_get_bytecode_sections() { + if(!caml_global_data.sections) { + caml_failwith("Program not compiled with --toplevel"); + } + return caml_global_data.sections; } //Provides: caml_reify_bytecode