Merge pull request #4409 from BuckleScript/variant_as_obj

variant as objects

Author: bobzhang

jscomp/core/js_block_runtime.ml

@@ -43,7 +43,6 @@ let tag_is_zero (tag : J.expression) =
   | Blk_class
   | Blk_array   
   | Blk_record_ext _ -> false
-  | Blk_extension_slot -> false 
   | Blk_na _ ->  not (tag_is_zero tag )
 
 let needBlockRuntime (tag : J.expression) (tag_info : J.tag_info) = 
@@ -62,7 +61,7 @@ let needBlockRuntime (tag : J.expression) (tag_info : J.tag_info) =
   | Blk_record_inlined _ 
   | Blk_constructor _   -> true  
   | Blk_record_ext _ 
-  | Blk_extension_slot -> false 
+   -> false 
     (* converted to [Pcreate_extension] in the beginning*)
 
 let option_id =   

jscomp/core/js_dump.ml

@@ -844,11 +844,10 @@ and expression_desc cxt ~(level:int) f x : cxt  =
   | Caml_block(el,_, _, Blk_module fields) ->        
       expression_desc cxt ~level f (Object (
         (Ext_list.map_combine fields el Ext_ident.convert)))
+  (*name convention of Record is slight different from modules*)        
   | Caml_block(el,_, _, Blk_record fields) ->        
-      expression_desc cxt ~level f (Object (
-        (List.combine (Array.to_list fields) el )))      
-        (* name convention of Record is slight different from modules 
-        *)
+      expression_desc cxt ~level f (Object ((Ext_list.combine_array fields el )))      
+        
   | Caml_block(el,_,_, Blk_poly_var name) ->
     begin match el with 
       | [hash;value] -> 
@@ -870,9 +869,39 @@ and expression_desc cxt ~(level:int) f x : cxt  =
       | _ -> 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)      
+    expression_desc cxt ~level f (exn_block_as_obj ~stack:false el ext)
+  | Caml_block(el,_,tag, (Blk_record_inlined p)) -> 
+    let objs = 
+      let tails =   
+        Ext_list.combine_array_append p.fields el      
+          (if !Js_config.debug then ["NAME",E.str p.name]
+           else []
+          ) in 
+      if p.num_nonconst = 1 then tails
+      else ("tag",
+        if !Js_config.debug then tag else {tag with comment = Some p.name}) :: tails in 
+    if p.num_nonconst = 1 && not !Js_config.debug then 
+      pp_comment_option f (Some p.name);
+    expression_desc cxt ~level f (Object objs)  
+  | Caml_block(el,_,tag, (Blk_constructor p)) -> 
+    let objs =     
+      let tails =   
+        Ext_list.mapi_append el (fun i e -> "_" ^ string_of_int i , e )
+          (if !Js_config.debug then 
+             ["NAME", E.str p.name]
+           else []) in         
+      if p.num_nonconst = 1 then       
+        tails
+      else         
+        ("tag",
+          if !Js_config.debug then tag else {tag with comment = Some p.name}) :: tails
+    in 
+    if p.num_nonconst = 1 && not !Js_config.debug then 
+      pp_comment_option f (Some p.name);
+    expression_desc cxt ~level f (Object objs)
   | Caml_block( el, mutable_flag, tag, tag_info)
     ->
+    pp_comment_option f (Lam_compile_util.comment_of_tag_info tag_info);
     (* Note that, if we ignore more than tag [0] we loose some information
        with regard tag  
 
@@ -937,7 +966,6 @@ and expression_desc cxt ~(level:int) f x : cxt  =
         | Blk_class
         | Blk_array
         | Blk_record_ext _
-        | Blk_extension_slot
         | Blk_na _
            ->           
           dbg_block_create f;
@@ -1007,7 +1035,7 @@ and expression_desc cxt ~(level:int) f x : cxt  =
 
   | Object lst ->    
     let action () =
-      if lst = [] then begin P.string f "{ }" ; cxt end else      
+      if lst = [] then begin P.string f "{}" ; cxt end else      
         P.brace_vgroup f 1 (fun _ ->
             property_name_and_value_list cxt f lst) in
     if level > 1 then

jscomp/core/js_exp_make.ml

@@ -131,14 +131,6 @@ let raw_js_code ?comment info s : t =
 let array ?comment mt es : t  = 
   {expression_desc = Array (es,mt) ; comment}
 
-let sep = " : "
-let merge_outer_comment comment (e : t )  = 
-  match e.comment with
-  | None -> {e with comment = Some comment}
-  | Some s -> { e with 
-                comment 
-                = Some (comment ^ sep ^ s)} 
-
 let some_comment = None
 
 let optional_block e  : J.expression =                 
@@ -178,29 +170,6 @@ let make_block ?comment
   (tag_info : J.tag_info) 
   (es : t list) 
   (mutable_flag : J.mutable_flag) : t = 
-  let comment = 
-    match comment with 
-    | None -> Lam_compile_util.comment_of_tag_info tag_info 
-    | _ -> comment in
-  let es = 
-    match tag_info with       
-    | Blk_record_inlined {fields = des}
-      -> 
-      Ext_list.mapi es (fun i e  -> merge_outer_comment des.(i) e) 
-    | Blk_record_ext _
-    | Blk_record _ 
-    | Blk_module _
-    | Blk_module_export
-    | Blk_tuple 
-    | Blk_array
-    | Blk_extension_slot 
-    | Blk_extension 
-    | Blk_class 
-    | Blk_constructor _ 
-    | Blk_poly_var _ 
-    | Blk_na _
-      ->  es
-  in
   {
     expression_desc = Caml_block( es, mutable_flag, tag,tag_info) ;
     comment 
@@ -284,14 +253,15 @@ let dummy_obj ?comment (info : Lam_tag_info.t)  : t =
   match info with
   | Blk_record _ 
   | Blk_module _ 
-    -> 
-    {comment ; expression_desc = Object ([])}
   | Blk_constructor _ 
-  | Blk_tuple | Blk_array
-  | Blk_poly_var _ | Blk_extension_slot 
-  | Blk_extension | Blk_na _ 
   | Blk_record_inlined _ 
+  | Blk_poly_var _ 
+  | Blk_extension 
   | Blk_record_ext _ 
+    -> 
+    {comment ; expression_desc = Object []}
+  | Blk_tuple | Blk_array  
+  | Blk_na _   
   | Blk_class | Blk_module_export 
     ->
     {comment  ; expression_desc = Array ([],Mutable)}
@@ -401,6 +371,9 @@ let record_access (e : t) (name : string) (pos : int32) =
     )
   | _ -> { expression_desc = Static_index (e, name, Some pos); comment = None} 
 
+(* The same as {!record_access} except tag*)
+let inline_record_access = record_access
+
 let poly_var_tag_access (e : t)  = 
   match e.expression_desc with
   | Caml_block (l,_, _, _) when no_side_effect e

jscomp/core/js_exp_make.mli

@@ -188,6 +188,13 @@ val record_access :
   Int32.t -> 
   t 
 
+val inline_record_access :   
+  t ->
+  string -> 
+  Int32.t -> 
+  t 
+
+
 val extension_access : 
   t ->
   string option -> 

jscomp/core/js_of_lam_block.ml

@@ -48,14 +48,11 @@ let make_block mutable_flag (tag_info : Lam_tag_info.t) tag args  =
   (*       (E.int  ?comment:(Lam_compile_util.comment_of_tag_info tag_info) tag   *)
   (*        :: args) *)
 
-let field (field_info : Lam_compat.field_dbg_info) e i =
+let field (field_info : Lam_compat.field_dbg_info) e (i : int32) =
   match field_info with 
   | Fld_na _
   | Fld_tuple  
 
-
-  | Fld_record_inline _
-  | Fld_variant
   | Fld_array
     -> 
     E.array_index_by_int  
@@ -68,6 +65,12 @@ let field (field_info : Lam_compat.field_dbg_info) e i =
     E.extension_access e (Some name) i
   | Fld_extension -> 
     E.extension_access e  None i    
+  | Fld_variant  
+    -> 
+    E.inline_record_access e 
+      ("_" ^ Int32.to_string i) i 
+  | Fld_record_inline {name}
+    -> E.inline_record_access e name i      
   | Fld_record {name}
     -> E.record_access e name i
   | Fld_module {name}
@@ -80,13 +83,10 @@ let set_field (field_info : Lam_compat.set_field_dbg_info) e i e0 =
     match field_info with 
     | Fld_set_na 
       -> E.assign_by_int e i e0
-    | Fld_record_inline_set comment
-
-      -> (* see GPR#631*)
-      E.assign_by_int ~comment e i e0 
     | Fld_record_extension_set name
       -> 
       E.extension_assign e i name e0
+    | Fld_record_inline_set name
     | Fld_record_set name -> 
       E.record_assign e i name e0
 

jscomp/core/js_pass_flatten_and_mark_dead.ml

@@ -228,11 +228,11 @@ let subst_map () = object (self)
                     (match tag_info with 
                      | Blk_module fields -> 
                        (match Ext_list.nth_opt fields i with 
-                        | None -> Printf.sprintf "%03d" i                      
+                        | None -> Printf.sprintf "%d" i                      
                         | Some x -> x )
                      | Blk_record fields ->    
-                      Ext_array.get_or fields i (fun _ -> Printf.sprintf "%03d" i)                     
-                     | _ -> Printf.sprintf "%03d" i    
+                      Ext_array.get_or fields i (fun _ -> Printf.sprintf "%d" i)                     
+                     | _ -> Printf.sprintf "%d" i    
                     )) in
                (i + 1, E.var match_id :: e, (match_id, v') :: acc))  in
       let e = 

jscomp/core/lam_compat.ml

@@ -95,48 +95,6 @@ let cmp_int (cmp : comparison) (a : int) b : bool =
   | Cge -> a >= b
 
 
-
-type bigarray_kind = Lambda.bigarray_kind = 
-    Pbigarray_unknown
-  | Pbigarray_float32 | Pbigarray_float64
-  | Pbigarray_sint8 | Pbigarray_uint8
-  | Pbigarray_sint16 | Pbigarray_uint16
-  | Pbigarray_int32 | Pbigarray_int64
-  | Pbigarray_caml_int | Pbigarray_native_int
-  | Pbigarray_complex32 | Pbigarray_complex64
-
-
-(* let eq_bigarray_kind (p : bigarray_kind) (p1 : bigarray_kind) = 
-  match p with   
-  | Pbigarray_unknown -> p1 = Pbigarray_unknown
-  | Pbigarray_float32 -> p1 = Pbigarray_float32
-  | Pbigarray_float64 -> p1 =  Pbigarray_float64
-  | Pbigarray_sint8 -> p1 = Pbigarray_sint8
-  | Pbigarray_uint8 -> p1 = Pbigarray_uint8
-  | Pbigarray_sint16 -> p1 = Pbigarray_sint16 
-  | Pbigarray_uint16 -> p1 = Pbigarray_uint16
-  | Pbigarray_int32  -> p1 = Pbigarray_int32
-  | Pbigarray_int64 -> p1 = Pbigarray_int64
-  | Pbigarray_caml_int -> p1 = Pbigarray_caml_int
-  | Pbigarray_native_int -> p1 = Pbigarray_native_int
-  | Pbigarray_complex32  -> p1 = Pbigarray_complex32
-  | Pbigarray_complex64 -> p1 = Pbigarray_complex64 *)
-  
-  
-type bigarray_layout = Lambda.bigarray_layout = 
-    Pbigarray_unknown_layout
-  | Pbigarray_c_layout
-  | Pbigarray_fortran_layout
-
-
-
-
-(* let eq_bigarray_layout (p : bigarray_layout) (p1 : bigarray_layout) = 
-  match p with 
-  | Pbigarray_unknown_layout -> p1 = Pbigarray_unknown_layout
-  | Pbigarray_c_layout -> p1 = Pbigarray_c_layout
-  | Pbigarray_fortran_layout -> p1 = Pbigarray_fortran_layout   *)
-
 type compile_time_constant =
     | Big_endian  
     | Ostype_unix
@@ -172,6 +130,7 @@ type field_dbg_info = Lambda.field_dbg_info =
   | Fld_extension
   | Fld_variant
   | Fld_array 
+  
 let str_of_field_info (x : field_dbg_info) : string option =  
   match x with 
   | Fld_na  s -> if s = "" then None else Some s

jscomp/core/lam_compat.mli

@@ -32,20 +32,7 @@ type boxed_integer = Lambda.boxed_integer =
 type comparison = Lambda.comparison = 
     Ceq | Cneq | Clt | Cgt | Cle | Cge
 
-type bigarray_kind = Lambda.bigarray_kind = 
-    Pbigarray_unknown
-  | Pbigarray_float32 | Pbigarray_float64
-  | Pbigarray_sint8 | Pbigarray_uint8
-  | Pbigarray_sint16 | Pbigarray_uint16
-  | Pbigarray_int32 | Pbigarray_int64
-  | Pbigarray_caml_int | Pbigarray_native_int
-  | Pbigarray_complex32 | Pbigarray_complex64
-
-
-type bigarray_layout = Lambda.bigarray_layout = 
-    Pbigarray_unknown_layout
-  | Pbigarray_c_layout
-  | Pbigarray_fortran_layout
+
 
 
 

jscomp/core/lam_compile.ml

@@ -362,7 +362,12 @@ and compile_recursive_let ~all_bindings
     Js_output.output_of_expression 
       (Declare (Alias, id))
        result ~no_effects:(lazy (Lam_analysis.no_side_effects arg)), []
-  | Lprim {primitive = Pmakeblock (0, tag_info, _) ; args =  ls}
+  | Lprim{primitive = Pmakeblock (_, _, _) ; args } 
+    when  args_either_function_or_const args -> 
+    compile_lambda
+    {cxt with continuation = Declare (Alias ,id)} arg, [] 
+    (* case of lazy blocks, treat it as usual *)
+  | Lprim {primitive = Pmakeblock (_, (Blk_record _ | Blk_constructor {num_nonconst = 1} | Blk_record_inlined {num_nonconst = 1} as tag_info) , _) ; args =  ls}
     when Ext_list.for_all ls (fun x ->
         match x with
         | Lvar pid ->
@@ -385,7 +390,9 @@ and compile_recursive_let ~all_bindings
              (Js_of_lam_block.set_field 
               (match tag_info with 
               | Blk_record xs -> Fld_record_set xs.(i)
-              | _ -> Fld_set_na) (E.var id)  (Int32.of_int i)                    
+              | Blk_record_inlined xs -> Fld_record_inline_set xs.fields.(i)
+              | Blk_constructor _ -> Fld_record_inline_set ("_" ^ string_of_int i)
+              | _ -> assert false) (E.var id)  (Int32.of_int i)                    
                 (match x with 
                  | Lvar lid  -> E.var lid
                  | Lconst x -> Lam_compile_const.translate x
@@ -394,8 +401,7 @@ and compile_recursive_let ~all_bindings
          ))
     ), []
 
-  | Lprim{primitive = Pmakeblock (_, tag_info, _) ; args } 
-    when  not (args_either_function_or_const args) ->
+  | Lprim{primitive = Pmakeblock (_, tag_info, _) ;  }  ->
 
     (* Lconst should not appear here if we do [scc]
        optimization, since it's faked recursive value,

jscomp/core/lam_compile_primitive.ml

@@ -603,18 +603,8 @@ let translate  loc
         (Blk_constructor {name = "Other"; num_nonconst = 1})
         [E.str "BS"] Immutable
      )
-  | Pduprecord (Record_regular| Record_extension) -> 
+  | Pduprecord (Record_regular| Record_extension| Record_inlined _ ) -> 
       Lam_dispatch_primitive.translate loc "caml_obj_dup" args
-  | Pduprecord ((
-                 Record_inlined {tag = 0; num_nonconsts = 1}
-                
-                )) -> 
-    (* _size is the length of all_lables*)
-    (* TODO: In debug mode, need switch to  *)
-    Lam_dispatch_primitive.translate loc "caml_array_dup" args
-  | Pduprecord (Record_inlined _)
-    -> 
-    Lam_dispatch_primitive.translate loc "caml_obj_dup" args
 
   | Plazyforce  
     (* FIXME: we don't inline lazy force or at least