Experiment with compiling (ordinary) variants to objects.

jscomp/core/js_dump.ml

@@ -497,16 +497,15 @@ and  pp_function is_method
     since it can be either [int] or [string]
 *)
 and pp_one_case_clause : 'a .
-  _ -> P.t -> (P.t -> 'a -> unit) -> 'a J.case_clause -> _
+  _ -> P.t -> (string option -> P.t -> 'a -> unit) -> 'a J.case_clause -> _
   = fun cxt f  pp_cond
     ({switch_case; switch_body ; should_break; comment; } : _ J.case_clause) ->
     let cxt =
       P.group f 1  (fun _ ->
           P.group f 1 (fun _ ->
               P.string f L.case;
               P.space f ;
-              pp_comment_option f comment;
-              pp_cond  f switch_case; (* could be integer or string *)
+              pp_cond comment f switch_case; (* could be integer or string *)
               P.space f ;
               P.string f L.colon  );
           P.group f 1 (fun _ ->
@@ -529,7 +528,7 @@ and pp_one_case_clause : 'a .
     cxt
 
 and loop_case_clauses  :  'a . cxt ->
-  P.t -> (P.t -> 'a -> unit) -> 'a J.case_clause list -> cxt
+  P.t -> (string option -> P.t -> 'a -> unit) -> 'a J.case_clause list -> cxt
   = fun  cxt  f pp_cond cases ->
     Ext_list.fold_left cases cxt (fun acc x -> pp_one_case_clause acc f pp_cond x)              
 
@@ -1277,7 +1276,11 @@ and statement_desc top cxt f (s : J.statement_desc) : cxt =
     let cxt = P.paren_group f 1 (fun _ ->  expression 0 cxt f e) in
     P.space f;
     P.brace_vgroup f 1 @@ fun _ ->
-    let cxt = loop_case_clauses cxt f (fun f i -> P.string f (string_of_int i) ) cc in
+    let cxt = loop_case_clauses cxt f (fun comment f i ->
+      let s = match comment with
+        | None -> string_of_int i
+        | Some s -> "\"" ^ s  ^ "\""in
+      P.string f s) cc in
     (match def with
      | None -> cxt
      | Some def ->
@@ -1294,7 +1297,7 @@ and statement_desc top cxt f (s : J.statement_desc) : cxt =
     let cxt = P.paren_group f 1 @@ fun _ ->  expression 0 cxt f e in
     P.space f;
     P.brace_vgroup f 1 (fun _ ->
-        let cxt = loop_case_clauses cxt f (fun f i -> Js_dump_string.pp_string f i ) cc in
+        let cxt = loop_case_clauses cxt f (fun _ f i -> Js_dump_string.pp_string f i ) cc in
         match def with
         | None -> cxt
         | Some def ->

jscomp/core/js_exp_make.ml

@@ -182,6 +182,20 @@ let make_block ?comment
   match tag_info with 
   | Blk_module _ -> 
     {expression_desc = Caml_block(es,mutable_flag, tag,tag_info); comment}
+  | Blk_constructor _ ->
+    let name = match Lam_compile_util.comment_of_tag_info tag_info with
+    | Some s -> s
+    | None -> assert false in
+    (* {
+      expression_desc = Caml_block( es, mutable_flag, str name, tag_info) ;
+      comment 
+    } *)
+    let comment = Some "constructor" in
+    let property_map = [
+      ("tag", str name);
+      ]
+      @ List.mapi (fun n e -> ("Arg" ^ string_of_int n, e)) es in
+    {expression_desc = Object property_map; comment}
   | _ -> 
   let comment = 
     match comment with 
@@ -775,6 +789,9 @@ let rec string_equal ?comment (e0 : t) (e1 : t) : t =
 let is_type_number ?comment (e : t) : t = 
   string_equal ?comment (typeof e) (str "number")    
 
+let is_type_string ?comment (e : t) : t = 
+  string_equal ?comment (typeof e) (str "string")    
+
 
 (* we are calling [Caml_primitive.primitive_name], since it's under our
    control, we should make it follow the javascript name convention, and
@@ -783,10 +800,11 @@ let is_type_number ?comment (e : t) : t =
 
 
 let tag ?comment e : t = 
-  {expression_desc = 
+  let comment = Some "XXX" in
+  {expression_desc = Caml_block_tag e; comment }
+  (* {expression_desc = 
      Bin (Bor, {expression_desc = Caml_block_tag e; comment }, zero_int_literal );
-   comment = None }    
-
+   comment = None } *)
 
 (* according to the compiler, [Btype.hash_variant], 
    it's reduced to 31 bits for hash

jscomp/core/js_exp_make.mli

@@ -213,6 +213,7 @@ val string_equal : ?comment:string -> t -> t -> t
 val eq_null_undefined_boolean: ?comment:string -> t -> t -> t 
 val neq_null_undefined_boolean: ?comment:string -> t -> t -> t 
 val is_type_number : ?comment:string -> t -> t 
+val is_type_string : ?comment:string -> t -> t 
 val typeof : ?comment:string -> t -> t 
 
 val to_int32 : ?comment:string -> t -> t 

jscomp/core/js_of_lam_block.ml

@@ -61,6 +61,8 @@ let field (field_info : Lam_compat.field_dbg_info) e i =
     -> E.array_index_by_int ~comment e i
   | Fld_module name
     -> E.module_access e name i
+  | Fld_arg pos
+    -> E.dot e ("Arg" ^ string_of_int pos)
 let field_by_exp e i = 
   E.array_index e i 
 

jscomp/core/js_of_lam_float_record.ml

@@ -31,7 +31,8 @@ module E = Js_exp_make
 
 let get_double_feild (field_info : Lam_compat.field_dbg_info) e i = 
   match field_info with 
-  | Fld_na -> 
+  | Fld_na
+  | Fld_arg _ -> 
     E.array_index_by_int e i 
 #if OCAML_VERSION =~ ">4.03.0" then 
   | Fld_record_inline s

jscomp/core/js_of_lam_record.ml

@@ -43,7 +43,8 @@ module E = Js_exp_make
 
 let field (field_info : Lam_compat.field_dbg_info) e i =
   match field_info with 
-  | Fld_na -> 
+  | Fld_na
+  | Fld_arg _ -> 
     E.array_index_by_int e i 
 #if OCAML_VERSION =~ ">4.03.0" then
   | Fld_record_inline s

jscomp/core/lam_compat.ml

@@ -185,7 +185,8 @@ type meth_kind = Lambda.meth_kind
 type field_dbg_info = Lambda.field_dbg_info =
   | Fld_na
   | Fld_record of string
-  | Fld_module of string 
+  | Fld_module of string
+  | Fld_arg of int
 #if OCAML_VERSION =~ ">4.03.0"  then 
   | Fld_record_inline of string 
   | Fld_record_extension of string 

jscomp/core/lam_compat.mli

@@ -86,7 +86,8 @@ type meth_kind = Lambda.meth_kind
 type field_dbg_info = Lambda.field_dbg_info =
   | Fld_na
   | Fld_record of string
-  | Fld_module of string 
+  | Fld_module of string
+  | Fld_arg of int
 #if OCAML_VERSION =~ ">4.03.0"  then 
   | Fld_record_inline of string 
   | Fld_record_extension of string 

jscomp/core/lam_compile.ml

@@ -550,7 +550,11 @@ and compile_general_cases
 and compile_cases cxt switch_exp table default get_name =
   compile_general_cases
     get_name
-    (fun i -> {(E.small_int i) with comment = get_name i})
+    (fun i ->
+      let comment = get_name i in
+      match comment with
+      | None -> E.small_int i
+      | Some s -> E.str s)
     E.int_equal
     cxt
     (fun  ?default ?declaration e clauses    ->
@@ -607,15 +611,15 @@ and compile_switch switch_arg sw (lambda_cxt : Lam_compile_context.t) =
          (* [e] will be used twice  *)
          let dispatch e =
            S.if_
-             (E.is_type_number e )
+             (E.is_type_string e)
              (compile_cases cxt e sw_consts sw_num_default (get_name true)
              )
              (* default still needed, could simplified*)
              ~else_:
                (compile_cases cxt (E.tag e ) sw_blocks
                   sw_blocks_default (get_name false)) in
            match e.expression_desc with
-           | J.Var _  -> [ dispatch e]
+           | J.Var _ -> [ dispatch e]
            | _ ->
              let v = Ext_ident.create_tmp () in
              (* Necessary avoid duplicated computation*)

jscomp/core/lam_compile_const.ml

@@ -86,9 +86,13 @@ and translate (x : Lam_constant.t ) : J.expression =
     E.unicode i 
 
 
-  | Const_pointer (c,pointer_info) ->     
-    E.int ?comment:(Lam_compile_util.comment_of_pointer_info pointer_info)
-      (Int32.of_int c )
+  | Const_pointer (c,pointer_info) ->
+    ( match pointer_info with
+      | Pt_constructor s when s <> "()" ->
+        E.str s
+      | _ ->
+        E.int ?comment:(Lam_compile_util.comment_of_pointer_info pointer_info)
+          (Int32.of_int c ))
 
   | Const_block(tag, tag_info, xs ) -> 
     Js_of_lam_block.make_block NA tag_info 

jscomp/core/lam_compile_primitive.ml

@@ -590,7 +590,7 @@ let translate  loc
     Lam_compile_external_call.translate_ffi 
       loc cxt arg_types ffi args 
   (** FIXME, this can be removed later *)
-  | Pisint -> 
+  | Pisint ->
     E.is_type_number (Ext_list.singleton_exn args)
   | Pctconst ct -> 
     (match ct with 

jscomp/core/lam_print.ml

@@ -153,6 +153,8 @@ let primitive ppf (prim : Lam_primitive.t) = match prim with
     -> fprintf ppf "field %s/%i" s n
   | Pfield (n, Fld_na) 
     -> fprintf ppf "field %i" n
+  | Pfield (n, Fld_arg _) 
+    -> fprintf ppf "field_arg %i" n
   | Pfield_computed -> 
     fprintf ppf "field_computed"
   | Psetfield_computed -> 

jscomp/others/belt_List.ml

@@ -73,12 +73,20 @@ external mutableCell :
 *)
 external unsafeMutateTail :
   'a t -> 'a t -> unit = "#setfield1"
+let unsafeMutateTail0 = fun%raw l x ->  {|
+  l.Arg1 = x;
+|}
+let unsafeMutateTail : 'a t -> 'a t -> unit = unsafeMutateTail0
 (*
    - the cell is not empty
    - it is mutated
 *)
 external unsafeTail :
   'a t -> 'a t = "%field1"
+let unsafeTail0 = fun%raw l ->  {|
+  return l.Arg1
+|}
+let unsafeTail : 'a t -> 'a t = unsafeTail0
 (*
    - the cell is not empty
 *)

jscomp/runtime/caml_hash.ml

@@ -133,6 +133,8 @@ let caml_hash (count : int) _limit (seed : nativeint)
         match Js.undefinedToOption size with
         | None -> ()
         | Some size -> 
+          (* TODO: this could be extended so it works for arbitrary objects,
+             rather than the specific ones obtained from variants. *)
           let obj_tag = Caml_obj_extern.tag obj in
           let tag = (size lsl 10) lor obj_tag in 
           if tag = 248 (* Obj.object_tag*) then 

jscomp/runtime/caml_obj.ml

@@ -119,7 +119,7 @@ let caml_lazy_make (fn : _ -> _) =
    In most cases, rec value comes from record/modules, 
    whose tag is 0, we optimize that case
 *)
-let caml_update_dummy (x : Caml_obj_extern.t) (y : Caml_obj_extern.t) : unit =
+let caml_update_dummy0 (x : Caml_obj_extern.t) (y : Caml_obj_extern.t) : unit =
   (* let len = Caml_obj_extern.length y in   
      for i = 0 to len - 1 do 
      Array.unsafe_set x i (Caml_obj_extern.field y i)
@@ -137,6 +137,16 @@ let caml_update_dummy (x : Caml_obj_extern.t) (y : Caml_obj_extern.t) : unit =
 (* [set_length] seems redundant here given that it is initialized as an array 
 *)
 
+let () = if [1] == [1] then Js.log(caml_update_dummy0)
+
+let caml_update_dummy : Caml_obj_extern.t -> Caml_obj_extern.t -> unit = fun%raw x y-> {|
+if (Array.isArray(x) && Array.isArray(y)) { return caml_update_dummy0(x,y) }
+else {
+  return Object.assign(x, y)
+}
+|}
+
+
 type 'a selector = 'a -> 'a -> 'a 
 
 module O = struct

jscomp/runtime/caml_obj_extern.ml

@@ -36,8 +36,17 @@ external length : t -> int = "#obj_length"
 (** The same as {!Obj.set_tag} *)
 external set_tag : t -> int -> unit = "tag" [@@bs.set]
 
-external size_of_t : t -> 'a Js.undefined =
-  "length" [@@bs.get]
 
+(* external size_of_t : t -> 'a Js.undefined =
+  "length" [@@bs.get] *)
+
+(* polymorphic variants are still arrays *)
+let size_of_t : t -> 'a Js.undefined = fun%raw o -> {|
+return Array.isArray(o) ? o.length : Object.keys(o).length
+|}
+
+let length : t -> int = fun%raw o -> {|
+return Array.isArray(o) ? o.length : Object.keys(o).length
+|}
 
 external magic : 'a -> 'b = "%identity"

jscomp/runtime/caml_parser.ml

@@ -70,28 +70,28 @@ function caml_lex_array(s) {
  * @enum{number}
  */
 var Automata = {
-    START: 0,
-    LOOP: 6,
-    TOKEN_READ: 1,
-    TEST_SHIFT: 7,
-    ERROR_DETECTED: 5,
-    SHIFT: 8,
-    SHIFT_RECOVER: 9,
-    STACK_GROWN_1: 2,
-    REDUCE: 10,
-    STACK_GROWN_2: 3,
-    SEMANTIC_ACTION_COMPUTED: 4
+    START: "Start",
+    LOOP: "Loop",
+    TOKEN_READ: "Token_read",
+    TEST_SHIFT: "Test_shift",
+    ERROR_DETECTED: "Error_detected",
+    SHIFT: "Shift",
+    SHIFT_RECOVER: "Shift_recover",
+    STACK_GROWN_1: "Stacks_grown_1",
+    REDUCE: "Reduce",
+    STACK_GROWN_2: "Stacks_grown_2",
+    SEMANTIC_ACTION_COMPUTED: "Semantic_action_computed"
 };
 /**
  * @enum{number}
  */
 var Result = {
-    READ_TOKEN: 0,
-    RAISE_PARSE_ERROR: 1,
-    GROW_STACKS_1: 2,
-    GROW_STACKS_2: 3,
-    COMPUTE_SEMANTIC_ACTION: 4,
-    CALL_ERROR_FUNCTION: 5
+    READ_TOKEN: "Read_token",
+    RAISE_PARSE_ERROR: "Raise_parse_error",
+    GROW_STACKS_1: "Grow_stacks_1",
+    GROW_STACKS_2: "Grow_stacks_2",
+    COMPUTE_SEMANTIC_ACTION: "Compute_semantic_action",
+    CALL_ERROR_FUNCTION: "Call_error_function"
 };
 var PARSER_TRACE = false;
 |}]
@@ -157,6 +157,7 @@ type parser_env
 
 
 let caml_parse_engine : parse_tables -> parser_env -> (*Parsing.parser_input *)Caml_obj_extern.t -> Caml_obj_extern.t -> Caml_obj_extern.t = fun%raw tables (* parser_table *) env (* parser_env *) cmd (* parser_input*) arg (* Caml_obj_extern.t*) -> {|
+    console.log("cmd", cmd, "arg", arg);
     var ERRCODE = 256;
     //var START = 0;
     //var TOKEN_READ = 1;
@@ -243,7 +244,8 @@ let caml_parse_engine : parse_tables -> parser_env -> (*Parsing.parser_input *)C
             /* symb_start and symb_end */
             case Automata.TOKEN_READ:
                 if (typeof arg !== 'number') {
-                    env[env_curr_char] = tables[tbl_transl_block][arg.tag | 0 /* + 1 */];
+                    console.log("tbl_transl_block", tables[tbl_transl_block]);
+                    env[env_curr_char] = tables[tbl_transl_block][arg.tag /* + 1 */];
                     env[env_lval] = arg[0];
                 }
                 else {

jscomp/stdlib-402/printexc.ml

@@ -58,7 +58,7 @@ let to_string x =
             sprintf locfmt file line char (char+6) "Undefined recursive module"
         | _ ->
             let x = Obj.repr x in
-            if Obj.tag x <> 0 then
+            if Obj.tag x <> (Obj.magic None) then
               (Obj.magic (Obj.field x 0) : string)
             else
               let constructor =

jscomp/test/406_primitive_test.js

@@ -2,7 +2,7 @@
 
 var Mt = require("./mt.js");
 
-var suites = /* record */[/* contents : [] */0];
+var suites = /* record */[/* contents */"[]"];
 
 var test_id = /* record */[/* contents */0];