Permalink
Browse files

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

…iler part)
  • Loading branch information...
1 parent 852f58c commit 936d60af8ba765d9a238135812d7f37ff00ac7d8 Valentin Gatien-Baron committed with OpaOnWindowsNow Jun 23, 2011
View
@@ -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?) *)
]
(*
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -441,80 +441,86 @@ 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 *)
let skipped_bp_apply bypass bp_args = IL.Skip (QmlAstCons.UntypedExpr.apply bypass bp_args)
(** 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) ->
@@ -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
@@ -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
@@ -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
@@ -20,3 +20,4 @@ qmlpasses/pass_CleanLambdaLiftingDirectives
qmlpasses/pass_BypassApply
qmlpasses/pass_Purge
qmlpasses/pass_RewriteAsyncLambda
+qmlpasses/pass_InstrumentForClosureSerialization
@@ -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
Oops, something went wrong.

0 comments on commit 936d60a

Please sign in to comment.