tweak ... lambda_exports...

Author: Hongbo Zhang

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

@@ -81,6 +81,108 @@ let rec
         | _ -> 
           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 =
 
@@ -315,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  (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) -> 

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

@@ -354,7 +354,7 @@ let lambda_as_module
     (lam : Lambda.lambda) = 
   begin 
     Lam_current_unit.set_file filename ;  
-    Lam_current_unit.iset_debug_file "pervasives.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_program (compile ~filename false env sigs lam) chan)

jscomp/lam_stats_util.ml

@@ -256,16 +256,28 @@ let export_to_cmj
              then Some lambda
              else None
            else 
-           if Lam_analysis.size lambda < Lam_analysis.small_inline_size 
-              && 
-              Lam_analysis.is_closed lambda 
-              (* global need re-assocate when do the beta reduction *)
-           then 
-             begin
-               Ext_log.dwarn __LOC__ "%s recorded for inlining @." x.name ;
-               Some lambda
-             end
-           else None in 
+             let lam_size = Lam_analysis.size lambda in
+             (* let is_closed = Lam_analysis.is_closed lambda  in *)
+             let free_variables =
+               Lam_analysis.free_variables Ident_set.empty Ident_map.empty 
+                 lambda in
+             if  lam_size < Lam_analysis.small_inline_size && 
+                 Ident_map.is_empty free_variables
+             (* global need re-assocate when do the beta reduction *)
+             then 
+               begin
+                 Ext_log.dwarn __LOC__ "%s recorded for inlining @." x.name ;
+                 Some lambda
+               end
+             else 
+               begin
+                 Ext_log.dwarn __LOC__ "%s : %d : {%s} not inlined @." 
+                   x.name lam_size  
+                   (String.concat ", " @@ 
+                    List.map (fun x -> x.Ident.name) @@ Ident_map.keys free_variables) ;
+                 None 
+               end
+         in 
          String_map.add x.name  Js_cmj_format.{arity ; closed_lambda } acc 
       )
       String_map.empty

jscomp/stdlib/buffer.js

@@ -117,7 +117,7 @@ function add_substring(b, s, offset, len) {
 }
 
 function add_subbytes(b, s, offset, len) {
-  return add_substring(b, Bytes.unsafe_to_string(s), offset, len);
+  return add_substring(b, Caml_string.bytes_to_string(s), offset, len);
 }
 
 function add_string(b, s) {
@@ -132,7 +132,7 @@ function add_string(b, s) {
 }
 
 function add_bytes(b, s) {
-  return add_string(b, Bytes.unsafe_to_string(s));
+  return add_string(b, Caml_string.bytes_to_string(s));
 }
 
 function add_buffer(b, bs) {

jscomp/stdlib/camlinternalFormat.js

@@ -2,6 +2,7 @@
 'use strict';
 
 var Bytes                    = require("./bytes");
+var Caml_io                  = require("../runtime/caml_io");
 var Caml_float               = require("../runtime/caml_float");
 var Pervasives               = require("./pervasives");
 var Caml_exceptions          = require("../runtime/caml_exceptions");
@@ -4435,7 +4436,7 @@ function output_acc(o, _acc) {
             return acc[2](o);
         case 7 : 
             output_acc(o, acc[1]);
-            return Pervasives.flush(o);
+            return Caml_io.caml_ml_flush(o);
         case 8 : 
             output_acc(o, acc[1]);
             return Pervasives.invalid_arg(acc[2]);
@@ -4448,7 +4449,8 @@ function output_acc(o, _acc) {
           return Pervasives.output_string(o, acc[2]);
       case 2 : 
           output_acc(o, acc[1]);
-          return Pervasives.output_char(o, acc[2]);
+          var prim = acc[2];
+          return Caml_io.caml_ml_output_char(o, prim);
 
     }
   };

jscomp/stdlib/digest.js

@@ -1,7 +1,6 @@
 // Generated CODE, PLEASE EDIT WITH CARE
 'use strict';
 
-var Bytes           = require("./bytes");
 var Pervasives      = require("./pervasives");
 var Caml_exceptions = require("../runtime/caml_exceptions");
 var Char            = require("./char");
@@ -14,7 +13,7 @@ function string(str) {
 }
 
 function bytes(b) {
-  return string(Bytes.unsafe_to_string(b));
+  return string(Caml_string.bytes_to_string(b));
 }
 
 function substring(str, ofs, len) {
@@ -27,7 +26,7 @@ function substring(str, ofs, len) {
 }
 
 function subbytes(b, ofs, len) {
-  return substring(Bytes.unsafe_to_string(b), ofs, len);
+  return substring(Caml_string.bytes_to_string(b), ofs, len);
 }
 
 function file(filename) {

jscomp/stdlib/format.js

@@ -1,6 +1,7 @@
 // Generated CODE, PLEASE EDIT WITH CARE
 'use strict';
 
+var Caml_io            = require("../runtime/caml_io");
 var Caml_exceptions    = require("../runtime/caml_exceptions");
 var Pervasives         = require("./pervasives");
 var Caml_primitive     = require("../runtime/caml_primitive");
@@ -1063,7 +1064,7 @@ function pp_set_formatter_out_channel(state, os) {
     return Pervasives.output_substring(os, param, param$1, param$2);
   };
   state[18] = function () {
-    return Pervasives.flush(os);
+    return Caml_io.caml_ml_flush(os);
   };
   state[19] = function (param) {
     return display_newline(state, param);
@@ -1168,7 +1169,7 @@ function formatter_of_out_channel(oc) {
   return make_formatter(function (param, param$1, param$2) {
               return Pervasives.output_substring(oc, param, param$1, param$2);
             }, function () {
-              return Pervasives.flush(oc);
+              return Caml_io.caml_ml_flush(oc);
             });
 }
 

jscomp/stdlib/marshal.js

@@ -1,9 +1,9 @@
 // Generated CODE, PLEASE EDIT WITH CARE
 'use strict';
 
-var Bytes          = require("./bytes");
 var Pervasives     = require("./pervasives");
 var Caml_primitive = require("../runtime/caml_primitive");
+var Caml_string    = require("../runtime/caml_string");
 
 function to_buffer(buff, ofs, len, v, flags) {
   if (ofs < 0 || len < 0 || ofs > buff.length - len) {
@@ -45,7 +45,7 @@ function from_bytes(buff, ofs) {
 }
 
 function from_string(buff, ofs) {
-  return from_bytes(Bytes.unsafe_of_string(buff), ofs);
+  return from_bytes(Caml_string.bytes_of_string(buff), ofs);
 }
 
 function to_channel(prim, prim$1, prim$2) {

jscomp/stdlib/scanf.js

@@ -155,7 +155,7 @@ var file_buffer_size = [
 ];
 
 function scan_close_at_end(ic) {
-  Pervasives.close_in(ic);
+  Caml_primitive.caml_ml_close_channel(ic);
   throw Caml_exceptions.End_of_file;
 }
 

jscomp/test/ext_string.js

@@ -131,7 +131,7 @@ function escaped(s) {
     };
   };
   if (needs_escape(0)) {
-    return Caml_string.bytes_to_string(Ext_bytes.escaped(Bytes.unsafe_of_string(s)));
+    return Caml_string.bytes_to_string(Ext_bytes.escaped(Caml_string.bytes_of_string(s)));
   }
   else {
     return s;

jscomp/test/test_bytes.js

@@ -1,11 +1,10 @@
 // Generated CODE, PLEASE EDIT WITH CARE
 'use strict';
 
-var Bytes       = require("../stdlib/bytes");
 var Caml_string = require("../runtime/caml_string");
 
 function f(v) {
-  return Bytes.unsafe_to_string(v);
+  return Caml_string.bytes_to_string(v);
 }
 
 function ff(v) {