small enhancement to cross inlining: TODO: 1. add comments if we can,…

jscomp/lam_analysis.ml

@@ -452,6 +452,8 @@ let is_closed_by set lam =
   Ident_map.is_empty (free_variables set (Ident_map.empty ) lam   )
 
 
+(** A bit consverative , it should be empty *)
 let is_closed  lam = 
-  Ident_map.is_empty (free_variables Ident_set.empty Ident_map.empty lam)  
+  Ident_map.for_all (fun k _ -> Ident.global k)
+    (free_variables Ident_set.empty Ident_map.empty lam)  
 

jscomp/lam_analysis.mli

@@ -41,6 +41,7 @@ val is_closed : Lambda.lambda -> bool
 
 
 
+
 type stats = 
   { 
     mutable top : bool ; 
@@ -57,6 +58,7 @@ type stats =
   }
 
 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
 
 val small_inline_size : int 

jscomp/lam_compile.ml

@@ -51,8 +51,140 @@ type default_case =
   | Complete
   | NonComplete
 
+
 let rec  
-  compile_let flag (cxt : Lam_compile_defs.cxt) id (arg : Lambda.lambda) : Js_output.t =
+  get_exp_with_index (cxt : Lam_compile_defs.cxt) lam 
+    ((id : Ident.t), (pos : int),env) : Js_output.t = 
+  let f =   Js_output.handle_name_tail cxt.st cxt.should_return lam in    
+  Lam_compile_env.find_and_add_if_not_exist (id,pos) env 
+    ~not_found:(fun id -> 
+        f (E.str ~pure:false (Printf.sprintf "Err %s %d %d" id.name id.flags pos))
+        (* E.index m (pos + 1) *) (** shift by one *)
+        (** This can not happen since this id should be already consulted by type checker *)
+      )
+    ~found:(fun {id; name; closed_lambda } ->
+        match id, name, closed_lambda with 
+        | {name = "Sys"; _}, "os_type" , _
+          (** We drop the ability of cross-compiling
+              the compiler has to be the same running 
+          *)
+          ->  f (E.str Sys.os_type)
+        | _, _, Some lam when Lam_util.not_function lam
+          (* since it's only for alias, there is no arguments, 
+             we should not inline function definition here, even though
+             it is very small             
+             TODO: add comment here, we should try to add comment for 
+             cross module inlining             
+          *)              
+          ->  
+          compile_lambda cxt lam
+        | _ -> 
+          f (E.ml_var_dot id name)
+      ) 
+(* TODO: how nested module call would behave,
+   In the future, we should keep in track  of if 
+   it is fully applied from [Lapply]
+   Seems that the module dependency is tricky..
+   should we depend on [Pervasives] or not?
+
+   we can not do this correctly for the return value, 
+   however we can inline the definition in Pervasives
+   TODO:
+   [Pervasives.print_endline]
+   [Pervasives.prerr_endline]
+   @param id external module id 
+   @param number the index of the external function 
+   @param env typing environment
+   @param args arguments 
+ *)
+
+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 
+          {[
+            E.index m (pos + 1)
+          ]}
+          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
+                         ))
+
+    ~found:(fun {id; name;arity; closed_lambda ; _} -> 
+        match closed_lambda with 
+        | Some (Lfunction (_, params, body)) 
+          when Ext_list.same_length params args_lambda -> 
+          compile_lambda cxt 
+            (Lam_beta_reduce.propogate_beta_reduce cxt.meta 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) ->  
+             E.seq (E.dump Error args) (E.unit ())
+           | _ -> 
+
+
+             let rec aux (acc : J.expression)
+                 (arity : Lam_stats.function_arities) args (len : int)  =
+               match arity, len with
+               | _, 0 -> 
+                 acc (** All arguments consumed so far *)
+               | Determin (a, (x,_) :: rest, b), len   ->
+                 let x = 
+                   if x = 0 
+                   then 1 
+                   else x in (* Relax when x = 0 *)
+                 if  len >= x 
+                 then
+                   let first_part, continue =  (Ext_list.take x args) in
+                   aux
+                     (E.call ~info:{arity=Full} acc first_part)
+                     (Determin (a, rest, b))
+                     continue (len - x)
+                 else  acc 
+               (* alpha conversion now? --
+                  Since we did an alpha conversion before so it is not here
+               *)
+               | Determin (a, [], b ), _ ->
+                 (* can not happen, unless it's an exception ? *)
+                 E.call acc args
+               | NA, _ ->
+                 E.call acc args
+             in
+             aux (E.ml_var_dot id name) arity args (List.length args ))
+      )
+
+and  compile_let flag (cxt : Lam_compile_defs.cxt) id (arg : Lambda.lambda) : Js_output.t =
 
 
   match flag, arg  with 
@@ -285,28 +417,8 @@ and
         (Lapply (an, (args' @ args), (Lam_util.mk_apply_info NA)))
     (* External function calll *)
     | Lapply(Lprim(Pfield n, [ Lprim(Pgetglobal id,[])]), args_lambda,_info) ->
-      let [@warning "-8" (* non-exhaustive pattern*)] (args_code,args)   =
-        args_lambda
-        |> List.map
-          (
-            fun (x : Lambda.lambda) ->
-              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
-                *)
-                [], Lam_compile_global.get_exp (QueryGlobal (i, env,true))
-              | _ ->
-                begin
-                  match compile_lambda
-                          {cxt with st = NeedValue ; should_return =  False} x with
-                  | {block = a; value =  Some b} -> a,b
-                  | _ -> assert false
-                end)
-        |> List.split   in
-      Js_output.handle_block_return st should_return lam (List.concat args_code )
-        (Lam_compile_global.get_exp_with_args id n  env args)
+
+      get_exp_with_args cxt lam  args_lambda(* args_code *) id n  env (* args *)
 
 
     | Lapply(fn,args_lambda,  info) -> 
@@ -326,7 +438,7 @@ and
                       for the function, generative module or functor can be a function, 
                       however it can not be global -- global can only module 
                   *)
-                  [], Lam_compile_global.get_exp (QueryGlobal (ident, env,true))
+                  [], Lam_compile_global.get_exp  (ident, env,true)
                 | _ ->
                   begin
                     match compile_lambda 
@@ -444,8 +556,7 @@ and
       Js_output.handle_name_tail st should_return lam (Lam_compile_const.translate c)
 
     | Lprim(Pfield n, [ Lprim(Pgetglobal id,[])]) -> (* should be before Pgetglobal *)
-      Js_output.handle_name_tail st should_return lam 
-        (Lam_compile_global.get_exp (GetGlobal (id,n, env)))
+        get_exp_with_index cxt lam  (id,n, env)
 
     | Lprim(Praise _raise_kind, [ e ]) -> 
       begin
@@ -1089,7 +1200,7 @@ and
         |> List.map (fun (x : Lambda.lambda) -> 
             match x with 
             | Lprim (Pgetglobal i, []) -> 
-              [], Lam_compile_global.get_exp (QueryGlobal (i, env, true))
+              [], Lam_compile_global.get_exp  (i, env, true)
             | _ -> 
               begin
                 match compile_lambda {cxt with st = NeedValue; should_return = False}

jscomp/lam_compile_env.ml

@@ -46,9 +46,9 @@ type module_info = {
 type primitive_description = Types.type_expr option Primitive.description
 
 type key = 
-  | GetGlobal of Ident.t * int * Env.t 
-  | QueryGlobal of Ident.t * Env.t  * bool (** we need register which global variable is an dependency *)
-  | CamlRuntimePrimitive of primitive_description * J.expression list
+
+  Ident.t * Env.t  * bool (** we need register which global variable is an dependency *)
+
 
 type ident_info = {
   id : Ident.t;

jscomp/lam_compile_env.mli

@@ -25,15 +25,14 @@
 type primitive_description = Types.type_expr option Primitive.description
 
 type key = 
-  | GetGlobal of Ident.t * int * Env.t 
-  | QueryGlobal of Ident.t * Env.t * bool 
+  Ident.t * Env.t * bool 
   (** the boolean is expand or not
       when it's passed as module, it should be expanded, 
       otherwise for alias, [include Array], it's okay to return an identifier
       TODO: be more clear about its concept
   *)
   (** we need register which global variable is an dependency *)
-  | CamlRuntimePrimitive of primitive_description * J.expression list  
+
 
 type ident_info = {
   id : Ident.t;

jscomp/lam_compile_external_call.ml

@@ -288,7 +288,7 @@ let translate
           in 
           E.obj kvs 
         | None -> assert false 
-        (* Lam_compile_global.get_exp (CamlRuntimePrimitive (prim, args))  *)
+
       end
     | Js_call{ external_module_name = module_name; 
                txt = { name = fn; splice = js_splice ; 
@@ -375,8 +375,8 @@ let translate
         | _ -> assert false 
       end
 
-    | Normal -> 
-      Lam_compile_global.get_exp (CamlRuntimePrimitive (prim, args))
+    | Normal -> Lam_dispatch_primitive.query prim args 
+
 
   end
 

jscomp/lam_compile_global.ml

@@ -41,28 +41,11 @@ let query_lambda id env =
                            Lambda.Lprim(Pfield i, [Lprim(Pgetglobal id,[])])))
                         sigs))
 
+
 (* Given an module name and position, find its corresponding name  *)  
 let get_exp (key : Lam_compile_env.key) : J.expression = 
   match key with 
-  | GetGlobal ((id : Ident.t), (pos : int),env) -> 
-    Lam_compile_env.find_and_add_if_not_exist (id,pos) env 
-      ~not_found:(fun id -> 
-          E.str ~pure:false (Printf.sprintf "Err %s %d %d" id.name id.flags pos)
-          (* E.index m (pos + 1) *) (** shift by one *)
-          (** This can not happen since this id should be already consulted by type checker *)
-        )
-      ~found:(fun {id; name;_} ->
-          match id, name with 
-          | {name = "Sys"; _}, "os_type" 
-            (** We drop the ability of cross-compiling
-                the compiler has to be the same running 
-            *)
-            ->  E.str Sys.os_type
-          | _ -> 
-            E.ml_var_dot id name
-        ) 
-
-  | QueryGlobal (id, env, expand) -> 
+   (id, env, expand) -> 
     if Ident.is_predef_exn id 
     then 
       begin 
@@ -83,9 +66,7 @@ let get_exp (key : Lam_compile_env.key) : J.expression =
             else 
               E.ml_var id)
 
-  | CamlRuntimePrimitive (prim, args)    -> 
-    Lam_dispatch_primitive.query prim args
-
+
 
 (* TODO: how nested module call would behave,
    In the future, we should keep in track  of if 

jscomp/lam_compile_global.mli

@@ -24,12 +24,6 @@
 
 val get_exp : Lam_compile_env.key  -> J.expression
 
-(*
-   @param id external module id 
-   @param number the index of the external function 
-   @param env typing environment
-   @param args arguments 
- *)
-val get_exp_with_args : Ident.t  ->  int ->  Env.t -> J.expression list -> J.expression
+
 
 val query_lambda : Ident.t -> Env.t -> Lambda.lambda

jscomp/lam_compile_group.ml

@@ -357,7 +357,7 @@ let lambda_as_module
     (lam : Lambda.lambda) = 
   begin 
     Lam_current_unit.set_file filename ;  
-    Lam_current_unit.iset_debug_file "format_regression.ml";
+    Lam_current_unit.set_debug_file "pervasives.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_compile_primitive.ml

@@ -298,7 +298,7 @@ let translate
         1. include Array --> let include  = Array 
         2. get exception
     *)
-    Lam_compile_global.get_exp (QueryGlobal (i,env,false))
+    Lam_compile_global.get_exp (i,env,false)
 
     (** only when Lapply -> expand = true*)
   | Praise _raise_kind -> assert false (* handled before here *)

jscomp/lam_inline_util.ml

@@ -24,6 +24,10 @@
 let maybe_functor (name : string) = 
   name.[0] >= 'A' && name.[0] <= 'Z'
 
+
+let should_be_functor (name : string) lam = 
+  maybe_functor name  && (function | Lambda.Lfunction _ -> true | _ -> false) lam
+
 (* TODO: add a context, like 
     [args]
     [Lfunction(params,body)]

jscomp/lam_inline_util.mli

@@ -23,3 +23,5 @@
 (** Utilities for lambda inlining *)
 
 val maybe_functor : string -> bool
+
+val should_be_functor : string -> Lambda.lambda -> bool