Runtime: more efficient (space-wise) marshalling.

compiler/tests/test_marshal.ml

@@ -0,0 +1,102 @@
+(* Js_of_ocaml tests
+ * http://www.ocsigen.org/js_of_ocaml/
+ * Copyright (C) 2019 Shachar Itzhaky
+ *
+ * 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.
+ *)
+
+(* https://github.com/ocsigen/js_of_ocaml/pull/814 *)
+
+let%expect_test _ =
+  Util.compile_and_run
+    {|
+    type sign = SPlus | SMinus
+    type raw_numeral = int
+
+    type prim_token =
+      | Numeral of sign * raw_numeral
+      | String of string
+
+    type operator_token = Add | Sub | Times | PlusPlus
+
+    type expr =
+      | Literal of prim_token
+      | Op of operator_token * expr list
+
+    let write_out chan v =
+        let start = pos_out chan in
+        Marshal.to_channel chan v [];
+        pos_out chan - start
+
+    let write_out_noshare chan v =
+        let start = pos_out chan in
+        Marshal.to_channel chan v [Marshal.No_sharing];
+        pos_out chan - start
+
+    let _ =
+      let tmp_filename = Filename.temp_file "out" "txt" in
+      let chan = open_out tmp_filename in
+      let v1 = Op (Add, [Literal (Numeral (SPlus, 5)); Literal (Numeral (SMinus, 7))]) in
+      let v2 = Op (Times, [v1; v1]) (* shared *) in
+      let v1_sz = write_out chan v1 in
+      let v2_sz = write_out chan v2 in
+      let v2_ns_sz = write_out_noshare chan v2 in
+      flush chan;
+      Format.printf "sizes = %d %d %d (|v2| %s |v2_ns|)\n%!" v1_sz v2_sz v2_ns_sz
+        (if v2_sz < v2_ns_sz then "<" else ">=");
+
+      let chan = open_in tmp_filename in
+      let v1' = Marshal.from_channel chan in
+      let v2' = Marshal.from_channel chan in
+      Format.printf "readback = %B %B\n%!" (v1 = v1') (v2 = v2')
+|};
+  [%expect {|
+   sizes = 33 40 51 (|v2| < |v2_ns|)
+   readback = true true |}]
+
+(* https://github.com/ocsigen/js_of_ocaml/issues/359 *)
+
+let%expect_test _ =
+  let module M = struct
+    type loop = {mutable pointer : loop option}
+
+    let l = {pointer = None}
+
+    let () = l.pointer <- Some l
+
+    let _ =
+      let s = Marshal.to_string l [] in
+      Format.printf "%d\n%S\n%!" (String.length s) s
+  end in
+  [%expect
+    {|
+    24
+    "\132\149\166\190\000\000\000\004\000\000\000\002\000\000\000\004\000\000\000\004\144\144\004\002" |}]
+
+let%expect_test _ =
+  Util.compile_and_run
+    {|
+    type loop = { mutable pointer : loop option }
+    let l = { pointer = None }
+    let () = l.pointer <- Some l
+
+    let _ =
+      let s = Marshal.to_string l [] in
+      Format.printf "%d\n%S\n%!" (String.length s) s
+|};
+  [%expect
+    {|
+    24
+    "\132\149\166\190\000\000\000\004\000\000\000\002\000\000\000\004\000\000\000\004\144\144\004\002" |}]

runtime/io.js

@@ -386,8 +386,8 @@ function caml_ml_output_char (chanid,c) {
 
 //Provides: caml_output_value
 //Requires: caml_output_value_to_string, caml_ml_output,caml_ml_string_length
-function caml_output_value (chanid,v,_flags) {
-  var s = caml_output_value_to_string(v);
+function caml_output_value (chanid,v,flags) {
+  var s = caml_output_value_to_string(v, flags);
   caml_ml_output(chanid,s,0,caml_ml_string_length(s));
   return 0;
 }

runtime/marshal.js

@@ -337,10 +337,46 @@ function caml_marshal_data_size (s, ofs) {
   return (get32(s, ofs + 4));
 }
 
+//Provides: MlObjectTable
+var MlObjectTable;
+if (typeof joo_global_object.WeakMap === 'undefined') {
+  MlObjectTable = function() {
+    /* polyfill */
+    function NaiveLookup(objs) { this.objs = objs; }
+    NaiveLookup.prototype.get = function(v) {
+      for (var i = 0; i < this.objs.length; i++) {
+        if (this.objs[i] === v) return i;
+      }
+    };
+    NaiveLookup.prototype.set = function() { };
+
+    return function MlObjectTable() {
+      this.objs = []; this.lookup = new NaiveLookup(this.objs);
+    };
+  }();
+}
+else {
+  MlObjectTable = function MlObjectTable() {
+    this.objs = []; this.lookup = new joo_global_object.WeakMap();
+  };
+}
+
+MlObjectTable.prototype.store = function(v) {
+  this.lookup.set(v, this.objs.length);
+  this.objs.push(v);
+}
+
+MlObjectTable.prototype.recall = function(v) {
+  var i = this.lookup.get(v);
+  return (i === undefined)
+    ? undefined : this.objs.length - i;   /* index is relative */
+}
+
 //Provides: caml_output_val
 //Requires: caml_int64_to_bytes, caml_failwith
 //Requires: caml_int64_bits_of_float
 //Requires: MlBytes, caml_ml_string_length, caml_string_unsafe_get
+//Requires: MlObjectTable, caml_list_to_js_array
 var caml_output_val = function (){
   function Writer () { this.chunk = []; }
   Writer.prototype = {
@@ -354,6 +390,11 @@ var caml_output_val = function (){
       for (var i = size - 8;i >= 0;i -= 8)
         this.chunk[this.chunk_idx++] = (value >> i) & 0xFF;
     },
+    write_shared:function (offset) {
+      if (offset < (1 << 8)) this.write_code(8, 0x04 /*cst.CODE_SHARED8*/, offset);
+      else if (offset < (1 << 16)) this.write_code(16, 0x05 /*cst.CODE_SHARED16*/, offset);
+      else this.write_code(32, 0x06 /*cst.CODE_SHARED32*/, offset);
+    },
     finalize:function () {
       this.block_len = this.chunk_idx - 20;
       this.chunk_idx = 0;
@@ -365,13 +406,32 @@ var caml_output_val = function (){
       return this.chunk;
     }
   }
-  return function (v) {
+  return function (v, flags) {
+    flags = caml_list_to_js_array(flags);
+
+    var no_sharing = (flags.indexOf(0 /*Marshal.No_sharing*/) !== -1),
+        closures =  (flags.indexOf(1 /*Marshal.Closures*/) !== -1);
+        /* Marshal.Compat_32 is redundant since integers are 32-bit anyway */
+
+    if (closures)
+      joo_global_object.console.warn("in caml_output_val: flag Marshal.Closures is not supported.");
+
     var writer = new Writer ();
     var stack = [];
+    var intern_obj_table = new MlObjectTable();
+
+    function memo(v) {
+      if(no_sharing) return undefined;
+      var existing_offset = no_sharing ? undefined : intern_obj_table.recall(v);
+      if (existing_offset) { writer.write_shared(existing_offset); return existing_offset; }
+      else intern_obj_table.store(v);
+    }
+
     function extern_rec (v) {
       if (v instanceof Array && v[0] === (v[0]|0)) {
         if (v[0] == 255) {
           // Int64
+          if (memo(v)) return;
           writer.write (8, 0x12 /*cst.CODE_CUSTOM*/);
           for (var i = 0; i < 3; i++) writer.write (8, "_j\0".charCodeAt(i));
           var b = caml_int64_to_bytes (v);
@@ -383,6 +443,7 @@ var caml_output_val = function (){
         if (v[0] == 251) {
           caml_failwith("output_value: abstract value (Abstract)");
         }
+        if (v.length > 1 && memo(v)) return;
         if (v[0] < 16 && v.length - 1 < 8)
           writer.write (8, 0x80 /*cst.PREFIX_SMALL_BLOCK*/ + v[0] + ((v.length - 1)<<4));
         else
@@ -391,6 +452,7 @@ var caml_output_val = function (){
         writer.size_64 += v.length;
         if (v.length > 1) stack.push (v, 1);
       } else if (v instanceof MlBytes) {
+        if (memo(v)) return;
         var len = caml_ml_string_length(v);
         if (len < 0x20)
           writer.write (8, 0x20 /*cst.PREFIX_SMALL_STRING*/ + len);
@@ -437,30 +499,28 @@ var caml_output_val = function (){
       if (i + 1 < v.length) stack.push (v, i + 1);
       extern_rec (v[i]);
     }
-    writer.finalize ();
+    writer.obj_counter = intern_obj_table.objs.length;
+    writer.finalize();
     return writer.chunk;
   }
 } ();
 
 //Provides: caml_output_value_to_string mutable
 //Requires: caml_output_val, caml_string_of_array
-function caml_output_value_to_string (v, _fl) {
-  /* ignores flags... */
-  return caml_string_of_array (caml_output_val (v));
+function caml_output_value_to_string (v, flags) {
+  return caml_string_of_array (caml_output_val (v, flags));
 }
 
 //Provides: caml_output_value_to_bytes mutable
 //Requires: caml_output_val, caml_string_of_array
-function caml_output_value_to_bytes (v, _fl) {
-  /* ignores flags... */
-  return caml_string_of_array (caml_output_val (v));
+function caml_output_value_to_bytes (v, flags) {
+  return caml_string_of_array (caml_output_val (v, flags));
 }
 
 //Provides: caml_output_value_to_buffer
 //Requires: caml_output_val, caml_failwith, caml_blit_bytes
-function caml_output_value_to_buffer (s, ofs, len, v, _fl) {
-  /* ignores flags... */
-  var t = caml_output_val (v);
+function caml_output_value_to_buffer (s, ofs, len, v, flags) {
+  var t = caml_output_val (v, flags);
   if (t.length > len) caml_failwith ("Marshal.to_buffer: buffer overflow");
   caml_blit_bytes(t, 0, s, ofs, t.length);
   return 0;

runtime/stdlib.js

@@ -1215,6 +1215,15 @@ function caml_list_of_js_array(a){
   return l
 }
 
+//Provides: caml_list_to_js_array const (const)
+function caml_list_to_js_array(l){
+  var a = [];
+  for(; l !== 0; l = l[2]) {
+    a.push(l[1]);
+  }
+  return a;
+}
+
 //Provides: caml_runtime_warnings
 var caml_runtime_warnings = 0;