enhance cross module inlining, add a stream test case

jscomp/compiler.mllib

@@ -32,6 +32,7 @@ lam_compile_env
 lam_dispatch_primitive
 lam_stats
 lam_stats_util
+lam_stats_export
 lam_util
 lam_pass_alpha_conversion
 lam_pass_remove_alias

jscomp/lam_analysis.ml

@@ -457,3 +457,20 @@ let is_closed  lam =
   Ident_map.for_all (fun k _ -> Ident.global k)
     (free_variables Ident_set.empty Ident_map.empty lam)  
 
+
+let is_closed_with_map exports params body = 
+  let param_map = free_variables exports (param_map_of_list params) body in
+  let old_count = List.length params in
+  let new_count = Ident_map.cardinal param_map in
+  (old_count  = new_count, param_map)
+
+
+
+(* TODO:  We can relax this a bit later,
+    but decide whether to inline it later in the call site
+ *)
+let safe_to_inline (lam : Lambda.lambda) = 
+  match lam with 
+  | Lfunction _ ->  true
+  | Lconst (Const_pointer _  | Const_immstring _ ) -> true
+  | _ -> false

jscomp/lam_analysis.mli

@@ -41,7 +41,6 @@ val is_closed : Lambda.lambda -> bool
 
 
 
-
 type stats = 
   { 
     mutable top : bool ; 
@@ -57,6 +56,10 @@ type stats =
     mutable times : int ; 
   }
 
+val is_closed_with_map : 
+  Ident_set.t ->
+  Ident.t list -> Lambda.lambda -> bool * stats Ident_map.t
+
 val param_map_of_list : Ident.t list -> stats Ident_map.t
 
 val free_variables : Ident_set.t -> stats Ident_map.t -> Lambda.lambda -> stats Ident_map.t
@@ -65,3 +68,4 @@ val small_inline_size : int
 val exit_inline_size : int 
 
 
+val safe_to_inline : Lambda.lambda -> bool

jscomp/lam_beta_reduce.mli

@@ -50,8 +50,15 @@ val refresh :
   Lambda.lambda -> 
   Lambda.lambda 
 
+(** 
+   {[ Lam_beta_reduce.propogate_beta_reduce_with_map meta param_map params body args]}
+   [param_map] collect the usage of parameters, 
+   it can be  produced by 
+   {[!Lam_analysis.free_variables meta.export_idents 
+       (Lam_analysis.param_map_of_list params) body]}
+*)
 val propogate_beta_reduce_with_map : 
   Lam_stats.meta ->
   Lam_analysis.stats Ident_map.t ->
-  Ident_map.key list ->
+  Ident.t list ->
   Lambda.lambda -> Lambda.lambda list -> Lambda.lambda

jscomp/lam_compile.ml

@@ -75,7 +75,26 @@ let rec
              it is very small             
              TODO: add comment here, we should try to add comment for 
              cross module inlining             
-          *)              
+
+             if we do too agressive inlining here: 
+
+             if we inline {!List.length} which will call {!A_list.length}, 
+             then we if we try inline {!A_list.length}, this means if {!A_list} 
+             is rebuilt, this module should also be rebuilt,
+
+             But if the build system is content-based, suppose {!A_list} 
+             is changed, cmj files in {!List} is unchnaged, however, 
+             {!List.length} call {!A_list.length} which is changed, since
+             [ocamldep] only detect that we depend on {!List}, it will not 
+             get re-built, then we are screwed.                   
+
+             This is okay for stamp based build system.
+
+             Another solution is that we add dependencies in the compiler
+
+             -: we should not do functor application inlining in a 
+                non-toplevel, it will explode code very quickly              
+          *)               
           ->  
           compile_lambda cxt lam
         | _ -> 
@@ -100,25 +119,6 @@ let rec
 
 and get_exp_with_args (cxt : Lam_compile_defs.cxt)  lam args_lambda
     (id : Ident.t) (pos : int) env : Js_output.t = 
-  let args_code, args = 
-    List.fold_right 
-      (fun (x : Lambda.lambda) (args_code, args)  ->
-         match x with 
-         | Lprim (Pgetglobal i, [] ) -> 
-           (* when module is passed as an argument - unpack to an array
-               for the function, generative module or functor can be a function,
-               however it can not be global -- global can only module
-           *)
-
-           args_code, (Lam_compile_global.get_exp (i, env, true) :: args)
-         | _ -> 
-           begin match compile_lambda {cxt with st = NeedValue; should_return = False} x with
-             | {block = a; value = Some b} -> 
-               (a @ args_code), (b :: args )
-             | _ -> assert false
-           end
-      ) args_lambda ([], []) in
-
   Lam_compile_env.find_and_add_if_not_exist (id,pos) env ~not_found:(fun id -> 
       (** This can not happen since this id should be already consulted by type checker 
           Worst case 
@@ -127,26 +127,50 @@ and get_exp_with_args (cxt : Lam_compile_defs.cxt)  lam args_lambda
           ]}
           shift by one (due to module encoding)
       *)
-      Js_output.handle_block_return cxt.st cxt.should_return lam args_code @@ 
-      E.str ~pure:false  (Printf.sprintf "Err %s %d %d"
-                            id.name
-                            id.flags
-                            pos
-                         ))
+      (* Js_output.handle_block_return cxt.st cxt.should_return lam args_code @@  *)
+      (* E.str ~pure:false  (Printf.sprintf "Err %s %d %d" *)
+      (*                       id.name *)
+      (*                       id.flags *)
+      (*                       pos *)
+      (*                    ) *)
+      assert false 
+    )
 
     ~found:(fun {id; name;arity; closed_lambda ; _} -> 
+        let args_code, args = 
+          List.fold_right 
+            (fun (x : Lambda.lambda) (args_code, args)  ->
+               match x with 
+               | Lprim (Pgetglobal i, [] ) -> 
+                 (* when module is passed as an argument - unpack to an array
+                     for the function, generative module or functor can be a function,
+                     however it can not be global -- global can only module
+                 *)
+
+                 args_code, (Lam_compile_global.get_exp (i, env, true) :: args)
+               | _ -> 
+                 begin match compile_lambda {cxt with st = NeedValue; should_return = False} x with
+                   | {block = a; value = Some b} -> 
+                     (a @ args_code), (b :: args )
+                   | _ -> assert false
+                 end
+            ) args_lambda ([], []) in
+
+
         match closed_lambda with 
         | Some (Lfunction (_, params, body)) 
           when Ext_list.same_length params args_lambda -> 
+          (* TODO: serialize it when exporting to save compile time *)
+          let (_, param_map)  = 
+            Lam_analysis.is_closed_with_map Ident_set.empty params body in
           compile_lambda cxt 
-            (Lam_beta_reduce.propogate_beta_reduce cxt.meta params body args_lambda)
+            (Lam_beta_reduce.propogate_beta_reduce_with_map cxt.meta param_map
+               params body args_lambda)
         | _ ->  
           Js_output.handle_block_return cxt.st cxt.should_return lam args_code @@ 
           (match id, name,  args with 
            | {name = "Pervasives"; _}, "^", [ e0 ; e1] ->  
              E.string_append e0 e1 
-           | {name = "Pervasives"; _}, "string_of_int", [e] 
-             -> E.int_to_string e 
            | {name = "Pervasives"; _}, "print_endline", ([ _ ] as args) ->  
              E.seq (E.dump Log args) (E.unit ())
            | {name = "Pervasives"; _}, "prerr_endline", ([ _ ] as args) ->  

jscomp/lam_compile_group.ml

@@ -182,10 +182,9 @@ let compile  ~filename non_export env _sigs lam   =
     let lam = Lam_pass_remove_alias.simplify_alias meta lam  in
     let lam = Lam_group.deep_flatten lam in
     let ()  = Lam_pass_collect.collect_helper meta lam in
-    let () = ignore @@ _d lam  in
-
     let lam = 
       lam
+      |> _d
       |> Lam_pass_alpha_conversion.alpha_conversion meta
       |> Lam_pass_exits.simplify_exits in    
     let () = Lam_pass_collect.collect_helper meta lam in
@@ -215,19 +214,39 @@ let compile  ~filename non_export env _sigs lam   =
 
   begin 
     match (lam : Lambda.lambda) with
-    | Lprim(Psetglobal id, [biglambda])  (* ATT: might be wrong in toplevel *) ->
+    | Lprim(Psetglobal id, [biglambda])
+      -> 
+      (* Invariant: The last one is always [exports]
+         Compile definitions
+         Compile exports
+         Assume Pmakeblock(_,_),
+         lambda_exports are pure
+         compile each binding with a return value
+         This might be wrong in toplevel
+      *)
+
       begin 
         match Lam_group.flatten [] biglambda with 
         | Lprim( (Pmakeblock (_,_,_), lambda_exports)),  rest ->
-          let coercion_groups, new_exports = 
+          let coercion_groups, new_exports, new_export_set,  export_map = 
             if non_export then 
-              [], []
+              [], [], Ident_set.empty, Ident_map.empty
             else
               List.fold_right2 
-                (fun  eid lam (coercions, new_exports) ->
+                (fun  eid lam (coercions, new_exports, new_export_set,  export_map) ->
                    match (lam : Lambda.lambda) with 
-                   | Lvar id when Ident.name id = Ident.name eid -> 
-                     (coercions, id :: new_exports)
+                   | Lvar id 
+                     when Ident.name id = Ident.name eid -> 
+                     (* {[ Ident.same id eid]} is more  correct, 
+                        however, it will introduce 
+                        a coercion, which is not necessary, 
+                        as long as its name is the same, we want to avoid 
+                        another coercion                        
+                     *)
+                     (coercions, 
+                      id :: new_exports, 
+                      Ident_set.add id new_export_set,
+                      export_map)
                    | _ -> (** TODO : bug 
                               check [map.ml] here coercion, we introduced 
                               rebound which is not corrrect 
@@ -243,15 +262,25 @@ let compile  ~filename non_export env _sigs lam   =
                               however
                           *)
                      (Lam_group.Single(Strict ,eid,  lam) :: coercions, 
-                      eid :: new_exports))
-                meta.exports lambda_exports ([],[])
+                      eid :: new_exports,
+                      Ident_set.add eid new_export_set, 
+                      Ident_map.add eid lam export_map))
+                meta.exports lambda_exports 
+                ([],[], Ident_set.empty, Ident_map.empty)
           in
 
           let meta = { meta with 
-                       export_idents = Lam_util.ident_set_of_list new_exports;
+                       export_idents = new_export_set;
                        exports = new_exports
                      } in 
-          let rest = List.rev_append rest coercion_groups in
+          let (export_map, rest) = 
+            List.fold_left 
+              (fun (export_map, acc) x ->
+                 (match (x : Lam_group.t)  with 
+                 | Single (_,id,lam) when Ident_set.mem id new_export_set 
+                   -> Ident_map.add id lam export_map
+                 | _ -> export_map), x :: acc ) (export_map, coercion_groups) rest in
+
           let () =
             if not @@ Ext_string.is_empty filename 
             then
@@ -261,13 +290,6 @@ let compile  ~filename non_export env _sigs lam   =
               Format.pp_print_list ~pp_sep:Format.pp_print_newline
                 (Lam_group.pp_group env) fmt rest ;
           in
-          (* Invariant: The last one is always [exports]
-             Compile definitions
-             Compile exports
-             Assume Pmakeblock(_,_),
-             lambda_exports are pure
-             compile each binding with a return value
-          *)
           let rest = Lam_dce.remove meta.exports rest 
           in
           let module  E = struct exception  Not_pure of string end in
@@ -335,8 +357,8 @@ let compile  ~filename non_export env _sigs lam   =
 
             (* Exporting ... *)
             let v = 
-              Lam_stats_util.export_to_cmj meta  maybe_pure external_module_ids
-                (if non_export then [] else lambda_exports) 
+              Lam_stats_export.export_to_cmj meta  maybe_pure external_module_ids
+                (if non_export then Ident_map.empty else export_map) 
             in
             (if not @@ Ext_string.is_empty filename then
                Js_cmj_format.to_file 
@@ -357,7 +379,7 @@ let lambda_as_module
     (lam : Lambda.lambda) = 
   begin 
     Lam_current_unit.set_file filename ;  
-    Lam_current_unit.set_debug_file "pervasives.ml";
+    Lam_current_unit.iset_debug_file "caml_string.ml";
     Ext_pervasives.with_file_as_chan 
       (Ext_filename.chop_extension ~loc:__LOC__ filename ^  ".js")
       (fun chan -> Js_dump.dump_deps_program (compile ~filename false env sigs lam) chan)

jscomp/lam_dispatch_primitive.ml

@@ -517,16 +517,22 @@ let query (prim : Lam_compile_env.primitive_description)
       E.runtime_call Js_config.obj_runtime prim.prim_name args 
 
     | "caml_format_float"
-    | "caml_format_int"
+
     | "caml_nativeint_format"
     | "caml_int32_format"
     | "caml_float_of_string"
     | "caml_int_of_string" (* what is the semantics?*)
     | "caml_int32_of_string"
     | "caml_nativeint_of_string" -> 
       E.runtime_call Js_config.format prim.prim_name args
-
-
+    | "caml_format_int" -> 
+      begin match args with 
+      | [ {expression_desc = Str (_, "%d"); _}; v] 
+        ->
+        E.int_to_string v 
+      | _ -> 
+        E.runtime_call Js_config.format prim.prim_name args
+      end
     (*   "caml_alloc_dummy"; *)
     (* TODO:   "caml_alloc_dummy_float"; *)
     | "caml_update_dummy"

jscomp/lam_pass_remove_alias.ml

@@ -76,7 +76,7 @@ let simplify_alias
               | {closed_lambda=Some Lfunction(Curried, params, body) } 
                 (** be more cautious when do cross module inlining *)
                 when
-                  (
+                  ( Ext_list.same_length params args &&
                     List.for_all (fun (arg : Lambda.lambda) ->
                         match arg with 
                         | Lvar p -> 
@@ -126,18 +126,19 @@ let simplify_alias
               end
             else 
               if lam_size < Lam_analysis.small_inline_size then 
-                let param_fresh_map = Lam_analysis.param_map_of_list params in
+
+                (* let param_map =  *)
+                (*   Lam_analysis.free_variables meta.export_idents  *)
+                (*     (Lam_analysis.param_map_of_list params) body in *)
+                (* let old_count = List.length params in *)
+                (* let new_count = Ident_map.cardinal param_map in *)
                 let param_map = 
-                  Lam_analysis.free_variables meta.export_idents param_fresh_map body in
-                let old_count = List.length params in
-                let new_count = Ident_map.cardinal param_map in
-                if  
-                  (
-                    not (Ident_set.mem v meta.export_idents)
-                    || old_count = new_count
-                  )
-
-                then 
+                  Lam_analysis.is_closed_with_map 
+                    meta.export_idents params body in
+                let is_export_id = Ident_set.mem v meta.export_idents in
+                match is_export_id, param_map with 
+                | false, (_, param_map)
+                | true, (true, param_map) -> 
                   if rec_flag = Rec then               
                     begin
                       (* Ext_log.dwarn __LOC__ "beta rec.. %s/%d" v.name v.stamp ; *)
@@ -153,7 +154,7 @@ let simplify_alias
                       simpl (Lam_beta_reduce.propogate_beta_reduce_with_map meta param_map params body args)
 
                     end
-                else 
+                | _ -> 
                   Lapply ( simpl l1, List.map simpl args, info)
               else 
                 begin