Permalink
Browse files

[fix] compiler, cps, jsimp: Fix some troubles around cps, lambda lift…

…ing and jsimp compiler
  • Loading branch information...
1 parent 606d69c commit 859f7fd232bfbd35f5c6ea75df1b5d8bc22d17e2 @BourgerieQuentin BourgerieQuentin committed Jun 28, 2012
Showing with 27 additions and 7 deletions.
  1. +22 −3 qmlcps/qmlCpsRewriter.ml
  2. +4 −3 qmljsimp/imp_Compiler.ml
  3. +1 −1 qmljsimp/imp_Warnings.ml
View
@@ -1076,6 +1076,12 @@ let il_of_qml ?(can_skip_toplvl=false) (env:env) (private_env:private_env) (expr
| Q.Directive (_, `partial_apply _, _, _) -> assert false
+ | Q.Directive (a, ((`lifted_lambda _ | `full_apply _) as d), [e], tys) ->
+ begin match aux_can_skip ~can_skip_lambda e context with
+ | IL.Skip e -> IL.Skip (Q.Directive (a, d, [e], tys))
+ | term -> IL.Directive (d, [term], tys)
+ end
+
(* other directive : no specific tratement done in the cps *)
| Q.Directive (_, directive, exprs, tys) ->
let terms = List.map (fun expr -> aux expr context) exprs in
@@ -1480,7 +1486,9 @@ let private_env_add_skipped_fun id arity fskip_id fcps_id private_env =
skipped_functions = IdentMap.add id (arity, fskip_id, fcps_id) private_env.skipped_functions
}
-let simpl_let_in = function
+let rec simpl_let_in = function
+ | Q.Directive (l, d, [e], tys) ->
+ Q.Directive (l, d, [simpl_let_in e], tys)
| Q.LetIn (_, [(x, expr)], Q.Ident (_, y)) when Ident.equal x y -> expr
| expr -> expr
@@ -1558,7 +1566,18 @@ let code_elt (env:env) (private_env:private_env) code_elt =
let fskip = e in
let fskip_id = Ident.refreshf ~map:"%s_skip" id in
let private_env = private_env_add_skipped_fun id arity fskip_id id private_env in
- let fskip_eta_exp = QmlAstUtils.Lambda.eta_expand_ast arity (QC.ident id) in
+ let fskip_eta_exp =
+ match fskip with
+ | Q.Directive (l, (`lifted_lambda (env, _) as ll), [_e], tys) ->
+ let fskip_eta_exp =
+ match QmlAstUtils.Lambda.eta_expand_ast arity (QC.ident id) with
+ | Q.Lambda (l, args, e) ->
+ Q.Lambda (l, args, (Q.Directive (l, `full_apply env, [e], [])))
+ | _ -> assert false
+ in
+ Q.Directive(l, ll, [fskip_eta_exp], tys)
+ | _ -> QmlAstUtils.Lambda.eta_expand_ast arity (QC.ident id)
+ in
let private_env, fcps_il = il_of_qml env private_env fskip_eta_exp in
let private_env, fcps = qml_of_il ~toplevel_cont env private_env fcps_il in
let fcps = simpl_let_in fcps in
@@ -1596,7 +1615,7 @@ let code_elt (env:env) (private_env:private_env) code_elt =
| Q.LetIn _
| Q.LetRecIn _ -> immediate_value_or_barrier ()
- | Q.Directive (_, `restricted_bypass _, [Q.Lambda (_, l, _)], _)
+ | Q.Directive (_, (`restricted_bypass _ | `lifted_lambda _), [Q.Lambda (_, l, _)], _)
| Q.Lambda (_, l, _) -> immediate_lambda (List.length l)
| Q.Apply _ -> immediate_value_or_barrier ~can_skip_toplvl:true ()
View
@@ -91,19 +91,20 @@ let compile ?(val_=fun _ -> assert false) ?bsl ?(closure_map=IdentMap.empty) ~re
| QmlAst.Directive (label, `full_apply env, [QmlAst.Apply (label2,fun_,args) as sub], _) ->
if env = 0 then sub else
let env_args, args = List.split_at env args in
- let missing = List.length args - env + 1 in
+ let _missing = List.length args - env + 1 in
(* same here *)
(* BEWARE duplicating the annotation [label] is bad, but the
* backend doesn't care about that and then they are lost *)
QmlAst.Apply (
label,
QmlAst.Directive
(label,
- `partial_apply (Some missing, false),
+ `partial_apply (None, false),
[QmlAst.Apply (label2, fun_, env_args)],
[]),
args)
- | QmlAst.Directive (_,(`lifted_lambda _ | `full_apply _),_,_) -> assert false
+ | QmlAst.Directive (_,(`lifted_lambda _ | `full_apply _),_,_) as expr ->
+ OManager.i_error "Unexpected expression %a\n%!" QmlPrint.pp#expr expr
| e -> e)
) code in
View
@@ -26,7 +26,7 @@ let wclass = Qml2js.wclass
let missing_type =
let doc = "Missing type annotation, pattern matching not optimized" in
- WarningClass.create ~parent:wclass ~name:"missing-type" ~doc ~err:false ~enable:true ()
+ WarningClass.create ~parent:wclass ~name:"missing-type" ~doc ~err:false ~enable:false ()
let warning_set =
WarningClass.Set.create_from_list [

0 comments on commit 859f7fd

Please sign in to comment.