Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

[feature] closure serialisation: adding closure instrumentation (comp…

…iler part)
  • Loading branch information...
commit 936d60af8ba765d9a238135812d7f37ff00ac7d8 1 parent 852f58c
Valentin Gatien-Baron authored OpaOnWindowsNow committed
View
19 libqmlcompil/qmlAst.ml
@@ -791,16 +791,19 @@ type doctype_access_directive =
| `package (* visible only in the current package *)
]
+(**
+ add information around an apply or a lifted lambda
+*)
type lambda_lifting_directive = [
- | `partial_apply of int option (* original arity of the function, guaranteed to be filled by lambda lifting, None means 'undisclosed information' :) *)
- (**
- Used to indicate a partial application
- Must be around an Apply node
- *)
+ | `partial_apply of int option * bool (* original arity of the function, guaranteed to be filled by lambda lifting,
+ None means 'undisclosed information' :)
+ the boolean indicates that this is a creation of serializable closure
+ (so the partial apply may have extra type arguments) *)
| `full_apply of int (* size of the env *)
- | `lifted_lambda of int * Ident.t list
- (* size of the env and the toplevel name of the hierarchy of functions
- * from which it was lifted (innermost function first) *)
+ | `lifted_lambda of int * Ident.t option (* size of the env and the toplevel name of the declaration from where it was lifted
+ * (meaningful between lambda lifting and explicit instantiation, because
+ * ei adds @lifted_lambda on declarations that are not really lifted, so
+ * what would the value be?) *)
]
(*
View
7 libqmlcompil/qmlAstCons.ml
@@ -629,8 +629,11 @@ struct
match ty_func with
| Q.TypeArrow (more_params,more_ty) ->
let tparams = tparams @ more_params in
- assert (params_len = List.length tparams);
- tparams, more_ty
+ if params_len = List.length tparams then
+ tparams, more_ty
+ else (
+ OManager.i_error "QmlAstCons.TypedExpr.apply_gen: try to apply %d args to a function [%a] with %d-%d parameters (type = %a) (at %s)" params_len QmlPrint.pp#expr func (List.length tparams) (List.length more_params) QmlPrint.pp#ty (QmlAnnotMap.find_ty annot annotmap) (FilePos.to_string pos)
+ )
| _ -> assert false
) in
let tparams = List.drop params_len tparams in
View
8 libqmlcompil/qmlEffects.ml
@@ -276,7 +276,7 @@ struct
(try instantiate level (IdentMap.find i env)
with Not_found -> Printf.printf "Not found %s\n%!"
(Ident.to_string i);
- assert false)
+ assert false)
| Q.LetIn (_, iel,e) ->
let env =
List.fold_left
@@ -300,8 +300,8 @@ struct
let effect = next_eff_var level in
let ty = infer bp env effect (level+1) e in
Arrow (ref false,List.map snd styl, (S.no_effect,effect), ty)
- | Q.Directive (_, `partial_apply missing, [e], _) -> (
- let missing = Option.get missing in
+ | Q.Directive (_, `partial_apply (info,_), e :: _, _) -> (
+ let missing = Option.get info in
match e with
| Q.Apply (_, e, el) ->
(* no change on the current effect, since it is a partial
@@ -364,11 +364,11 @@ struct
| Q.Directive (_, `fail, el, _) ->
List.iter (fun e -> ignore (infer bp env effect level e)) el;
next_var level
+
| Q.Directive (_, ( `restricted_bypass _
| #Q.type_directive
| `recval
| #Q.slicer_directive
- | `partial_apply _
| `lifted_lambda _
| `full_apply _
| `assert_), l, _) -> (
View
4 libqmlcompil/qmlPrint.ml
@@ -147,8 +147,8 @@ let directive (d:QmlAst.qml_directive) =
| `xmlizer -> "@xmlizer"
| `llarray -> "@llarray"
| `specialize variant -> Printf.sprintf "@specialize%s" (match variant with `strict -> "_strict" | `polymorphic -> "")
- | `partial_apply None -> "@partial_apply"
- | `partial_apply (Some i) -> Printf.sprintf "@partial_apply[misssing:%d]" i
+ | `partial_apply (None, ser) -> Printf.sprintf "@partial_apply[ser:%B]" ser
+ | `partial_apply (Some i, ser) -> Printf.sprintf "@partial_apply[missing:%d,ser:%B]" i ser
| `full_apply n -> Printf.sprintf "@full_apply[env %d]" n
| `lifted_lambda (n,l) ->
Format.sprintf "@@lifted_lambda[env %d,[%a]]"
View
2  opa/main.ml
@@ -181,6 +181,8 @@ let () =
|> PH.old_if_handler
"EarlyLambdaLifting" S2.pass_EarlyLambdaLifting
+ |+> ("InstrumentForClosureSerialization", S3.pass_InstrumentForClosureSerialization)
+
(**********************************************)
(* SLICED PASSES ******************************)
<?> (If.server or If.separated or If.slicer_test,
View
13 opa/s3Passes.ml
@@ -1074,6 +1074,19 @@ let pass_SimplifyMagic =
)
~invariant:(global_invariant ())
+let pass_InstrumentForClosureSerialization =
+ PassHandler.make_pass
+ (fun e ->
+ let env = (e.PH.env : 'tmp_env Passes.env_Gen) in
+ let {Passes.typerEnv = typerEnv; qmlAst = code} = env in
+ let {QmlTypes.annotmap = annotmap; gamma = gamma} = typerEnv in
+ let gamma, annotmap, code = Pass_InstrumentForClosureSerialization.process_code gamma annotmap code in
+ let typerEnv = {typerEnv with QmlTypes.annotmap = annotmap; gamma} in
+ let env = {env with Passes.typerEnv = typerEnv; qmlAst = code} in
+ {e with PH.env = env}
+ )
+ ~invariant:(global_invariant ())
+
let pass_ReorderEnvGen =
PassHandler.make_pass
(fun e ->
View
3  opa/s3Passes.mli
@@ -288,6 +288,9 @@ val pass_SimplifyEquality :
val pass_SimplifyMagic :
(Pass_SimplifyMagic.env Passes.env_Gen, unit Passes.env_Gen) opa_pass
+val pass_InstrumentForClosureSerialization :
+ (unit Passes.env_Gen, unit Passes.env_Gen) opa_pass
+
val pass_ReorderEnvGen :
(unit Passes.env_Gen, unit Passes.env_Gen) opa_pass
View
115 qmlcps/qmlCpsRewriter.ml
@@ -441,9 +441,12 @@ module U = struct
(** skipped_apply fskip_id f_args :
create the IL application of the SKIPPED function fskip_id with QML IDENT arguments *)
- let skipped_apply ?(partial=false) fskip_id f_args =
+ let skipped_apply ?partial fskip_id f_args =
let e = QmlAstUtils.App.from_list (Q.Ident (label (), fskip_id) :: f_args ) in
- let e = if partial then Q.Directive (label (), `partial_apply None, [e], []) else e in
+ let e =
+ match partial with
+ | None -> e
+ | Some (more_args, ser) -> Q.Directive (label (), `partial_apply (None,ser), e :: more_args, []) in
IL.Skip e
(** same for bypass *)
@@ -451,70 +454,73 @@ module U = struct
(** bad_apply_property f f_args : check that all args are idents that don't need rewriting
and that f is either an non barrier ident or a bypass *)
- let good_apply_property penv f f_args =
+ let good_apply_property ?(more_args=[]) penv f f_args =
List.for_all (is_stable_ident penv) f_args
+ && List.for_all (is_stable_ident penv) more_args
&& is_not_barrier_ident_or_internal_bypass penv f
(** transform the expression so that the apply has the good property
gives name to all element in need for cps rewriting *)
- let normalize_apply_property ?stack_info ?(partial=false) penv f f_args =
- let f_and_args = f::f_args in
- let rec fold ?(head_is_f=false) f_and_args (bindings, ids) =
- let s_fold e l= fold l (bindings, (e :: ids)) in
- match f_and_args with
- (* keep already named *)
- (* 1 eventually the function *)
- | (Q.Bypass _ | Q.Directive (_, `restricted_bypass _, _, _) as e) :: l
- when head_is_f -> s_fold e l
- (* 2 function and args *)
- | (Q.Ident _ as e) :: l
- when is_stable_ident penv e
- || (head_is_f && is_not_barrier_ident_or_internal_bypass penv f)
- -> s_fold e l
- (* name all others *)
- | e :: l ->
+ let normalize_apply_property ?stack_info ?partial penv f f_args =
+ let name_arg (bindings,exprs) e =
+ match e with
+ | Q.Ident _ when is_stable_ident penv e -> (bindings, e :: exprs)
+ | _ ->
let id = Ident.next "arg" in
- fold l (((id, e) :: bindings), Q.Ident (label (), id) :: ids)
- (* create the letin if needed *)
- | [] when bindings = [] -> assert false
- | [] ->
- let app = QmlAstUtils.App.from_list (List.rev ids) in
- let app =
- match stack_info with
- | None -> app
- | Some info -> Q.Directive (label (), `cps_stack_apply info, [app], []) in
- let app =
- if partial then Q.Directive (label (), `partial_apply None, [app], [])
- else app in
- Q.LetIn (label (), bindings, app)
- in fold ~head_is_f:true f_and_args ([],[])
+ ((id,e) :: bindings, Q.Ident (label (), id) :: exprs) in
+ let acc =
+ match f with
+ | Q.Bypass _ | Q.Directive (_, `restricted_bypass _, _, _) ->
+ ([],[f])
+ | Q.Ident _ when is_stable_ident penv f || is_not_barrier_ident_or_internal_bypass penv f ->
+ ([],[f])
+ | _ ->
+ name_arg ([],[]) f in
+ let bindings, rev_args = List.fold_left name_arg acc f_args in
+ let bindings, rev_more_args_opt =
+ match partial with
+ | None -> bindings, None
+ | Some (more_args, ser) ->
+ let bindings, rev_more_args = List.fold_left name_arg (bindings,[]) more_args in
+ bindings, Some (rev_more_args, ser) in
+ let app = QmlAstUtils.App.from_list (List.rev rev_args) in
+ let app =
+ match stack_info with
+ | None -> app
+ | Some info -> Q.Directive (label (), `cps_stack_apply info, [app], []) in
+ let app =
+ match rev_more_args_opt with
+ | None -> app
+ | Some (rev_more_args, ser) ->
+ Q.Directive (label (), `partial_apply (None,ser), (app :: List.rev rev_more_args), []) in
+ Q.LetIn (label (), bindings, app)
let rewrite_apply_partial context f_id f_args =
let e = IL.Skip (QC.apply (QC.ident f_id) f_args) in
if Skip.can then e
else Skip.remove e context
- let rewrite_apply ?stack_info ?(partial=false) ~private_env ~expr ~context f_id f_args =
+ let rewrite_apply ?stack_info ?partial ~private_env ~expr ~context f_id f_args =
match private_env_get_skipped_fun f_id private_env with
- | Some(real_arity, fskip_id, fcps_id) ->
- if partial then
- (* skipped version exists but incomplete call *)
- skipped_apply ~partial fcps_id f_args
- else (
- (* skipped version exists, complete call *)
- if List.length f_args <> real_arity then (
- Format.printf "Partial apply (expected %d args, get %d) in CpsRewriter :@\n%a@."
- real_arity (List.length f_args) QmlPrint.pp#expr expr;
- assert false
- );
- skipped_apply ~partial fskip_id f_args
+ | Some(real_arity, fskip_id, fcps_id) -> (
+ match partial with
+ | Some _ ->
+ (* skipped version exists but incomplete call *)
+ skipped_apply ?partial fcps_id f_args
+ | None ->
+ (* skipped version exists, complete call *)
+ if List.length f_args <> real_arity then (
+ Format.printf "Partial apply (expected %d args, get %d) in CpsRewriter :@\n%a@."
+ real_arity (List.length f_args) QmlPrint.pp#expr expr;
+ assert false
+ );
+ skipped_apply ?partial fskip_id f_args
)
| None ->
(* skipped version don t exist *)
- if partial then
- skipped_apply ~partial f_id f_args
- else
- cps_apply ?stack_info f_id f_args context
+ match partial with
+ | Some _ -> skipped_apply ?partial f_id f_args
+ | None -> cps_apply ?stack_info f_id f_args context
let is_const e =
match e with
@@ -728,14 +734,15 @@ let il_of_qml ?(can_skip_toplvl=false) (env:env) (private_env:private_env) (expr
to guaranty property : f is a non barrier ident or a bypass, f_args are stable identifiers *)
| Q.Apply (_, f, f_args) when not(U.good_apply_property private_env f f_args) ->
aux_can_skip (U.normalize_apply_property private_env f f_args) context
- | Q.Directive (_, `partial_apply _, [Q.Apply (_, f, f_args)], _) when not(U.good_apply_property private_env f f_args) ->
- aux_can_skip (U.normalize_apply_property private_env ~partial:true f f_args) context
+ | Q.Directive (_, `partial_apply (_,ser), Q.Apply (_, f, f_args) :: more_args, _)
+ when not (U.good_apply_property ~more_args private_env f f_args) ->
+ aux_can_skip (U.normalize_apply_property private_env ~partial:(more_args,ser) f f_args) context
(* guaranteed property : f is a non barrier ident, f_args are stable identifiers *)
| Q.Apply (_, Q.Ident (_, f_id), f_args) ->
U.rewrite_apply ~private_env ~expr ~context f_id f_args
- | Q.Directive (_, `partial_apply _, [Q.Apply (_, Q.Ident (_, f_id), f_args)], _) ->
- U.rewrite_apply ~partial:true ~private_env ~expr ~context f_id f_args
+ | Q.Directive (_, `partial_apply (_, ser), Q.Apply (_, Q.Ident (_, f_id), f_args) :: more_args, _) ->
+ U.rewrite_apply ~partial:(more_args,ser) ~private_env ~expr ~context f_id f_args
(* guaranteed property : f is a bypass, f_args are stable identifiers *)
| Q.Apply (_, bypass, bp_args) ->
View
2  qmlflat/flat/flat_ExprGeneration.ml
@@ -191,7 +191,7 @@ let expr env expr =
| Q.Coerce (_, expr, _) ->
aux expr
- | Q.Directive (_, `partial_apply (Some 0), [e], _) when not env.E.options.P.cps && not env.E.options.P.qml_closure ->
+ | Q.Directive (_, `partial_apply (Some 0, _), [e], _) when not env.E.options.P.cps && not env.E.options.P.qml_closure ->
(* i think that the directive @partial_apply (Some 0) may stay in the code
* even when closures are activated, but in that case, they have been taken
* care of already
View
13 qmljsimp/imp_Code.ml
@@ -285,11 +285,14 @@ let compile_expr_to_expr env private_env expr =
| Q.Apply (_, f, args) ->
aux_apply ~pure:false private_env f args
- | Q.Directive (_, `partial_apply _, l, _) ->
- (match l with
- | [Q.Apply (_, f, args)] ->
- aux_apply ~pure:true private_env f args
- | _ -> assert false)
+
+ | Q.Directive (_, `partial_apply (Some _, true), e :: _, _) (* TODO *)
+
+ | Q.Directive (_, `partial_apply ((Some _ | None), false), [e], _) ->
+ begin match e with
+ | Q.Apply (_, f, args) -> aux_apply ~pure:true private_env f args
+ | _ -> assert false
+ end
| Q.LetIn (_, iel, e) ->
let private_env, exprs =
View
2  qmljsimp/imp_Compiler.ml
@@ -98,7 +98,7 @@ let compile ?(val_=fun _ -> assert false) ?bsl ?(closure_map=IdentMap.empty) ~re
label,
QmlAst.Directive
(label,
- `partial_apply None,
+ `partial_apply (None, false),
[QmlAst.Apply (label2, fun_, env_args)],
[]),
args)
View
1  qmlpasses.mllib
@@ -20,3 +20,4 @@ qmlpasses/pass_CleanLambdaLiftingDirectives
qmlpasses/pass_BypassApply
qmlpasses/pass_Purge
qmlpasses/pass_RewriteAsyncLambda
+qmlpasses/pass_InstrumentForClosureSerialization
View
34 qmlpasses/pass_ExplicitInstantiation.ml
@@ -1553,15 +1553,35 @@ let walk_undirective ~val_ side gamma toplevel_lambdas annotmap e =
| Q.Coerce (_,_,_)
| Q.Directive (_,#Q.type_directive,_,_) -> tra context annotmap e
- | Q.Directive (label, (`partial_apply _ | `full_apply _ as v), [Q.Apply (_, Q.Directive (_, `apply_ty_arg (lt,lrow,lcol), [de], _),args)], _) -> (
+ | Q.Directive (label, (`partial_apply _ | `full_apply _ as v), (Q.Apply (_, Q.Directive (_, `apply_ty_arg (lt,lrow,lcol), [de], _),args) :: other_args), _) -> (
assert (match try_get_ident de with `ident x -> IdentSet.mem x toplevel_lambdas | `call -> true | `none -> false);
let annotmap, args' = aux_lambda abstracted_set annotmap de lt lrow lcol in
let annotmap, e = QmlAstCons.TypedExpr.apply_partial gamma annotmap de (args' @ args) in
- let v =
+ let v, other_args, annotmap =
match v with
- | `partial_apply missing -> `partial_apply missing
- | `full_apply env -> `full_apply (env + List.length lt + List.length lrow + List.length lcol) in
- let e = Q.Directive (label, v, [e], []) in
+ | `partial_apply ((_, false) as missing) ->
+ (* unserializable closure, don't do anything *)
+ `partial_apply missing, other_args, annotmap
+ | `partial_apply ((_, true) as missing) ->
+ (* serializable closure, update the other args because the env was enriched
+ * with types *)
+ let annotmap, other_args_ty =
+ List.fold_left_map (
+ fun annotmap _ -> arg_of_type ~val_ side abstracted_set gamma annotmap opatype_type
+ ) annotmap lt in
+ let annotmap, other_args_row =
+ List.fold_left_map (
+ fun annotmap _ -> arg_of_type ~val_ side abstracted_set gamma annotmap oparow_type
+ ) annotmap lrow in
+ let annotmap, other_args_col =
+ List.fold_left_map (
+ fun annotmap _ -> arg_of_type ~val_ side abstracted_set gamma annotmap opacol_type
+ ) annotmap lcol in
+ let other_args = other_args_ty @ other_args_row @ other_args_col @ other_args in
+ `partial_apply missing, other_args, annotmap
+ | `full_apply env ->
+ `full_apply (env + List.length lt + List.length lrow + List.length lcol), other_args, annotmap in
+ let e = Q.Directive (label, v, (e :: other_args), []) in
tra (abstracted_set,false) annotmap e
)
@@ -1577,10 +1597,10 @@ let walk_undirective ~val_ side gamma toplevel_lambdas annotmap e =
let annotmap, e = QmlAstCons.TypedExpr.apply_partial gamma annotmap de args in
match try_get_ident de with
| `ident x when IdentSet.mem x toplevel_lambdas ->
- let annotmap, e = QmlAstCons.TypedExpr.directive annotmap (`partial_apply None) [e] [] in
+ let annotmap, e = QmlAstCons.TypedExpr.directive annotmap (`partial_apply (None,false)) [e] [] in
tra (abstracted_set,false) annotmap e
| `call ->
- let annotmap, e = QmlAstCons.TypedExpr.directive annotmap (`partial_apply None) [e] [] in
+ let annotmap, e = QmlAstCons.TypedExpr.directive annotmap (`partial_apply (None,false)) [e] [] in
tra (abstracted_set,false) annotmap e
| _ ->
tra (abstracted_set,false) annotmap e
View
136 qmlpasses/pass_InstrumentForClosureSerialization.ml
@@ -0,0 +1,136 @@
+(*
+ Copyright © 2011 MLstate
+
+ This file is part of OPA.
+
+ OPA is free software: you can redistribute it and/or modify it under the
+ terms of the GNU Affero General Public License, version 3, as published by
+ the Free Software Foundation.
+
+ OPA is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+ FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
+ more details.
+
+ You should have received a copy of the GNU Affero General Public License
+ along with OPA. If not, see <http://www.gnu.org/licenses/>.
+*)
+
+module Q = QmlAst
+module Cons = QmlAstCons.TypedExpr
+module List = BaseList
+
+type env = Ident.t * (Q.ty,unit) QmlGenericScheme.tsc option IdentMap.t
+
+let empty = IdentMap.empty
+
+let extract_env_type env_size gamma ty =
+ match QmlTypesUtils.Inspect.get_arrow_through_alias_and_private gamma ty with
+ | Some (l1,ret) ->
+ assert (List.length l1 >= env_size);
+ let l1, l2 = List.split_at env_size l1 in
+ l1, Q.TypeArrow (l2, ret), l2, ret
+ | None -> assert false
+
+let generate_typeofer gamma annotmap env (i,e) =
+ match e with
+ | Q.Directive (_, `lifted_lambda (env_size, function_of_origin), [_], _) ->
+ let new_i = Ident.refreshf ~map:"%s_ser" i in
+ let tsc_gen_opt = QmlAnnotMap.find_tsc_opt (Q.QAnnot.expr e) annotmap in
+ let ty_i = QmlAnnotMap.find_ty (Q.QAnnot.expr e) annotmap in
+ let ty_i =
+ (* refreshing or else ei will stupidly propagate type vars to the original def *)
+ let tsc = QmlTypes.Scheme.quantify ty_i in
+ let tsc = QmlTypes.Scheme.refresh tsc in
+ let _quant, ty_i, () = QmlGenericScheme.export_unsafe tsc in
+ ty_i in
+ let ty_env, ty_remaining, ty_args, _ty_ret = extract_env_type env_size gamma ty_i in
+ let annotmap, g = Cons.ident annotmap i (*ty_i*) (Q.TypeArrow (ty_env, ty_remaining)) in
+ let annotmap = QmlAnnotMap.add_tsc_inst_opt (Q.QAnnot.expr g) tsc_gen_opt annotmap in
+ let new_tsc_gen_opt, gamma =
+ let ty = Q.TypeArrow (ty_env,ty_remaining) in
+ let tsc = QmlTypes.Scheme.quantify ty in
+ let gamma = QmlTypes.Env.Ident.add i tsc gamma in
+ let tsc_opt =
+ if QmlGenericScheme.is_empty tsc then
+ None
+ else
+ Some tsc in
+ tsc_opt, gamma in
+ let params = List.init env_size (fun i -> Ident.next ("eta_" ^ string_of_int i)) in
+ let annotmap, args = List.fold_left_map2 (fun annotmap i ty -> Cons.ident annotmap i ty) annotmap params ty_env in
+ let annotmap, apply_g = Cons.apply_partial gamma annotmap g args in
+ let partial_apply = `partial_apply (Some (List.length ty_args), true) in
+ let annotmap, typeofs =
+ List.fold_left_map2
+ (fun annotmap i ty ->
+ let annotmap, i = Cons.ident annotmap i ty in
+ Cons.directive annotmap `typeof [i] []
+ ) annotmap params ty_env in
+ let annotmap, body =
+ let label = Annot.refresh (Q.Label.expr e) in
+ let annotmap = QmlAnnotMap.add_ty_label label ty_remaining annotmap in
+ annotmap, Q.Directive (label,partial_apply,apply_g::typeofs,[]) in
+ let annotmap, fun_ = Cons.lambda annotmap (List.combine params ty_env) body in
+ (* the @lifted_lambda is for the slicer, so that it puts the function on the right side
+ * (which is the side of function_of_origin)
+ * this probably won't work when we have local annotation, because this function should
+ * be on the side of the lambda it is created from instead *)
+ let annotmap, fun_ = Cons.directive_id annotmap (`lifted_lambda (0, function_of_origin)) fun_ in
+ let annotmap =
+ QmlAnnotMap.add_tsc_opt (Q.QAnnot.expr fun_) new_tsc_gen_opt annotmap in
+ let env = IdentMap.add i (new_i, new_tsc_gen_opt) env in
+ Some (gamma, annotmap, env, new_i, fun_)
+ | _ ->
+ None
+
+let generate_new_binding (gamma, annotmap, env) iel =
+ List.fold_left_filter_map
+ (fun (gamma, annotmap, env) (i,e) ->
+ match generate_typeofer gamma annotmap env (i,e) with
+ | None -> (gamma, annotmap, env), None
+ | Some (gamma, annotmap, env, i, e) -> (gamma, annotmap, env), Some (i,e)
+ ) (gamma, annotmap, env) iel
+
+let rewrite_identifiers env annotmap code =
+ QmlAstWalk.CodeExpr.fold_map
+ (QmlAstWalk.Expr.foldmap
+ (fun annotmap e ->
+ match e with
+ | Q.Directive (_, `partial_apply (_,false), [Q.Apply (label2, Q.Ident (label1, i), args)], _)
+ when IdentMap.mem i env ->
+ let new_ident, tsc_opt = IdentMap.find i env in
+ let e = Q.Apply (label2, Q.Ident (label1, new_ident), args) in
+ let annotmap = QmlAnnotMap.remove_tsc_inst_label label1 annotmap in
+ let annotmap = QmlAnnotMap.add_tsc_inst_opt_label label1 tsc_opt annotmap in
+ annotmap, e
+ | _ ->
+ annotmap, e
+ )
+ ) annotmap code
+
+let process_code gamma annotmap code =
+ if ObjectFiles.stdlib_packages (ObjectFiles.get_current_package ()) then
+ gamma, annotmap, code
+ else
+ let (gamma, annotmap, env), code =
+ List.fold_left_collect
+ (fun acc code_elt ->
+ match code_elt with
+ | Q.NewVal (label,iel) ->
+ let acc, new_iel = generate_new_binding acc iel in
+ let code =
+ if new_iel = [] then
+ [code_elt]
+ else
+ [code_elt; Q.NewVal (Annot.refresh label,new_iel)] in
+ acc, code
+ | Q.NewValRec (label,iel) ->
+ let acc, new_iel = generate_new_binding acc iel in
+ let code = [Q.NewValRec (label,iel @ new_iel)] in
+ acc, code
+ | _ ->
+ assert false
+ ) (gamma, annotmap, empty) code in
+ let annotmap, code = rewrite_identifiers env annotmap code in
+ gamma, annotmap, code
View
89 qmlpasses/pass_InstrumentForClosureSerialization.mli
@@ -0,0 +1,89 @@
+(*
+ Copyright © 2011 MLstate
+
+ This file is part of OPA.
+
+ OPA is free software: you can redistribute it and/or modify it under the
+ terms of the GNU Affero General Public License, version 3, as published by
+ the Free Software Foundation.
+
+ OPA is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+ FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
+ more details.
+
+ You should have received a copy of the GNU Affero General Public License
+ along with OPA. If not, see <http://www.gnu.org/licenses/>.
+*)
+
+val process_code : QmlTypes.gamma -> QmlAst.annotmap -> QmlAst.code -> QmlTypes.gamma * QmlAst.annotmap * QmlAst.code
+
+(*
+ The transformation related to closure serialization is as follows:
+
+ --- Source code
+ f(x:list) =
+ g(y) = (x,y)
+ (g,g(1))
+
+ --- After the early lambda lifting
+ g(x,y) = (x,y)
+ f(x) =
+ (@partial_apply(g(x)),g(x,1))
+
+ --- After instrumentation by this pass
+ g(x,y) = (x,y)
+ g'(x) = @partial_apply(g(x),@typeof(x))
+ f(x) =
+ (g'(x),g(x,1))
+
+ --- After ei
+ g(x,y) = (x,y)
+ g'(ty,x) = @partial_apply(g(x),list(ty))
+ f(ty,x) =
+ (g'(ty,x),g(x,1))
+
+ --- After closures, assuming no cps:
+ g(x,y) = (x,y)
+ clos_g = %%closure_create%%(g,2,true)
+ g'(ty,x) = %%closure_apply_env_with_ty%%(clos_g,@llarray(x),@llarray(list(ty)))
+ // no need to create a closure for g', it is the code that creates the closures
+ f(ty,x) =
+ (g'(ty,x),g(x,1))
+ clos_f = %%closure_create%%(f,2,true)
+
+
+ And the more complicated case, where the lifted function is recursive through its closure:
+ --- Source code
+ id(x) = x
+ f(x:list) =
+ rec g(y) = if true then x else id(g)(y)
+ g
+
+ --- After early ll
+ id(x) = x
+ rec g(x,y) = if true then x else id(@partial_apply(g(x)))(y)
+ f(x) =
+ @partial_apply(g(x))
+
+ --- After instrumentation
+ id(x) = x
+ rec g(x,y) = if true then x else id(g'(x))(y)
+ and g'(x) = @partial_apply(g(x),OpaType.ty,@typeof(x)) // tricky case, we must anticipate
+ // the addition of a typevar by ei
+ f(x) = g'(x)
+
+ --- After ei
+ id(x) = x
+ rec g(ty,x,y) = if true then x else id(g'(ty,x))(y)
+ and g'(ty,x) = @partial_apply(g(ty,x),OpaType.ty,list(ty))
+ f(ty,x) = g'(ty,x)
+
+ --- After closures:
+ id(x) = x
+ clos_id(x) = %%closure_create%%(id,1,true)
+ clos_g = %% closure_create_no_function%%(3,true)
+ rec g(ty,x,y) = if true then x else @clos_apply(id(g'(ty,x)),y)
+ and g'(ty,x) = %%closure_apply_env_with_ty%%(clos_g,@llarray(ty,x),@llarray(OpaType.ty,list(ty)))
+ f(ty,x) = g'(ty,x)
+*)
View
2  qmlpasses/pass_LambdaLifting.ml
@@ -722,7 +722,7 @@ let rec parameterLiftExp ~options ?outer_apply ((gamma,annotmap,env) as full_env
| None ->
assert (original_arity <> -1);
let tsc_gen_opt = QmlAnnotMap.find_tsc_opt_label label annotmap in
- e, [], `partial_apply (Some original_arity), tsc_gen_opt
+ e, [], `partial_apply (Some original_arity,false), tsc_gen_opt
(* ident with an env -> partial application *)
| Some ({applied = e; args = el; used; tsc_gen_opt} as context) ->
(* full apply (if the user code didn't contain
View
11 qmlpasses/pass_Uncurry.ml
@@ -49,7 +49,11 @@ module S =
struct
type t = env
let pass = "qmlUncurry"
- let pp f _ = Format.pp_print_string f "<dummy>"
+ let pp f {funcs} =
+ IdentMap.iter
+ (fun _ {arity;code;closure} ->
+ Format.fprintf f "%s: arity: %d, clos %s@\n" (Ident.to_string code) arity (Ident.to_string closure)
+ ) funcs
end
module R =
@@ -286,8 +290,9 @@ let rewrite_expr cons env e =
with Not_found -> e
)
- | Q.Directive (label2, `partial_apply missing, [Q.Apply (_, Q.Ident (label, x), args)], []) ->
+ | Q.Directive (label2, `partial_apply missing, (Q.Apply (_, Q.Ident (label, x), args) :: more_args), []) ->
let args = List.map self args in
+ let more_args = List.map self more_args in
let func_info =
try IdentMap.find x env.funcs
with Not_found ->
@@ -297,7 +302,7 @@ let rewrite_expr cons env e =
because only the lambda lifting introduces such cases
*)
let f = get_closure_ident cons (Annot.annot label) func_info in
- Q.Directive (label2, `partial_apply missing, [closure_apply cons label2 f args], [])
+ Q.Directive (label2, `partial_apply missing, (closure_apply cons label2 f args :: more_args), [])
| Q.Directive (_, `partial_apply _, _, _) -> assert false
View
1  stdlib/core/core_client_code.opa
@@ -61,6 +61,7 @@ type Client_code.output =
* {3 Interface}
*/
+@server_private
Core_client_code =
{{
/*
Please sign in to comment.
Something went wrong with that request. Please try again.