Merge pull request #3799 from BuckleScript/fix_filed_info_missing_during_optimization

fix field info loss during optimizations, avoid depdency on cmi which is no longer necessary

Author: bobzhang

jscomp/core/lam_arity_analysis.ml

@@ -44,18 +44,18 @@ let rec get_arity (meta : Lam_stats.t) (lam : Lam.t) :  Lam_arity.t =
   | Lvar v -> arity_of_var meta v 
   | Lconst _ -> Lam_arity.non_function_arity_info
   | Llet(_,_,_, l ) -> get_arity meta l 
-  | Lprim {primitive = Pfield (n,_); 
-           args =  [ Lglobal_module id  ]; _} ->
-    begin match (Lam_compile_env.cached_find_ml_id_pos id n meta.env).arity with 
+  | Lprim {primitive = Pfield (_, Fld_module fld_name); 
+           args =  [ Lglobal_module id  ]; _} -> 
+    begin match (Lam_compile_env.cached_find_ml_id_pos id fld_name).arity with 
       | Single x -> x 
       | Submodule _ -> Lam_arity.na
     end
   | Lprim {primitive = Pfield (m,_); 
-           args =  [ Lprim{primitive = Pfield(n,_); 
+           args =  [ Lprim{primitive = Pfield(n,Fld_module fld_name); 
                            args = [ Lglobal_module id]}  ]
           ; _} ->
-    begin match (Lam_compile_env.cached_find_ml_id_pos id n meta.env).arity with 
-      | Submodule subs -> subs.(m)
+    begin match (Lam_compile_env.cached_find_ml_id_pos id fld_name ).arity with 
+      | Submodule subs -> subs.(m) (* TODO: shall we store it as array?*)
       | Single _ -> Lam_arity.na
     end
   (* TODO: all information except Pccall is complete, we could 

jscomp/core/lam_compile.ml

@@ -125,19 +125,17 @@ let rec
   compile_external_field (* Like [List.empty]*)
     (lamba_cxt : Lam_compile_context.t)
     (id : Ident.t)
-    (pos : int)
-    (env : Env.t)
+    pos
   : Js_output.t =  
-  match Lam_compile_env.cached_find_ml_id_pos id pos env  with      
+  match Lam_compile_env.cached_find_ml_id_pos id pos  with      
   | { closed_lambda = Some lam}
       when Lam_util.not_function lam
       ->
       compile_lambda lamba_cxt lam     
   | { name} ->
       Js_output.output_of_expression lamba_cxt.continuation  
       ~no_effects:no_effects_const
-      (if id.name = "Sys" && name = "os_type" then E.str Sys.os_type
-         else E.ml_var_dot id name )
+      (E.ml_var_dot id name )
 
 (* TODO: how nested module call would behave,
    In the future, we should keep in track  of if
@@ -169,11 +167,11 @@ let rec
 and compile_external_field_apply    
     (args_lambda : Lam.t list)
     (id : Ident.t)
-    (pos : int)
-    (env : Env.t) (lambda_cxt : Lam_compile_context.t): Js_output.t =
+    pos
+    (lambda_cxt : Lam_compile_context.t): Js_output.t =
 
   let ident_info =  
-    Lam_compile_env.cached_find_ml_id_pos id pos env in 
+    Lam_compile_env.cached_find_ml_id_pos id pos  in 
   let args_code, args =
       let dummy = [], [] in 
       if args_lambda = [] then dummy
@@ -1270,16 +1268,18 @@ and compile_apply
       compile_lambda  lambda_cxt (Lam.apply fn (Ext_list.append fn_args  args)  loc  App_na )
     (* External function calll *)
     | { fn =
-          Lprim{primitive = Pfield (n,_);
+          Lprim{primitive = Pfield (_, fld_info);
                 args = [  Lglobal_module id];_};
         args ;
         status = App_na | App_ml_full} ->
       (* Note we skip [App_js_full] since [get_exp_with_args] dont carry
          this information, we should fix [get_exp_with_args]
       *)
-      compile_external_field_apply  args id n  lambda_cxt.meta.env  lambda_cxt
-
-
+      begin match fld_info with 
+        | Fld_module fld_name -> 
+          compile_external_field_apply  args id fld_name  lambda_cxt
+        | _ -> assert false
+      end     
     | { fn; args = args_lambda;   status} ->
       (* TODO: ---
          1. check arity, can be simplified for pure expression
@@ -1342,9 +1342,15 @@ and compile_apply
              ) fn_code args)
 and compile_prim (prim_info : Lam.prim_info) (lambda_cxt : Lam_compile_context.t) =     
     match prim_info with 
-    | {primitive = Pfield (n,_); args = [ Lglobal_module id ]; _}
+    | {primitive = Pfield (_, fld_info); args = [ Lglobal_module id ]; _}
       -> (* should be before Lglobal_global *)
-      compile_external_field lambda_cxt id n lambda_cxt.meta.env
+      begin match fld_info with 
+      | Fld_module field -> 
+         if id.name = "Sys" && field = "os_type" then 
+          Js_output.output_of_expression lambda_cxt.continuation ~no_effects:no_effects_const (E.str Sys.os_type)
+         else compile_external_field lambda_cxt id field 
+      | _ -> assert false  
+      end
     | {primitive = Praise ; args =  [ e ]; _} ->      
       (match compile_lambda {lambda_cxt with  continuation = NeedValue Not_tail} e with
        | {block ; value =  Some v} ->

jscomp/core/lam_compile_env.ml

@@ -35,7 +35,6 @@ module S = Js_stmt_make
 type path = string 
 
 type ml_module_info = { 
-  signature : Ocaml_types.t;
   cmj_table : Js_cmj_format.t ;
   cmj_path : path;
 }
@@ -59,7 +58,6 @@ type env_value =
 type ident_info = {
   (* id : Ident.t; *)
   name : string;
-  signature : Ocaml_types.t;
   arity : Js_cmj_format.arity; 
   closed_lambda : Lam.t option 
 }
@@ -119,40 +117,29 @@ let add_js_module
 
 let (+>) = Lam_module_ident.Hash.add cached_tbl
 
-let cached_find_ml_id_pos (module_id : Ident.t) (pos : int) env : ident_info =
+let cached_find_ml_id_pos (module_id : Ident.t) name : ident_info =
   let oid  = Lam_module_ident.of_ml module_id in
   match Lam_module_ident.Hash.find_opt cached_tbl oid with 
   | None -> 
     let cmj_path, cmj_table = 
       Js_cmj_load.find_cmj (module_id.name ^ Literals.suffix_cmj) in
-    begin match
-        Ocaml_types.find_serializable_signatures_by_path module_id env with 
-    | None -> 
-      assert false (*TODO: more informative error message *)
-    | Some signature -> 
-      oid  +> Visit {signature;  cmj_table ; cmj_path  }  ;
-      let name =  Ocaml_types.get_name signature pos  in
-      let arity, closed_lambda =        
-        Js_cmj_format.query_by_name cmj_table name         
-      in
-      {
-       (* id;  *)
-       name ;
-       signature ;
-       arity ;
-       closed_lambda
-      }
-    end
-  | Some (Visit {signature ; cmj_table } )
+    oid  +> Visit {  cmj_table ; cmj_path  }  ;
+    let arity, closed_lambda =        
+      Js_cmj_format.query_by_name cmj_table name         
+    in
+    {
+      name ;
+      arity ;
+      closed_lambda
+    }
+    
+  | Some (Visit { cmj_table } )
     -> 
-    let name = Ocaml_types.get_name signature pos  in
     let arity , closed_lambda =  
       Js_cmj_format.query_by_name cmj_table name 
     in
     { 
-      (* id; *)
       name; 
-      signature;
       arity;
       closed_lambda
       (* TODO shall we cache the arity ?*) 
@@ -163,7 +150,6 @@ let cached_find_ml_id_pos (module_id : Ident.t) (pos : int) env : ident_info =
 
 
 type module_info = {
-  signature :  Ocaml_types.t ;
   pure : bool 
 }
 (* TODO: it does not make sense to cache
@@ -189,7 +175,7 @@ let query_and_add_if_not_exist
         oid +> Runtime (true,cmj_path,cmj_table) ; 
          (match env with 
           | Has_env _ -> 
-            found {signature = Ocaml_types.empty; pure = true}
+            found { pure = true}
           | No_env -> 
             found cmj_info)        
       | Ml 
@@ -202,8 +188,8 @@ let query_and_add_if_not_exist
                 Ocaml_types.find_serializable_signatures_by_path  oid.id env with 
             | None -> not_found () (* actually when [not_found] in the call site, we throw... *)
             | Some signature -> 
-              oid +> Visit {signature; cmj_table;cmj_path } ;
-              found  { signature ; pure = Js_cmj_format.is_pure cmj_table} 
+              oid +> Visit {cmj_table;cmj_path } ;
+              found  { pure = Js_cmj_format.is_pure cmj_table} 
             end
           | No_env -> 
             found cmj_info)
@@ -217,31 +203,31 @@ let query_and_add_if_not_exist
         begin match env with 
           | Has_env _ 
             -> 
-            found {signature = Ocaml_types.empty; pure = false}
+            found { pure = false}
           | No_env -> 
             found (Ext_string.empty, Js_cmj_format.no_pure_dummy)
             (* FIXME: #154, it come from External, should be okay *)
         end
 
     end
-  | Some (Visit {signature  ; cmj_table; cmj_path}) -> 
+  | Some (Visit { cmj_table; cmj_path}) -> 
     begin match env with 
       | Has_env _ -> 
-        found   { signature; pure = Js_cmj_format.is_pure cmj_table} 
+        found   { pure = Js_cmj_format.is_pure cmj_table} 
       | No_env  -> found (cmj_path,cmj_table)
     end
 
   | Some (Runtime (pure, cmj_path,cmj_table)) -> 
     begin match env with 
       | Has_env _ -> 
-        found {signature = Ocaml_types.empty; pure }
+        found {pure }
       | No_env -> 
         found (cmj_path, cmj_table) 
     end
   | Some External -> 
     begin match env with 
       | Has_env _ -> 
-        found {signature = Ocaml_types.empty; pure  = false}
+        found {pure  = false}
       | No_env -> 
         found (Ext_string.empty, Js_cmj_format.no_pure_dummy) (* External is okay *)
     end

jscomp/core/lam_compile_env.mli

@@ -38,7 +38,6 @@ type path = string
 
 
 type module_info = {
-  signature :  Ocaml_types.t ;
   pure : bool 
 }
 
@@ -49,7 +48,6 @@ type _ t =
 
 type ident_info = {
   name : string;
-  signature : Ocaml_types.t;
   arity : Js_cmj_format.arity;
   closed_lambda : Lam.t option 
 }  
@@ -98,8 +96,7 @@ val add_js_module :
 *)
 val cached_find_ml_id_pos : 
   Ident.t ->
-  int -> 
-  Env.t -> 
+  string -> 
   ident_info
 
 val query_and_add_if_not_exist : 

jscomp/core/lam_pass_remove_alias.ml

@@ -81,21 +81,15 @@ let simplify_alias
         for the inner expression
     *)
 
-    | Lprim {primitive = (Pfield (i,_) as primitive); args =  [arg]; loc} -> 
+    | Lprim {primitive = (Pfield (i,info) as primitive); args =  [arg]; loc} -> 
       (* ATTENTION: 
          Main use case, we should detect inline all immutable block .. *)
-      begin match  simpl  arg with 
-        | Lglobal_module g 
-          ->    
-          Lam.prim 
-            ~primitive:(Pfield(i,Lam_compat.Fld_na))
-            ~args:[Lam.global_module g ]
-            loc
+      begin match  simpl  arg with     
         | Lvar v as l-> 
           Lam_util.field_flatten_get (fun _ -> Lam.prim ~primitive ~args:[l] loc )
-            v  i meta.ident_tbl 
-        | _ ->  
-          Lam.prim ~primitive ~args:[simpl arg] loc 
+            v  i info meta.ident_tbl 
+        | l ->  
+          Lam.prim ~primitive ~args:[l] loc 
       end
     | Lprim {primitive = Pval_from_option | Pval_from_option_not_nest; args = [Lvar v]} as x -> 
       begin match Ident_hashtbl.find_opt meta.ident_tbl v with 
@@ -156,12 +150,12 @@ let simplify_alias
       return [0, $$let[5],... $$let[16]]}
     *)      
     | Lapply{fn = 
-               Lprim {primitive = Pfield (index, _) ;
+               Lprim {primitive = Pfield (index, Fld_module fld_name) ;
                       args = [ Lglobal_module ident ];
                       _} as l1;
              args; loc ; status} ->
       begin
-        match  Lam_compile_env.cached_find_ml_id_pos ident index meta.env with                   
+        match  Lam_compile_env.cached_find_ml_id_pos ident fld_name with                   
         | {closed_lambda=Some Lfunction{params; body; _} } 
           (** be more cautious when do cross module inlining *)
           when

jscomp/core/lam_print.ml

@@ -149,7 +149,10 @@ let primitive ppf (prim : Lam_primitive.t) = match prim with
   (* | Psetglobal id -> fprintf ppf "setglobal %a" Ident.print id *)
   | Pmakeblock(tag, _, Immutable) -> fprintf ppf "makeblock %i" tag
   | Pmakeblock(tag, _, Mutable) -> fprintf ppf "makemutable %i" tag
-  | Pfield (n,_) -> fprintf ppf "field %i" n
+  | Pfield (n, (Fld_module s | Fld_record s)) 
+    -> fprintf ppf "field %s/%i" s n
+  | Pfield (n, Fld_na) 
+    -> fprintf ppf "field %i" n
   | Pfield_computed -> 
     fprintf ppf "field_computed"
   | Psetfield_computed -> 

jscomp/core/lam_util.ml

@@ -192,10 +192,10 @@ let kind_of_lambda_block (xs : Lam.t list) : Lam_id_kind.t =
     element_of_lambda x ))
 
 let field_flatten_get
-   lam v i (tbl : Lam_id_kind.t Ident_hashtbl.t) : Lam.t =
+   lam v i info (tbl : Lam_id_kind.t Ident_hashtbl.t) : Lam.t =
   match Ident_hashtbl.find_opt tbl v  with 
   | Some (Module g) -> 
-    Lam.prim ~primitive:(Pfield (i, Lam_compat.Fld_na)) 
+    Lam.prim ~primitive:(Pfield (i, info)) 
       ~args:[ Lam.global_module g ] Location.none
   | Some (ImmutableBlock (arr)) -> 
     begin match arr.(i) with 

jscomp/core/lam_util.mli

@@ -50,7 +50,7 @@ val kind_of_lambda_block : Lam.t list -> Lam_id_kind.t
     }}
 *)
 val field_flatten_get : 
-  (unit -> Lam.t) -> Ident.t -> int -> Lam_stats.ident_tbl -> Lam.t
+  (unit -> Lam.t) -> Ident.t -> int -> Lambda.field_dbg_info -> Lam_stats.ident_tbl -> Lam.t