Skip to content

Commit c95e570

Browse files
committed
fix a bug in Js_fn module (#263)
1 parent 364103a commit c95e570

13 files changed

+410
-93
lines changed

jscomp/ext_string.ml

Lines changed: 31 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -46,12 +46,15 @@ let starts_with s beg =
4646
let s_len = String.length s in
4747
beg_len <= s_len &&
4848
(let i = ref 0 in
49-
while !i < beg_len && s.[!i] = beg.[!i] do
49+
while !i < beg_len
50+
&& String.unsafe_get s !i =
51+
String.unsafe_get beg !i do
5052
incr i
5153
done;
5254
!i = beg_len
5355
)
5456

57+
5558
(* TODO: optimization *)
5659
let ends_with s beg =
5760
let s_finish = String.length s - 1 in
@@ -164,3 +167,30 @@ let digits_of_str s ~offset x =
164167

165168

166169

170+
(*
171+
{[
172+
starts_with_and_number "js_fn_mk_01" 0 "js_fn_mk_" = 1 ;;
173+
starts_with_and_number "js_fn_run_02" 0 "js_fn_mk_" = -1 ;;
174+
starts_with_and_number "js_fn_mk_03" 6 "mk_" = 3 ;;
175+
starts_with_and_number "js_fn_mk_04" 6 "run_" = -1;;
176+
starts_with_and_number "js_fn_run_04" 6 "run_" = 4;;
177+
(starts_with_and_number "js_fn_run_04" 6 "run_" = 3) = false ;;
178+
]}
179+
*)
180+
let starts_with_and_number s ~offset beg =
181+
let beg_len = String.length beg in
182+
let s_len = String.length s in
183+
let finish_delim = offset + beg_len in
184+
185+
if finish_delim > s_len then -1
186+
else
187+
let i = ref offset in
188+
while !i < finish_delim
189+
&& String.unsafe_get s !i =
190+
String.unsafe_get beg (!i - offset) do
191+
incr i
192+
done;
193+
if !i = finish_delim then
194+
digits_of_str ~offset:finish_delim s 2
195+
else
196+
-1

jscomp/ext_string.mli

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -49,3 +49,5 @@ val rfind : sub:string -> string -> int
4949
val tail_from : string -> int -> string
5050

5151
val digits_of_str : string -> offset:int -> int -> int
52+
53+
val starts_with_and_number : string -> offset:int -> string -> int

jscomp/lam_compile.ml

Lines changed: 97 additions & 65 deletions
Original file line numberDiff line numberDiff line change
@@ -679,91 +679,123 @@ and
679679
let exp = E.or_ l_expr r_expr in
680680
Js_output.handle_block_return st should_return lam args_code exp
681681
end
682-
| Lprim (Pccall {prim_name =
683-
(
684-
"js_fn_mk_00"
685-
| "js_fn_mk_01"
686-
| "js_fn_mk_02"
687-
| "js_fn_mk_03"
688-
| "js_fn_mk_04"
689-
| "js_fn_mk_05"
690-
| "js_fn_mk_06"
691-
| "js_fn_mk_07"
692-
| "js_fn_mk_08"
693-
| "js_fn_mk_09"
694-
as name )
695-
}, [fn])
696-
->
697-
let arity = Ext_string.digits_of_str ~offset:9 (* String.length "js_fn_mk_" *) name 2 in
698-
begin match fn with
699-
| Lambda.Lfunction(kind,args, body)
700-
->
701-
let len = List.length args in
702-
if len = arity then
703-
compile_lambda cxt fn
704-
else if len > arity then
705-
let first, rest = Ext_list.take arity args in
706-
compile_lambda cxt (Lambda.Lfunction (kind, first, Lambda.Lfunction (kind, rest, body)))
707-
else
708-
compile_lambda cxt (Lam_util.eta_conversion arity Lam_util.default_apply_info fn [] )
709-
(* let extra_args = Ext_list.init (arity - len) (fun _ -> (Ident.create Literals.param)) in *)
710-
(* let extra_lambdas = List.map (fun x -> Lambda.Lvar x) extra_args in *)
711-
(* Lambda.Lfunction (kind, extra_args @ args , body ) *)
712-
(*TODO: can be optimized ?
713-
{[\ x y -> (\u -> body x) x y]}
714-
{[\u x -> body x]}
715-
rewrite rules
716-
{[
717-
\x -> body
718-
--
719-
\y (\x -> body ) y
720-
]}
721-
{[\ x y -> (\a b c -> g a b c) x y]}
722-
{[ \a b -> \c -> g a b c ]}
723-
*)
724-
| _ ->
725-
compile_lambda cxt (Lam_util.eta_conversion arity Lam_util.default_apply_info fn [] )
726-
end
727682
(* TODO:
728683
check the arity of fn before wrapping it
729684
we need mark something that such eta-conversion can not be simplified in some cases
730685
*)
731-
| Lprim (Pccall{prim_name = "js_debugger"; _},
732-
_)
733-
->
734-
(* [%bs.debugger] guarantees that the expression does not matter
686+
687+
| Lprim (prim, args_lambda) ->
688+
let cont args_code exp =
689+
Js_output.handle_block_return st should_return lam args_code exp in
690+
begin match prim with
691+
| Pccall {prim_name = "js_debugger"; _}
692+
->
693+
(* [%bs.debugger] guarantees that the expression does not matter
735694
TODO: make it even safer
736695
*)
737-
Js_output.handle_block_return st should_return lam [S.debugger] E.unit
738-
| Lprim (prim, args_lambda) ->
739-
begin
696+
cont [S.debugger] E.unit
697+
| Pccall {prim_name = name}
698+
when Ext_string.starts_with name "js_fn_"
699+
->
700+
let arity, kind =
701+
let mk = Ext_string.starts_with_and_number name ~offset:6 "mk_" in
702+
if mk < 0 then
703+
let run = Ext_string.starts_with_and_number name ~offset:6 "run_" in
704+
run , `Run
705+
else mk, `Mk
706+
in
707+
708+
(* 1. prevent eta-conversion
709+
by using [App_js_full]
710+
2. invariant: `external` declaration will guarantee
711+
the function application is saturated
712+
3. we need a location for Pccall in the call site
713+
*)
714+
715+
if kind = `Run then
716+
match args_lambda with
717+
| fn :: rest ->
718+
compile_lambda cxt @@
719+
Lambda.Lapply (fn, rest ,
720+
{apply_loc = Location.none;
721+
apply_status = App_js_full})
722+
| _ -> assert false
723+
else
724+
begin match args_lambda with
725+
| [fn] ->
726+
if arity = 0 then
727+
(*
728+
Invariant: mk0 : (unit -> 'a0) -> 'a0 t
729+
TODO: this case should be optimized,
730+
we need check where we handle [arity=0]
731+
as a special case --
732+
if we do an optimization before compiling
733+
into lambda
734+
*)
735+
compile_lambda cxt
736+
(Lfunction (Lambda.Curried, [],
737+
Lambda.Lapply(fn,
738+
[Lam_util.lam_unit],
739+
Lam_util.default_apply_info
740+
)))
741+
else
742+
begin match fn with
743+
| Lambda.Lfunction(kind,args, body)
744+
->
745+
let len = List.length args in
746+
if len = arity then
747+
compile_lambda cxt fn
748+
else if len > arity then
749+
let first, rest = Ext_list.take arity args in
750+
compile_lambda cxt
751+
(Lambda.Lfunction
752+
(kind, first, Lambda.Lfunction (kind, rest, body)))
753+
else
754+
compile_lambda cxt
755+
(Lam_util.eta_conversion arity Lam_util.default_apply_info
756+
fn [] )
757+
(* let extra_args = Ext_list.init (arity - len) (fun _ -> (Ident.create Literals.param)) in *)
758+
(* let extra_lambdas = List.map (fun x -> Lambda.Lvar x) extra_args in *)
759+
(* Lambda.Lfunction (kind, extra_args @ args , body ) *)
760+
(*TODO: can be optimized ?
761+
{[\ x y -> (\u -> body x) x y]}
762+
{[\u x -> body x]}
763+
rewrite rules
764+
{[
765+
\x -> body
766+
--
767+
\y (\x -> body ) y
768+
]}
769+
{[\ x y -> (\a b c -> g a b c) x y]}
770+
{[ \a b -> \c -> g a b c ]}
771+
*)
772+
| _ ->
773+
compile_lambda cxt
774+
(Lam_util.eta_conversion arity Lam_util.default_apply_info fn [] )
775+
end
776+
| _ -> assert false
777+
end
778+
| _ ->
740779
let args_block, args_expr =
741-
args_lambda
742-
|> List.map (fun (x : Lambda.lambda) ->
780+
Ext_list.split_map (fun (x : Lambda.lambda) ->
743781
match compile_lambda {cxt with st = NeedValue; should_return = False} x
744782
with
745783
| {block = a; value = Some b} -> a,b
746-
| _ -> assert false )
747-
|> List.split
784+
| _ -> assert false ) args_lambda
785+
748786
in
749787
let args_code = List.concat args_block in
750788
let exp = (* TODO: all can be done in [compile_primitive] *)
751789
Lam_compile_primitive.translate cxt prim args_expr in
752-
Js_output.handle_block_return st should_return lam args_code exp
790+
cont args_code exp
753791
end
754792
| Lsequence (l1,l2) ->
755793
let output_l1 =
756794
compile_lambda {cxt with st = EffectCall; should_return = False} l1 in
757795
let output_l2 =
758796
compile_lambda cxt l2 in
759-
let result = output_l1 ++ output_l2 in
760-
(* let () = *)
761-
(* Ext_log.dwarn __LOC__ *)
762-
(* "@ @[l1:%a@ js-l1(%d):%s@ l2:@ %a@ js-l2(%d):%s@ js-l:@ %s@]" *)
763-
(* Printlambda.lambda l1 (List.length output_l1.block) (Js_output.to_string output_l1) *)
764-
(* Printlambda.lambda l2 (List.length output_l2.block) (Js_output.to_string output_l2) *)
765-
(* (Js_output.to_string result ) in *)
766-
result
797+
output_l1 ++ output_l2
798+
767799

768800
(* begin
769801
match cxt.st, cxt.should_return with *)

jscomp/lam_util.ml

Lines changed: 8 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
12
(* BuckleScript compiler
23
* Copyright (C) 2015-2016 Bloomberg Finance L.P.
34
*
@@ -313,9 +314,14 @@ let mk_apply_info ?(loc = Location.none) apply_status : Lambda.apply_info =
313314
{ apply_loc = loc; apply_status }
314315

315316

316-
let lam_true : Lambda.lambda = Lconst (Const_pointer ( 1, Pt_constructor "true"))
317+
let lam_true : Lambda.lambda =
318+
Lconst (Const_pointer ( 1, Pt_constructor "true"))
319+
320+
let lam_false : Lambda.lambda =
321+
Lconst (Const_pointer( 0, Pt_constructor "false"))
317322

318-
let lam_false : Lambda.lambda = Lconst (Const_pointer( 0, Pt_constructor "false"))
323+
let lam_unit : Lambda.lambda =
324+
Lconst (Const_pointer( 0, Pt_constructor "()"))
319325

320326
let is_function (lam : Lambda.lambda) =
321327
match lam with

jscomp/lam_util.mli

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -61,6 +61,7 @@ val mk_apply_info : ?loc:Location.t -> Lambda.apply_status -> Lambda.apply_info
6161

6262
val lam_true : Lambda.lambda
6363
val lam_false : Lambda.lambda
64+
val lam_unit : Lambda.lambda
6465

6566
val not_function : Lambda.lambda -> bool
6667
val is_function : Lambda.lambda -> bool

jscomp/lib/js_fn.ml

Lines changed: 45 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -31,42 +31,82 @@
3131
*)
3232

3333

34-
type 'a t
34+
type + 'a t
3535

3636
external mk0 : (unit -> 'a0) -> 'a0 t =
3737
"js_fn_mk_00"
3838

39+
external run0 : 'a0 t -> 'a0 = "js_fn_run_00"
40+
3941
external mk1 : ('a0 -> 'a1) -> ('a0 * 'a1) t =
4042
"js_fn_mk_01"
4143

44+
external run1 : ('a0 * 'a1) t -> 'a0 -> 'a1 =
45+
"js_fn_run_01"
46+
4247
external mk2 : ('a0 -> 'a1 -> 'a2 ) -> ('a0 * 'a1 * 'a2) t =
4348
"js_fn_mk_02"
4449

45-
external mk3 : ('a0 -> 'a1 -> 'a2 -> 'a3 ) -> ('a0 * 'a1 * 'a2 * 'a3) t =
50+
external run2 : ('a0 * 'a1 * 'a2 )t -> 'a0 -> 'a1 -> 'a2 =
51+
"js_fn_run_02"
52+
53+
external mk3 :
54+
('a0 -> 'a1 -> 'a2 -> 'a3 ) -> ('a0 * 'a1 * 'a2 * 'a3) t =
4655
"js_fn_mk_03"
4756

48-
external mk4 : ('a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 ) -> ('a0 * 'a1 * 'a2 * 'a3 * 'a4) t =
57+
external run3 :
58+
('a0 * 'a1 * 'a2 * 'a3) t -> 'a0 -> 'a1 -> 'a2 -> 'a3 =
59+
"js_fn_run_03"
60+
61+
external mk4 : ('a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 )
62+
-> ('a0 * 'a1 * 'a2 * 'a3 * 'a4) t =
4963
"js_fn_mk_04"
5064

51-
external mk5 : ('a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 ) -> ('a0 * 'a1 * 'a2 * 'a3 * 'a4 * 'a5) t =
65+
external run4 : ('a0 * 'a1 * 'a2 * 'a3 * 'a4) t ->
66+
'a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 =
67+
"js_fn_run_04"
68+
69+
external mk5 :
70+
('a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 ) ->
71+
('a0 * 'a1 * 'a2 * 'a3 * 'a4 * 'a5) t =
5272
"js_fn_mk_05"
5373

74+
external run5 :
75+
('a0 * 'a1 * 'a2 * 'a3 * 'a4 * 'a5) t
76+
-> 'a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 =
77+
"js_fn_run_05"
5478

5579
external mk6 : ('a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6) ->
5680
('a0 * 'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6) t =
5781
"js_fn_mk_06"
82+
external run6 : ('a0 * 'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6) t
83+
-> 'a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 =
84+
"js_fn_run_06"
5885

5986
external mk7 : ('a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'a7) ->
6087
('a0 * 'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 ) t =
6188
"js_fn_mk_07"
6289

90+
external run7 : ('a0 * 'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 ) t
91+
-> 'a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'a7 =
92+
"js_fn_run_07"
6393

6494
external mk8 : ('a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'a7 -> 'a8 ) ->
6595
('a0 * 'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 ) t =
6696
"js_fn_mk_08"
6797

98+
external run8 :
99+
('a0 * 'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 ) t ->
100+
'a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'a7 -> 'a8
101+
=
102+
"js_fn_run_08"
68103

69-
external mk9 : ('a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'a7 -> 'a8 -> 'a9) ->
104+
external mk9 :
105+
('a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'a7 -> 'a8 -> 'a9) ->
70106
('a0 * 'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 ) t =
71107
"js_fn_mk_09"
72108

109+
external run9 :
110+
('a0 * 'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 ) t ->
111+
'a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'a7 -> 'a8 -> 'a9 =
112+
"js_fn_run_09"

jscomp/test/.depend

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -128,6 +128,8 @@ equal_test.cmo :
128128
equal_test.cmx :
129129
es6_module_test.cmo : mt.cmi ../stdlib/list.cmi
130130
es6_module_test.cmx : mt.cmx ../stdlib/list.cmx
131+
event_ffi.cmo : ../lib/js_fn.cmo ../lib/js.cmo
132+
event_ffi.cmx : ../lib/js_fn.cmx ../lib/js.cmx
131133
exception_raise_test.cmo : mt.cmi
132134
exception_raise_test.cmx : mt.cmx
133135
ext_array.cmo : ../stdlib/list.cmi ../stdlib/array.cmi
@@ -666,6 +668,8 @@ equal_test.cmo :
666668
equal_test.cmj :
667669
es6_module_test.cmo : mt.cmi ../stdlib/list.cmi
668670
es6_module_test.cmj : mt.cmj ../stdlib/list.cmj
671+
event_ffi.cmo : ../lib/js_fn.cmo ../lib/js.cmo
672+
event_ffi.cmj : ../lib/js_fn.cmj ../lib/js.cmj
669673
exception_raise_test.cmo : mt.cmi
670674
exception_raise_test.cmj : mt.cmj
671675
ext_array.cmo : ../stdlib/list.cmi ../stdlib/array.cmi

0 commit comments

Comments
 (0)