Skip to content

Commit

Permalink
Merge 5cb3752 into 35374ea
Browse files Browse the repository at this point in the history
  • Loading branch information
@bobzhang
bobzhang committed Mar 12, 2018
2 parents 35374ea + 5cb3752 commit 48af91f
Show file tree
Hide file tree
Showing 10 changed files with 637 additions and 306 deletions.
2 changes: 1 addition & 1 deletion jscomp/core/bs_conditional_initial.ml
View file
Expand Up @@ -25,7 +25,7 @@

let setup_env () =
#if BS_DEBUG then
Js_config.set_debug_file "test_bool_equal.ml";
Js_config.set_debug_file "gpr_2608_test.ml";
#end
Lexer.replace_directive_bool "BS" true;
Lexer.replace_directive_string "BS_VERSION" Bs_version.version
Expand Down
165 changes: 110 additions & 55 deletions jscomp/core/lam_compile.ml
View file
Expand Up @@ -51,7 +51,8 @@ let rec flat_catches acc (x : Lam.t)
flat_catches ((code,handler,bindings)::acc) l
| _ -> acc, x

let flatten_caches x = flat_catches [] x
let flatten_caches x : (int * Lam.t * Ident.t list ) list * Lam.t =
flat_catches [] x



Expand Down Expand Up @@ -101,12 +102,13 @@ type default_case =
non-toplevel, it will explode code very quickly
*)
let rec
compile_external_field
compile_external_field (* Like [List.empty]*)
(cxt : Lam_compile_context.t)
lam
(lam : Lam.t)
(id : Ident.t)
(pos : int)
env : Js_output.t =
(env : Env.t)
: Js_output.t =
let f = Js_output.output_of_expression cxt.st cxt.should_return lam in
match Lam_compile_env.cached_find_ml_id_pos id pos env with
| {id; name; closed_lambda } ->
Expand Down Expand Up @@ -151,17 +153,23 @@ let rec

and compile_external_field_apply
(cxt : Lam_compile_context.t)
lam
args_lambda
(lam : Lam.t) (* original lambda*)
(args_lambda : Lam.t list)
(id : Ident.t)
(pos : int) env : Js_output.t =
match Lam_compile_env.cached_find_ml_id_pos
id pos env with
(pos : int)
(env : Env.t) : Js_output.t =
match
Lam_compile_env.cached_find_ml_id_pos
id pos env
with
| {id; name;arity; closed_lambda ; _} ->
let args_code, args =
Ext_list.fold_right
(fun (x : Lam.t) (args_code, args) ->
match compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse} x with
match
compile_lambda
{cxt with st = NeedValue; should_return = ReturnFalse} x
with
| {block = a; value = Some b} ->
(Ext_list.append a args_code), (b :: args )
| _ -> assert false
Expand Down Expand Up @@ -223,8 +231,13 @@ and compile_external_field_apply
args (List.length args ))


and compile_let let_kind (cxt : Lam_compile_context.t) id (arg : Lam.t) : Js_output.t =
compile_lambda {cxt with st = Declare (let_kind, id); should_return = ReturnFalse } arg
and compile_let
(let_kind : Lam_compile_context.let_kind)
(cxt : Lam_compile_context.t)
(id : J.ident)
(arg : Lam.t) : Js_output.t =
compile_lambda
{cxt with st = Declare (let_kind, id); should_return = ReturnFalse } arg
(**
The second return values are values which need to be wrapped using
[caml_update_dummy]
Expand Down Expand Up @@ -339,7 +352,8 @@ and compile_recursive_let ~all_bindings
| _ -> assert false
end
| Lvar _ ->
compile_lambda {cxt with st = Declare (Alias ,id); should_return = ReturnFalse } arg, []
compile_lambda
{cxt with st = Declare (Alias ,id); should_return = ReturnFalse } arg, []
| _ ->
(* pathological case:
fail to capture taill call?
Expand All @@ -362,13 +376,16 @@ and compile_recursive_let ~all_bindings
fun _-> print_endline "hey"; v ()
]}
*)
compile_lambda {cxt with st = Declare (Alias ,id); should_return = ReturnFalse } arg, []
compile_lambda
{cxt with st = Declare (Alias ,id); should_return = ReturnFalse } arg, []

and compile_recursive_lets_aux cxt id_args : Js_output.t =
(* #1716 *)
let output_code, ids = Ext_list.fold_right
let output_code, ids =
Ext_list.fold_right
(fun (ident,arg) (acc, ids) ->
let code, declare_ids = compile_recursive_let ~all_bindings:id_args cxt ident arg in
let code, declare_ids =
compile_recursive_let ~all_bindings:id_args cxt ident arg in
(code ++ acc, Ext_list.append declare_ids ids )
) id_args (Js_output.dummy, [])
in
Expand All @@ -388,7 +405,8 @@ and compile_recursive_lets cxt id_args : Js_output.t =
| [ ] -> assert false
| first::rest ->
let acc = compile_recursive_lets_aux cxt first in
List.fold_left (fun acc x -> acc ++ compile_recursive_lets_aux cxt x ) acc rest
List.fold_left
(fun acc x -> acc ++ compile_recursive_lets_aux cxt x ) acc rest
end
and compile_general_cases :
'a .
Expand Down Expand Up @@ -456,14 +474,18 @@ and compile_general_cases :
in
let body =
table
|> Ext_list.stable_group (fun (_,lam) (_,lam1) -> Lam_analysis.eq_lambda lam lam1)
|> Ext_list.stable_group
(fun (_,lam) (_,lam1)
-> Lam_analysis.eq_lambda lam lam1)
|> Ext_list.flat_map
(fun group ->
group
|> Ext_list.map_last
(fun last (x,lam) ->
if last
then {J.case = x; body = Js_output.to_break_block (compile_lambda cxt lam) }
then {J.case = x;
body =
Js_output.to_break_block (compile_lambda cxt lam) }
else { case = x; body = [],false }))
(* TODO: we should also group default *)
(* The last clause does not need [break]
Expand All @@ -472,11 +494,15 @@ and compile_general_cases :
in
[switch ?default ?declaration v body]

and compile_cases cxt = compile_general_cases (fun x -> E.small_int x) E.int_equal cxt
(fun ?default ?declaration e clauses -> S.int_switch ?default ?declaration e clauses)
and compile_cases cxt =
compile_general_cases (fun x -> E.small_int x) E.int_equal cxt
(fun ?default ?declaration e clauses ->
S.int_switch ?default ?declaration e clauses)

and compile_string_cases cxt = compile_general_cases E.str E.string_equal cxt
(fun ?default ?declaration e clauses -> S.string_switch ?default ?declaration e clauses)
and compile_string_cases cxt =
compile_general_cases E.str E.string_equal cxt
(fun ?default ?declaration e clauses ->
S.string_switch ?default ?declaration e clauses)
(* TODO: optional arguments are not good
for high order currying *)
and
Expand All @@ -500,15 +526,15 @@ and


| Lapply{
fn = Lapply{ fn = an; args = args'; status = App_na ; };
fn = Lapply{ fn = an; args = fn_args; status = App_na ; };
args;
status = App_na; loc }
->
(* After inlining we can generate such code,
see {!Ari_regress_test}
*)
compile_lambda cxt
(Lam.apply an (Ext_list.append args' args) loc App_na )
(Lam.apply an (Ext_list.append fn_args args) loc App_na )
(* External function calll *)
| Lapply{ fn =
Lprim{primitive = Pfield (n,_);
Expand Down Expand Up @@ -650,43 +676,70 @@ and
(* Invariant: if [should_return], then [st] will not be [NeedValue] *)
->
compile_lambda cxt (Lam.sequand l r )
| _ ->
let l_block,l_expr =
match compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse} l with
| {block = a; value = Some b} -> a, b
| _ -> assert false
in
let r_block, r_expr =
match compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse} r with
| {block = a; value = Some b} -> a, b
| _ -> assert false
in
let args_code = Ext_list.append l_block r_block in
let exp = E.and_ l_expr r_expr in
Js_output.output_of_block_and_expression st should_return lam args_code exp
| {should_return = ReturnFalse } ->
let new_cxt = {cxt with st = NeedValue} in
match
compile_lambda new_cxt l with
| { value = None } -> assert false
| {block = l_block; value = Some l_expr} ->
match compile_lambda new_cxt r
with
| { value = None } -> assert false
| {block = []; value = Some r_expr}
->
Js_output.output_of_block_and_expression
st
should_return lam l_block (E.and_ l_expr r_expr)
| { block = r_block; value = Some r_expr} ->
let v = Ext_ident.create_tmp () in
Js_output.output_of_block_and_expression
st
should_return
lam
(S.define_variable ~kind:Variable v E.caml_false ::
l_block @
[S.if_ l_expr
(r_block @ [
S.assign v r_expr
]
)
]
)
(E.var v)
end

| Lprim {primitive = Psequor; args = [l;r]}
->
begin match cxt with
| {should_return = ReturnTrue _ }
(* Invariant: if [should_return], then [st] will not be [NeedValue] *)
->
compile_lambda cxt @@ Lam.sequor l r
| _ ->
let l_block,l_expr =
match compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse} l with
| {block = a; value = Some b} -> a, b
| _ -> assert false
in
let r_block, r_expr =
match compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse} r with
| {block = a; value = Some b} -> a, b
| _ -> assert false
in
let args_code = Ext_list.append l_block r_block in
let exp = E.or_ l_expr r_expr in
Js_output.output_of_block_and_expression st should_return lam args_code exp
| {should_return = ReturnFalse } ->
let new_cxt = {cxt with st = NeedValue} in
match compile_lambda new_cxt l with
| {value = None } -> assert false
| {block = l_block; value = Some l_expr} ->
match compile_lambda new_cxt r with
| {value = None} -> assert false
| {block = []; value = Some r_expr} ->
let exp = E.or_ l_expr r_expr in
Js_output.output_of_block_and_expression
st should_return lam l_block exp
| {block = r_block; value = Some r_expr} ->
let v = Ext_ident.create_tmp () in
Js_output.output_of_block_and_expression
st
should_return
lam
(S.define_variable ~kind:Variable v E.caml_true
:: l_block @
[ S.if_ (E.not l_expr)
(r_block @ [
S.assign v r_expr
])
]
)
(E.var v)
end
| Lprim {primitive = Pdebugger ; _}
->
Expand Down Expand Up @@ -1154,7 +1207,9 @@ and
when branches are minimial (less than 2)
*)
let v = Ext_ident.create_tmp () in
Js_output.make (S.declare_variable ~kind:Variable v :: compile_whole {cxt with st = Assign v})
Js_output.make
(S.declare_variable ~kind:Variable v ::
compile_whole {cxt with st = Assign v})
~value:(E.var v)

| Declare (kind,id) ->
Expand Down
1 change: 1 addition & 0 deletions jscomp/test/.depend
View file
Expand Up @@ -304,6 +304,7 @@ gpr_2316_test.cmj : mt.cmj ../runtime/js.cmj
gpr_2474.cmj :
gpr_2487.cmj : ../others/belt.cmj
gpr_2503_test.cmj : mt.cmj ../runtime/js.cmj
gpr_2608_test.cmj : mt.cmj ../stdlib/list.cmj
gpr_405_test.cmj : ../stdlib/hashtbl.cmj gpr_405_test.cmi
gpr_441.cmj :
gpr_459_test.cmj : mt.cmj
Expand Down
1 change: 1 addition & 0 deletions jscomp/test/Makefile
View file
Expand Up @@ -241,6 +241,7 @@ OTHERS := test_literals a test_ari test_export2 test_internalOO test_obj_simple_
gpr_2487\
gpr_2503_test\
block_alias_test\
gpr_2608_test\
# bs_uncurry_test
# needs Lam to get rid of Uncurry arity first
# simple_derive_test
Expand Down
2 changes: 1 addition & 1 deletion jscomp/test/bs_hashtbl_string_test.js
View file
Expand Up @@ -23,7 +23,7 @@ var hashString = (function (str) {
while(i !== 0) {
hash = (hash * 33) ^ str.charCodeAt(--i);
}
return hash
return hash
}
);

Expand Down
16 changes: 12 additions & 4 deletions jscomp/test/ext_string_test.js
View file
Expand Up @@ -59,15 +59,23 @@ function trim(s) {
var i = 0;
var j = s.length;
while((function () {
var u = s.charCodeAt(i);
return +(i < j && (u === /* "\t" */9 || u === /* "\n" */10 || u === /* " " */32));
var tmp = /* false */0;
if (i < j) {
var u = s.charCodeAt(i);
tmp = +(u === /* "\t" */9 || u === /* "\n" */10 || u === /* " " */32);
}
return tmp;
})()) {
i = i + 1 | 0;
};
var k = j - 1 | 0;
while((function () {
var u = s.charCodeAt(k);
return +(k >= i && (u === /* "\t" */9 || u === /* "\n" */10 || u === /* " " */32));
var tmp = /* false */0;
if (k >= i) {
var u = s.charCodeAt(k);
tmp = +(u === /* "\t" */9 || u === /* "\n" */10 || u === /* " " */32);
}
return tmp;
})()) {
k = k - 1 | 0;
};
Expand Down

0 comments on commit 48af91f

Please sign in to comment.