switch the encoding of poly-var

- in debug mode it attaches the name property
- fix caml_hash to handle polyvar

Author: bobzhang

jscomp/core/js_dump.ml

@@ -849,6 +849,26 @@ and expression_desc cxt ~(level:int) f x : cxt  =
         (List.combine (Array.to_list fields) el )))      
         (* name convention of Record is slight different from modules 
         *)
+  | Caml_block(el,_,_, Blk_poly_var name) ->
+    begin match el with 
+      | [hash;value] -> 
+        expression_desc 
+          cxt 
+          ~level 
+          f 
+          (Object 
+             (("HASH", 
+               if !Js_config.debug then hash
+               else {hash with comment = Some name}
+              ) ::
+              ("value", value) ::
+              if !Js_config.debug then 
+                ["name", E.str name]
+              else []
+             )          
+          )
+      | _ -> assert false
+    end       
   | Caml_block(el,_, _, (Blk_extension | Blk_record_ext _ as ext )) ->             
     expression_desc cxt ~level f (exn_block_as_obj ~stack:false el ext)      
   | Caml_block( el, mutable_flag, tag, tag_info)

jscomp/core/js_exp_make.ml

@@ -400,7 +400,32 @@ let record_access (e : t) (name : string) (pos : int32) =
       { expression_desc = Static_index (e, name, Some pos); comment = None}     
     )
   | _ -> { expression_desc = Static_index (e, name, Some pos); comment = None} 
-    
+
+let poly_var_tag_access (e : t)  = 
+  match e.expression_desc with
+  | Array (l,_) (* Float i -- should not appear here *)
+  | Caml_block (l,_, _, _) when no_side_effect e
+    -> 
+    (match l  with
+     | x ::_ -> x 
+     | [] -> 
+       assert false
+    )
+  | _ -> { expression_desc = Static_index (e, "HASH", Some 0l); comment = None} 
+
+
+let poly_var_value_access (e : t) =   
+  match e.expression_desc with
+  | Array (l,_) 
+  | Caml_block (l,_, _, _) when no_side_effect e
+    -> 
+    (match l  with
+     | _ :: v :: _ ->  v
+     | _  -> 
+       assert false
+    )
+  | _ -> { expression_desc = Static_index (e, "value", Some 1l); comment = None} 
+  
 let extension_access (e : t) name (pos : int32)  : t  = 
   match e.expression_desc with
   | Array (l,_) (* Float i -- should not appear here *)

jscomp/core/js_exp_make.mli

@@ -201,6 +201,13 @@ val record_assign :
   t -> 
   t 
 
+val poly_var_tag_access : 
+  t -> t 
+
+val poly_var_value_access : 
+  t -> t  
+
+  
 val extension_assign : 
   t -> 
   int32 -> 

jscomp/core/js_of_lam_block.ml

@@ -52,14 +52,18 @@ let field (field_info : Lam_compat.field_dbg_info) e i =
   match field_info with 
   | Fld_na _
   | Fld_tuple  
-  | Fld_poly_var_tag 
-  | Fld_poly_var_content 
+  
+
   | Fld_record_inline _
   | Fld_variant
   | Fld_array
     -> 
     E.array_index_by_int  
       ?comment:(Lam_compat.str_of_field_info field_info) e i 
+  | Fld_poly_var_content
+    -> E.poly_var_value_access e     
+  | Fld_poly_var_tag    
+    -> E.poly_var_tag_access e 
   | Fld_record_extension {name} -> 
     E.extension_access e (Some name) i
   | Fld_extension -> 

jscomp/core/js_of_lam_option.ml

@@ -99,7 +99,7 @@ let option_unwrap (arg : J.expression) : J.expression =
   match desc with
   | Optional_block (x,_) 
     -> 
-    Js_of_lam_polyvar.get_field x 
+    E.poly_var_value_access x 
     (* invariant: option encoding *)
   | _ ->
     E.runtime_call Js_runtime_modules.option "option_unwrap" [arg]

jscomp/core/js_of_lam_polyvar.ml

@@ -58,7 +58,7 @@ let eval_as_event (arg : J.expression) (dispatches : (int * string) list ) =
   | _ ->
     Splice2
       (E.of_block
-      [(S.int_switch (Js_of_lam_polyvar.get_tag arg)
+      [(S.int_switch (E.poly_var_tag_access arg)
       (Ext_list.map dispatches (fun (i,r) ->
               {J.switch_case = i ;
                switch_body = [S.return_stmt (E.str r)];
@@ -69,7 +69,7 @@ let eval_as_event (arg : J.expression) (dispatches : (int * string) list ) =
            the problem is that we can not create bindings
            due to the
         *)
-     (Js_of_lam_polyvar.get_field  arg)
+     (E.poly_var_value_access  arg)
       )
       (** FIXME:
         1. duplicated evaluation of expressions arg
@@ -100,7 +100,7 @@ let eval_as_unwrap (arg : J.expression) : E.t =
   | Caml_block ([{expression_desc = Number _}; cb], _, _, _) ->
     cb
   | _ ->
-    Js_of_lam_polyvar.get_field arg 
+    E.poly_var_value_access arg 
 
 
 

jscomp/core/js_of_lam_polyvar.mli

@@ -45,7 +45,7 @@ let comment_of_tag_info  (x : Lam_tag_info.t) =
   | Blk_constructor {name = n} -> Some n 
   | Blk_tuple -> Some "tuple"
   | Blk_class -> Some "class"
-  | Blk_poly_var x -> Some ("`" ^  x)
+  | Blk_poly_var _ -> None
   | Blk_record _ -> None
   | Blk_record_inlined {name = ctor} -> Some ctor
   | Blk_record_ext _ -> None

jscomp/core/js_of_lam_variant.ml

@@ -129,12 +129,12 @@ let caml_hash (count : int) _limit (seed : nativeint)
         () 
       else 
         let size = Obj.size obj in 
-        if size <> 0 then         
+        if size <> 0 then begin        
           let obj_tag = Obj.tag obj in
           let tag = (size lsl 10) lor obj_tag in 
-          if tag = 248 (* Obj.object_tag*) then 
+          if obj_tag = 248 (* Obj.object_tag*) then 
             hash.contents <- caml_hash_mix_int hash.contents 
-              (Caml_nativeint_extern.of_int (Obj.obj (Obj.field obj 1) : int))
+                (Caml_nativeint_extern.of_int (Obj.obj (Obj.field obj 1) : int))
           else 
             begin 
               hash.contents <- caml_hash_mix_int hash.contents (Caml_nativeint_extern.of_int tag) ;
@@ -144,6 +144,18 @@ let caml_hash (count : int) _limit (seed : nativeint)
                 push_back queue (Obj.field obj i ) 
               done 
             end
+        end else
+          begin             
+            let size : int = ([%raw {|function(obj,cb){
+            var size = 0  
+            for(var k in obj){
+              cb(obj[k])
+              ++ size
+            }
+            return size
+          }|}] obj (fun [@bs] v -> push_back queue v ) [@bs]) in    
+            hash.contents <- caml_hash_mix_int hash.contents (Caml_nativeint_extern.of_int ((size lsl 10) lor 0)) (*tag*) ;
+          end
     done;
     caml_hash_final_mix hash.contents