fix a bug in Js_fn module

jscomp/ext_string.ml

@@ -46,12 +46,15 @@ let starts_with s beg =
   let s_len = String.length s in
    beg_len <=  s_len &&
   (let i = ref 0 in
-    while !i <  beg_len && s.[!i] = beg.[!i] do 
+    while !i <  beg_len 
+          && String.unsafe_get s !i =
+             String.unsafe_get beg !i do 
       incr i 
     done;
     !i = beg_len
   )
 
+
 (* TODO: optimization *)
 let ends_with s beg = 
   let s_finish = String.length s - 1 in
@@ -164,3 +167,30 @@ let digits_of_str s ~offset x =
 
 
 
+(*
+   {[
+     starts_with_and_number "js_fn_mk_01" 0 "js_fn_mk_" = 1 ;;
+     starts_with_and_number "js_fn_run_02" 0 "js_fn_mk_" = -1 ;;
+     starts_with_and_number "js_fn_mk_03" 6 "mk_" = 3 ;;
+     starts_with_and_number "js_fn_mk_04" 6 "run_" = -1;;
+     starts_with_and_number "js_fn_run_04" 6 "run_" = 4;;
+     (starts_with_and_number "js_fn_run_04" 6 "run_" = 3) = false ;;
+   ]}
+*)
+let starts_with_and_number s ~offset beg =
+  let beg_len = String.length beg in
+  let s_len = String.length s in
+  let finish_delim = offset + beg_len in 
+
+   if finish_delim >  s_len  then -1 
+   else 
+     let i = ref offset  in
+      while !i <  finish_delim
+            && String.unsafe_get s !i =
+               String.unsafe_get beg (!i - offset) do 
+        incr i 
+      done;
+      if !i = finish_delim then 
+        digits_of_str ~offset:finish_delim s 2 
+      else 
+        -1 

jscomp/ext_string.mli

@@ -49,3 +49,5 @@ val rfind : sub:string -> string -> int
 val tail_from : string -> int -> string
 
 val digits_of_str : string -> offset:int -> int -> int
+
+val starts_with_and_number : string -> offset:int -> string -> int

jscomp/lam_compile.ml

@@ -679,91 +679,123 @@ and
           let exp =  E.or_ l_expr r_expr  in
           Js_output.handle_block_return st should_return lam args_code exp
       end
-    | Lprim (Pccall {prim_name = 
-                       (
-                         "js_fn_mk_00" 
-                       | "js_fn_mk_01"
-                       | "js_fn_mk_02"
-                       | "js_fn_mk_03"
-                       | "js_fn_mk_04"
-                       | "js_fn_mk_05"
-                       | "js_fn_mk_06"
-                       | "js_fn_mk_07"
-                       | "js_fn_mk_08"
-                       | "js_fn_mk_09"
-                         as name )
-                    }, [fn])
-      -> 
-      let arity = Ext_string.digits_of_str ~offset:9 (* String.length "js_fn_mk_" *) name 2   in
-      begin match fn with
-      | Lambda.Lfunction(kind,args, body) 
-        ->
-        let len =  List.length args in 
-        if len = arity then
-          compile_lambda cxt fn 
-        else if len > arity then 
-          let first, rest  = Ext_list.take arity args  in 
-          compile_lambda cxt (Lambda.Lfunction (kind, first, Lambda.Lfunction (kind, rest, body)))
-        else 
-          compile_lambda cxt (Lam_util.eta_conversion arity Lam_util.default_apply_info  fn  [] )
-          (* let extra_args = Ext_list.init (arity - len) (fun _ ->   (Ident.create Literals.param)) in *)
-          (* let extra_lambdas = List.map (fun x -> Lambda.Lvar x) extra_args in *)
-          (* Lambda.Lfunction (kind, extra_args @ args , body ) *)
-      (*TODO: can be optimized ?
-        {[\ x y -> (\u -> body x) x y]}
-        {[\u x -> body x]}        
-        rewrite rules 
-        {[
-          \x -> body 
-                --
-                \y (\x -> body ) y 
-        ]}
-        {[\ x y -> (\a b c -> g a b c) x y]}
-        {[ \a b -> \c -> g a b c ]}
-      *)
-      | _ -> 
-        compile_lambda cxt (Lam_util.eta_conversion arity Lam_util.default_apply_info  fn  [] )
-      end
     (* TODO: 
        check the arity of fn before wrapping it 
        we need mark something that such eta-conversion can not be simplified in some cases 
     *)
-    | Lprim (Pccall{prim_name = "js_debugger"; _}, 
-             _) 
-      -> 
-      (* [%bs.debugger] guarantees that the expression does not matter 
+
+    | Lprim (prim, args_lambda)  ->
+      let cont args_code exp = 
+        Js_output.handle_block_return st should_return lam args_code exp  in 
+      begin match prim with 
+      | Pccall {prim_name = "js_debugger"; _} 
+        -> 
+        (* [%bs.debugger] guarantees that the expression does not matter 
          TODO: make it even safer
          *)
-      Js_output.handle_block_return st should_return lam  [S.debugger] E.unit 
-    | Lprim (prim, args_lambda)  ->
-      begin
+        cont [S.debugger] E.unit 
+      | Pccall {prim_name = name}
+        when Ext_string.starts_with name "js_fn_"
+      -> 
+        let arity, kind  = 
+          let mk =  Ext_string.starts_with_and_number name ~offset:6 "mk_" in 
+          if mk < 0 then 
+            let run = Ext_string.starts_with_and_number name ~offset:6 "run_" in 
+            run , `Run
+          else mk, `Mk
+        in 
+
+        (* 1. prevent eta-conversion
+           by using [App_js_full]
+           2. invariant: `external` declaration will guarantee
+           the function application is saturated
+           3. we need a location for Pccall in the call site
+        *)
+
+        if kind = `Run then 
+          match args_lambda with 
+          | fn :: rest -> 
+            compile_lambda cxt @@ 
+            Lambda.Lapply (fn, rest , 
+                           {apply_loc = Location.none;
+                            apply_status = App_js_full})
+          | _ -> assert false 
+        else 
+        begin match args_lambda with 
+          | [fn] -> 
+            if arity = 0 then 
+              (* 
+                Invariant: mk0 : (unit -> 'a0) -> 'a0 t 
+                TODO: this case should be optimized, 
+                we need check where we handle [arity=0] 
+                as a special case -- 
+                if we do an optimization before compiling
+                into lambda
+             *)
+              compile_lambda cxt 
+                  (Lfunction (Lambda.Curried, [], 
+                              Lambda.Lapply(fn, 
+                                            [Lam_util.lam_unit],
+                                            Lam_util.default_apply_info 
+                                           )))
+            else 
+              begin match fn with
+                | Lambda.Lfunction(kind,args, body) 
+                  ->
+                  let len =  List.length args in 
+                  if len = arity then
+                    compile_lambda cxt fn 
+                  else if len > arity then 
+                    let first, rest  = Ext_list.take arity args  in 
+                    compile_lambda cxt 
+                      (Lambda.Lfunction 
+                         (kind, first, Lambda.Lfunction (kind, rest, body)))
+                  else 
+                    compile_lambda cxt 
+                      (Lam_util.eta_conversion arity Lam_util.default_apply_info  
+                         fn  [] )
+                (* let extra_args = Ext_list.init (arity - len) (fun _ ->   (Ident.create Literals.param)) in *)
+                (* let extra_lambdas = List.map (fun x -> Lambda.Lvar x) extra_args in *)
+                (* Lambda.Lfunction (kind, extra_args @ args , body ) *)
+                (*TODO: can be optimized ?
+                  {[\ x y -> (\u -> body x) x y]}
+                  {[\u x -> body x]}        
+                  rewrite rules 
+                  {[
+                    \x -> body 
+                          --
+                          \y (\x -> body ) y 
+                  ]}
+                  {[\ x y -> (\a b c -> g a b c) x y]}
+                  {[ \a b -> \c -> g a b c ]}
+                *)
+                | _ -> 
+                  compile_lambda cxt 
+                    (Lam_util.eta_conversion arity Lam_util.default_apply_info  fn  [] )
+              end
+          | _ -> assert false 
+        end
+      | _ -> 
         let args_block, args_expr =
-          args_lambda 
-          |> List.map (fun (x : Lambda.lambda) ->
+          Ext_list.split_map (fun (x : Lambda.lambda) ->
               match compile_lambda {cxt with st = NeedValue; should_return = False} x 
               with 
               | {block = a; value = Some b} -> a,b
-              | _ -> assert false )
-          |> List.split 
+              | _ -> assert false ) args_lambda 
+            
         in
         let args_code  = List.concat args_block in
         let exp  =  (* TODO: all can be done in [compile_primitive] *)
           Lam_compile_primitive.translate cxt prim args_expr in
-        Js_output.handle_block_return st should_return lam args_code exp 
+        cont  args_code exp 
       end
     | Lsequence (l1,l2) ->
       let output_l1 = 
         compile_lambda {cxt with st = EffectCall; should_return =  False} l1 in
       let output_l2 = 
         compile_lambda cxt l2  in
-      let result = output_l1 ++ output_l2  in
-      (* let () = *)
-      (*   Ext_log.dwarn __LOC__ *)
-      (*     "@ @[l1:%a@ js-l1(%d):%s@ l2:@ %a@ js-l2(%d):%s@ js-l:@ %s@]" *)
-      (*     Printlambda.lambda l1 (List.length output_l1.block) (Js_output.to_string output_l1) *)
-      (*     Printlambda.lambda l2 (List.length output_l2.block) (Js_output.to_string output_l2) *)
-      (*     (Js_output.to_string result ) in  *)
-      result      
+       output_l1 ++ output_l2
+
 
     (* begin
        match cxt.st, cxt.should_return with  *)

jscomp/lam_util.ml

@@ -1,3 +1,4 @@
+
 (* BuckleScript compiler
  * Copyright (C) 2015-2016 Bloomberg Finance L.P.
  *
@@ -313,9 +314,14 @@ let mk_apply_info ?(loc = Location.none)  apply_status : Lambda.apply_info =
   { apply_loc = loc; apply_status }
 
 
-let lam_true : Lambda.lambda = Lconst (Const_pointer ( 1, Pt_constructor "true")) 
+let lam_true : Lambda.lambda =
+  Lconst (Const_pointer ( 1, Pt_constructor "true")) 
+
+let lam_false : Lambda.lambda =
+  Lconst (Const_pointer( 0, Pt_constructor "false"))
 
-let lam_false : Lambda.lambda = Lconst (Const_pointer( 0, Pt_constructor "false"))
+let lam_unit : Lambda.lambda = 
+  Lconst (Const_pointer( 0, Pt_constructor "()"))
 
 let is_function (lam : Lambda.lambda) = 
   match lam with 

jscomp/lam_util.mli

@@ -61,6 +61,7 @@ val mk_apply_info : ?loc:Location.t -> Lambda.apply_status -> Lambda.apply_info
 
 val lam_true : Lambda.lambda
 val lam_false : Lambda.lambda
+val lam_unit : Lambda.lambda 
 
 val not_function : Lambda.lambda -> bool 
 val is_function : Lambda.lambda -> bool 

jscomp/lib/js_fn.ml

@@ -31,42 +31,82 @@
 *)
 
 
-type 'a t
+type + 'a t
 
 external mk0 : (unit -> 'a0) -> 'a0 t = 
   "js_fn_mk_00" 
 
+external run0 : 'a0 t  -> 'a0 = "js_fn_run_00"
+
 external mk1 : ('a0 -> 'a1) -> ('a0 * 'a1) t  = 
   "js_fn_mk_01"
 
+external run1 : ('a0 * 'a1) t -> 'a0 -> 'a1  = 
+  "js_fn_run_01"
+
 external mk2 : ('a0 -> 'a1 -> 'a2 ) -> ('a0 *  'a1 * 'a2) t = 
   "js_fn_mk_02"
 
-external mk3 : ('a0 -> 'a1 -> 'a2 -> 'a3 ) -> ('a0 *  'a1 * 'a2 * 'a3)  t = 
+external run2 : ('a0 * 'a1 * 'a2 )t -> 'a0 -> 'a1 -> 'a2  = 
+  "js_fn_run_02"
+
+external mk3 : 
+  ('a0 -> 'a1 -> 'a2 -> 'a3 ) -> ('a0 *  'a1 * 'a2 * 'a3)  t = 
   "js_fn_mk_03"
 
-external mk4 : ('a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 ) -> ('a0 *  'a1 * 'a2 * 'a3 * 'a4) t = 
+external run3 : 
+  ('a0 * 'a1 * 'a2 * 'a3) t -> 'a0 -> 'a1 -> 'a2 -> 'a3 = 
+  "js_fn_run_03"
+
+external mk4 : ('a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 ) 
+  -> ('a0 *  'a1 * 'a2 * 'a3 * 'a4) t = 
   "js_fn_mk_04"
 
-external mk5 : ('a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 ) -> ('a0 *  'a1 * 'a2 * 'a3 * 'a4 * 'a5) t =
+external run4 : ('a0 *  'a1 * 'a2 * 'a3 * 'a4) t -> 
+  'a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 = 
+  "js_fn_run_04"
+
+external mk5 : 
+  ('a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 ) ->
+  ('a0 *  'a1 * 'a2 * 'a3 * 'a4 * 'a5) t =
   "js_fn_mk_05"
 
+external run5 : 
+  ('a0 *  'a1 * 'a2 * 'a3 * 'a4 * 'a5) t
+  -> 'a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 = 
+  "js_fn_run_05"
 
 external mk6 : ('a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6) -> 
   ('a0 *  'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6) t =
   "js_fn_mk_06"
+external run6 : ('a0 *  'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6) t
+  -> 'a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 = 
+  "js_fn_run_06"
 
 external mk7 : ('a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'a7) -> 
   ('a0 *  'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 ) t =
   "js_fn_mk_07"
 
+external run7 : ('a0 *  'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 ) t
+  -> 'a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'a7 = 
+  "js_fn_run_07"
 
 external mk8 : ('a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'a7 -> 'a8 ) ->
   ('a0 *  'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 ) t =
   "js_fn_mk_08"
 
+external run8 :   
+  ('a0 *  'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 ) t -> 
+  'a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'a7 -> 'a8 
+  = 
+  "js_fn_run_08"
 
-external mk9 : ('a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'a7 -> 'a8 -> 'a9) ->
+external mk9 : 
+  ('a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'a7 -> 'a8 -> 'a9) ->
   ('a0 *  'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 ) t =
   "js_fn_mk_09"
 
+external run9 : 
+  ('a0 *  'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 ) t -> 
+  'a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'a7 -> 'a8 -> 'a9 = 
+  "js_fn_run_09"

jscomp/test/.depend

@@ -128,6 +128,8 @@ equal_test.cmo :
 equal_test.cmx :
 es6_module_test.cmo : mt.cmi ../stdlib/list.cmi
 es6_module_test.cmx : mt.cmx ../stdlib/list.cmx
+event_ffi.cmo : ../lib/js_fn.cmo ../lib/js.cmo
+event_ffi.cmx : ../lib/js_fn.cmx ../lib/js.cmx
 exception_raise_test.cmo : mt.cmi
 exception_raise_test.cmx : mt.cmx
 ext_array.cmo : ../stdlib/list.cmi ../stdlib/array.cmi
@@ -666,6 +668,8 @@ equal_test.cmo :
 equal_test.cmj :
 es6_module_test.cmo : mt.cmi ../stdlib/list.cmi
 es6_module_test.cmj : mt.cmj ../stdlib/list.cmj
+event_ffi.cmo : ../lib/js_fn.cmo ../lib/js.cmo
+event_ffi.cmj : ../lib/js_fn.cmj ../lib/js.cmj
 exception_raise_test.cmo : mt.cmi
 exception_raise_test.cmj : mt.cmj
 ext_array.cmo : ../stdlib/list.cmi ../stdlib/array.cmi