pass lambda tag_info as is

Author: bobzhang

jscomp/core/js_dump.ml

@@ -117,7 +117,7 @@ let exn_block_as_obj
         | i ->  
           "_" ^ string_of_int i
       )
-    | Blk_record_ext ss ->   
+    | Blk_record_ext {fields = ss} ->   
       (fun i ->  
          match i with 
          | 0 -> Literals.exception_id
@@ -167,7 +167,7 @@ let exp_need_paren  (e : J.expression) =
 
   | Raw_js_code {code_info = Exp _}
   | Fun _ 
-  | Caml_block (_,_,_, (Blk_record _ | Blk_module _ | Blk_poly_var  | Blk_extension | Blk_record_ext _ | Blk_record_inlined _ | Blk_constructor _ ))
+  | Caml_block (_,_,_, (Blk_record _ | Blk_module _ | Blk_poly_var _  | Blk_extension | Blk_record_ext _ | Blk_record_inlined _ | Blk_constructor _ ))
   | Object _ -> true
   | Raw_js_code {code_info = Stmt _ }
   | Length _
@@ -804,14 +804,14 @@ and expression_desc cxt ~(level:int) f x : cxt  =
            fields el 
            (fun  x -> Js_op.Lit (Ext_ident.convert x) ))))
   (*name convention of Record is slight different from modules*)        
-  | Caml_block(el,mutable_flag, _, Blk_record fields) ->  
+  | Caml_block(el,mutable_flag, _, Blk_record {fields}) ->  
     if Ext_array.for_alli fields (fun i v -> string_of_int i = v) then 
       expression_desc cxt ~level f  (Array (el, mutable_flag))
     else      
       expression_desc cxt ~level f (Object 
                                       ((Ext_list.combine_array fields el  (fun i -> Js_op.Lit i))))      
 
-  | Caml_block(el,_,_, Blk_poly_var ) ->
+  | Caml_block(el,_,_, Blk_poly_var _) ->
     begin match el with 
       | [tag;value] -> 
         expression_desc 
@@ -863,8 +863,8 @@ and expression_desc cxt ~(level:int) f x : cxt  =
        && not_is_cons then 
       pp_comment_option f (Some p.name);
     expression_desc cxt ~level f (Object objs)
-  | Caml_block ( _, _, _, (Blk_module_export  )) -> assert false
-  | Caml_block( el, mutable_flag, _tag, (Blk_tuple  | Blk_array  ))
+  | Caml_block ( _, _, _, (Blk_module_export _  | Blk_some | Blk_some_not_nested | Blk_lazy_general)) -> assert false
+  | Caml_block( el, mutable_flag, _tag, (Blk_tuple    ))
     ->
     expression_desc cxt ~level f  (Array (el, mutable_flag))
 

jscomp/core/js_exp_make.ml

@@ -264,17 +264,19 @@ let dummy_obj ?comment (info : Lam_tag_info.t)  : t =
   | Blk_module _ 
   | Blk_constructor _ 
   | Blk_record_inlined _ 
-  | Blk_poly_var  
+  | Blk_poly_var  _
   | Blk_extension 
   | Blk_record_ext _ 
     -> 
     {comment ; expression_desc = Object []}
-  | Blk_tuple | Blk_array  
+  | Blk_tuple 
 
-  | Blk_module_export 
+  | Blk_module_export _
     ->
     {comment  ; expression_desc = Array ([],Mutable)}
-
+  | Blk_some 
+  | Blk_some_not_nested 
+  | Blk_lazy_general -> assert false 
 
 (* TODO: complete 
     pure ...

jscomp/core/js_of_lam_block.ml

@@ -37,7 +37,7 @@ module E = Js_exp_make
 let make_block mutable_flag (tag_info : Lam_tag_info.t) tag args  = 
 
   match tag_info with
-  | Blk_array -> Js_of_lam_array.make_array mutable_flag  args
+
   |  _ -> E.make_block tag tag_info args mutable_flag
 (* | _, (  Tuple | Variant _ ) -> (\** TODO: check with inline record *\) *)
 (*     E.arr Immutable *)

jscomp/core/js_of_lam_variant.ml

@@ -53,7 +53,7 @@ let eval (arg : J.expression) (dispatches : (string * string) list ) : E.t =
 (* arg is a polyvar *)
 let eval_as_event (arg : J.expression) (dispatches : (string * string) list option) =
   match arg.expression_desc with
-  | Caml_block([{expression_desc = Str(_,s)}; cb], _, _, Blk_poly_var ) when Js_analyzer.no_side_effect_expression cb 
+  | Caml_block([{expression_desc = Str(_,s)}; cb], _, _, Blk_poly_var _ ) when Js_analyzer.no_side_effect_expression cb 
     -> 
     let v = 
       match dispatches with 

jscomp/core/js_pass_flatten_and_mark_dead.ml

@@ -197,7 +197,7 @@ let subst_map (substitution : J.expression Hash_ident.t) = { super
                                                                                    (match Ext_list.nth_opt fields i with 
                                                                                     | None -> Printf.sprintf "%d" i                      
                                                                                     | Some x -> x )
-                                                                                 | Blk_record fields ->    
+                                                                                 | Blk_record {fields} ->    
                                                                                    Ext_array.get_or fields i (fun _ -> Printf.sprintf "%d" i)                     
                                                                                  | _ -> Printf.sprintf "%d" i    
                                                                                 )) in

jscomp/core/lam_compile.ml

@@ -389,7 +389,7 @@ and compile_recursive_let ~all_bindings
            S.exp
              (Js_of_lam_block.set_field 
                 (match tag_info with 
-                 | Blk_record xs -> Fld_record_set xs.(i)
+                 | Blk_record {fields = xs} -> Fld_record_set xs.(i)
                  | Blk_record_inlined xs -> Fld_record_inline_set xs.fields.(i)
                  | Blk_constructor p -> 
                    let is_cons = p.name = Literals.cons in 

jscomp/core/lam_compile_primitive.ml

@@ -487,7 +487,7 @@ let translate  loc
      | Backend_type  -> 
        E.make_block
          E.zero_int_literal 
-         (Blk_constructor {name = "Other"; num_nonconst = 1})
+         (Blk_constructor {name = "Other"; num_nonconst = 1; tag = 0})
          [E.str "BS"] Immutable
     )
   | Pduprecord (Record_regular| Record_extension| Record_inlined _ ) -> 

jscomp/core/lam_compile_util.ml

@@ -44,21 +44,16 @@ let comment_of_tag_info  (x : Lam_tag_info.t) =
   match x with 
   | Blk_constructor {name = n} -> Some n 
   | Blk_tuple -> Some "tuple"
-  | Blk_poly_var  -> None
+  | Blk_poly_var _ -> None
   | Blk_record _ -> None
   | Blk_record_inlined {name = ctor} -> Some ctor
   | Blk_record_ext _ -> None
-  | Blk_array -> 
-    (* so far only appears in {!Translclass} 
-       and some constant immutable array block
-    *)
-    Some "array"
-  | Blk_module_export
+  | Blk_module_export _
   | Blk_module _ ->  
     (* Turn it on next time to save some noise diff*)
     None
   | Blk_extension (* TODO: enhance it later *)
     -> None
 
-
+  | Blk_some | Blk_some_not_nested | Blk_lazy_general -> assert false
 (* let module_alias = Some "alias"   *)

jscomp/core/lam_constant_convert.ml

@@ -65,47 +65,28 @@ let rec convert_constant ( const : Lambda.structured_constant) : Lam_constant.t
         Const_some (convert_constant (Ext_list.singleton_exn xs))
       | Blk_some -> 
         Const_some (convert_constant (Ext_list.singleton_exn xs))        
-      | Blk_constructor{name ; num_nonconst } ->   
-        let t : Lam_tag_info.t = Blk_constructor {name; num_nonconst} in 
-        Const_block (tag,t, Ext_list.map xs convert_constant )
-      | Blk_tuple ->   
-        let t : Lam_tag_info.t = Blk_tuple in 
+      | Blk_constructor _ 
+      | Blk_tuple 
+      | Blk_record _
+      | Blk_module _ 
+      | Blk_module_export _
+      | Blk_extension
+      | Blk_record_inlined _
+      | Blk_record_ext _ 
+        -> 
         Const_block (tag,t, Ext_list.map xs convert_constant )
       | Blk_poly_var s -> 
         begin match xs with 
           | [_; value] -> 
-            let t : Lam_tag_info.t = Blk_poly_var  in 
             let tag_val : Lam_constant.t = 
               if Ext_string.is_valid_hash_number s then Const_int {i = Ext_string.hash_number_as_i32_exn s; comment = None}
               else Const_string s in 
             Const_block (tag,t, [tag_val; convert_constant value] )      
           | _ -> assert false  
         end
-      | Blk_record {fields = s} -> 
-        let t : Lam_tag_info.t = Blk_record s in 
-        Const_block (tag,t, Ext_list.map xs convert_constant )
-      | Blk_module s -> 
-        let t : Lam_tag_info.t = Blk_module s in 
-        Const_block (tag,t, Ext_list.map xs convert_constant )    
-      | Blk_module_export _ -> 
-        let t : Lam_tag_info.t = Blk_module_export in 
-        Const_block (tag,t, Ext_list.map xs convert_constant )     
-      | Blk_extension_slot -> assert false 
-      (* let t : Lam_tag_info.t = Blk_extension_slot in 
-         Const_block (i,t, Ext_list.map xs convert_constant )       *)
-      | Blk_extension ->   
-        let t : Lam_tag_info.t = Blk_extension in 
-        Const_block (tag,t, Ext_list.map xs convert_constant )      
       | Blk_lazy_general 
         -> assert false
 
-      | Blk_record_inlined {name;fields;num_nonconst}  -> 
-        let t : Lam_tag_info.t = Blk_record_inlined {name;fields;num_nonconst} in 
-        Const_block (tag,t, Ext_list.map xs convert_constant )      
-      | Blk_record_ext {fields = s} -> 
-        let t : Lam_tag_info.t = Blk_record_ext s in 
-        Const_block(tag,t, Ext_list.map xs convert_constant)
-
     end
 
 

jscomp/core/lam_convert.ml

@@ -33,12 +33,11 @@ let lam_extension_id loc (head : Lam.t) =
   prim ~primitive:lam_caml_id ~args:[head] loc    
 
 let lazy_block_info : Lam_tag_info.t = 
-  Blk_record 
-    [|Literals.lazy_done; 
-      Literals.lazy_val|]  
-
-let unbox_extension info (args : Lam.t list) mutable_flag loc =
-  prim ~primitive:(Pmakeblock (0,info,mutable_flag)) ~args loc 
+  Blk_record {
+      fields = [|Literals.lazy_done; Literals.lazy_val|]  ; 
+      mutable_flag = Mutable; 
+      record_repr = Record_regular
+  }
 
 
 (** A conservative approach to avoid packing exceptions
@@ -214,6 +213,8 @@ let lam_prim ~primitive:( p : Lambda.primitive) ~args loc : Lam.t =
   | Pbytes_to_string (* handled very early *)
     -> prim ~primitive:Pbytes_to_string ~args loc
   | Pbytes_of_string -> prim ~primitive:Pbytes_of_string ~args loc
+  | Pcreate_extension s ->  
+    prim ~primitive:(Pcreate_extension s) ~args loc
   | Pignore -> (* Pignore means return unit, it is not an nop *)
     seq (Ext_list.singleton_exn args) unit 
   | Pgetglobal _ ->
@@ -233,43 +234,19 @@ let lam_prim ~primitive:( p : Lambda.primitive) ~args loc : Lam.t =
       | Blk_some 
         ->    
         prim ~primitive:Psome ~args loc 
-      | Blk_constructor{name ; num_nonconst } ->  
-        let info : Lam_tag_info.t = Blk_constructor {name; num_nonconst} in
-        prim ~primitive:(Pmakeblock (tag,info,mutable_flag)) ~args loc
-      | Blk_tuple  -> 
-        let info : Lam_tag_info.t = Blk_tuple in
-        prim ~primitive:(Pmakeblock (tag,info,mutable_flag)) ~args loc
-      | Blk_extension  -> 
-        let info : Lam_tag_info.t = Blk_extension in
-        unbox_extension info args mutable_flag loc 
-      | Blk_record_ext {fields = s} ->
-        let info : Lam_tag_info.t = Blk_record_ext s in
-        unbox_extension info args mutable_flag loc 
-      | Blk_extension_slot -> 
-        ( 
-          match args with 
-          | [ Lconst (Const_string name)] -> 
-            prim ~primitive:(Pcreate_extension name) ~args:[] loc
-          | _ ->
-            assert false
-        )
-
-      | Blk_record {fields = s} -> 
-        let info : Lam_tag_info.t = Blk_record s in
-        prim ~primitive:(Pmakeblock (tag,info,mutable_flag)) ~args loc    
-      | Blk_record_inlined {name; fields; num_nonconst} ->
-        let info : Lam_tag_info.t = Blk_record_inlined {name; fields; num_nonconst} in
-        prim ~primitive:(Pmakeblock (tag,info,mutable_flag)) ~args loc
-      | Blk_module s -> 
-        let info : Lam_tag_info.t = Blk_module s in
+      | Blk_constructor _ 
+      | Blk_tuple  
+      | Blk_record _ 
+      | Blk_record_inlined _ 
+      | Blk_module _ 
+      | Blk_module_export _
+      | Blk_extension  
+      | Blk_record_ext _ 
+        ->         
         prim ~primitive:(Pmakeblock (tag,info,mutable_flag)) ~args loc
-      | Blk_module_export _ -> 
-        let info : Lam_tag_info.t = Blk_module_export in
-        prim ~primitive:(Pmakeblock (tag,info,mutable_flag)) ~args loc  
       | Blk_poly_var s -> 
         begin match args with 
           | [_; value] -> 
-            let info : Lam_tag_info.t = Blk_poly_var  in
             let tag_val : Lam_constant.t = 
               if Ext_string.is_valid_hash_number s then Const_int {i = Ext_string.hash_number_as_i32_exn s; comment = None}
               else Const_string s in 
@@ -647,7 +624,7 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : Lam.t * Lam_module_i
         | "#apply7"
         | "#apply8" -> Pjs_apply
         | "#makemutablelist" ->
-          Pmakeblock(0, Blk_constructor{name = "::"; num_nonconst = 1},Mutable)
+          Pmakeblock(0, Blk_constructor{name = "::"; num_nonconst = 1; tag = 0},Mutable)
         | "#undefined_to_opt" -> Pundefined_to_opt
         | "#nullable_to_opt" -> Pnull_undefined_to_opt
         | "#null_to_opt" -> Pnull_to_opt

jscomp/core/lam_tag_info.ml

@@ -27,14 +27,4 @@
    it reduces some branches e.g, 
    [Blk_some], [Blk_some_not_nested]
 *)
-type t =   
-  | Blk_tuple
-  | Blk_array
-  | Blk_poly_var
-  | Blk_record of string array 
-  | Blk_module of string list
-  | Blk_extension
-  | Blk_record_ext of string array
-  | Blk_record_inlined of { name : string ; num_nonconst : int; fields : string array }
-  | Blk_constructor of {name : string ; num_nonconst : int}
-  | Blk_module_export
+type t = Lambda.tag_info

jscomp/core/record_attributes_check.ml

@@ -43,18 +43,18 @@ let find_name_with_loc (attr : Parsetree.attribute) :
 
 let fld_record (lbl : label) = 
   Lambda.Fld_record
-    {name = Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name; mutable_flag = lbl.Types.lbl_mut}
+    {name = Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name; mutable_flag = lbl.lbl_mut}
 
 let fld_record_set (lbl : label) = 
   Lambda.Fld_record_set 
     (Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name)
 
-let blk_record  fields mut = 
+let blk_record  (fields : (label * _) array) mut record_repr = 
   let all_labels_info = 
     Ext_array.map fields   
-      (fun ((lbl : label),_) -> 
-         Ext_list.find_def lbl.Types.lbl_attributes find_name lbl.lbl_name) in  
-  Lambda.Blk_record {fields = all_labels_info ; mutable_flag = mut}
+      (fun (lbl,_) -> 
+         Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name) in  
+  Lambda.Blk_record {fields = all_labels_info ; mutable_flag = mut; record_repr}
 
 let check_bs_attributes_inclusion
     (attrs1 : Parsetree.attributes)

jscomp/ml/lambda.ml

@@ -34,15 +34,19 @@ type loc_kind =
   | Loc_LOC
   | Loc_POS
 
+type record_repr = 
+  | Record_regular 
+  | Record_object 
+
 type tag_info = 
   | Blk_constructor of {name : string ; num_nonconst : int ; tag : int }
   | Blk_record_inlined of { name : string ; num_nonconst :  int;  tag : int; fields : string array; mutable_flag : mutable_flag }   
   | Blk_tuple
   | Blk_poly_var of string 
-  | Blk_record of {fields : string array; mutable_flag : mutable_flag}  
+  | Blk_record of {fields : string array; mutable_flag : mutable_flag; record_repr : record_repr}  
   | Blk_module of string list
   | Blk_module_export of Ident.t list
-  | Blk_extension_slot
+
   | Blk_extension  
   | Blk_some
   | Blk_some_not_nested (* ['a option] where ['a] can not inhabit a non-like value *)
@@ -58,7 +62,6 @@ let tag_of_tag_info (tag : tag_info ) =
   | Blk_record _ 
   | Blk_module _ 
   | Blk_module_export _ 
-  | Blk_extension_slot (* tag not make sense  248 *)
   | Blk_extension 
   | Blk_some (* tag not make sense *)
   | Blk_some_not_nested (* tag not make sense *)
@@ -77,14 +80,13 @@ let mutable_flag_of_tag_info (tag : tag_info) =
   | Blk_poly_var _ 
   | Blk_module _
   | Blk_module_export _ 
-  | Blk_extension_slot
   | Blk_extension
   | Blk_some_not_nested
   | Blk_some 
    -> Immutable
 
 
-let blk_record = ref (fun _ _ -> 
+let blk_record = ref (fun _ _ _ -> 
   assert false
   )
 
@@ -99,7 +101,8 @@ let blk_record_inlined = ref (fun fields name num_nonconst ~tag mutable_flag ->
   Blk_record_inlined {fields; name; num_nonconst; tag; mutable_flag}
 ) 
 
-let ref_tag_info : tag_info = Blk_record {fields = [| "contents" |]; mutable_flag = Mutable}
+let ref_tag_info : tag_info = 
+  Blk_record {fields = [| "contents" |]; mutable_flag = Mutable; record_repr = Record_regular}
 
 type field_dbg_info = 
   | Fld_record of {name : string; mutable_flag : Asttypes.mutable_flag}
@@ -214,6 +217,7 @@ type primitive =
   (* Inhibition of optimisation *)
   | Popaque
   | Puncurried_apply
+  | Pcreate_extension of string
 and comparison =
     Ceq | Cneq | Clt | Cgt | Cle | Cge