Compiler: fix for 12500

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)))

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

compiler/lib-dynlink/stubs.c

@@ -0,0 +1,6 @@
+#include <stdlib.h>
+#include <stdio.h>
+void caml_dynlink_get_bytecode_sections () {
+  fprintf(stderr, "Unimplemented Javascript primitive caml_dynlink_get_bytecode_sections!\n");
+  exit(1);
+}

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,25 +2744,20 @@ 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
           []
         |> 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

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

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

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 {

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