Skip to content
Browse files

[feature] closure serialisation: restrict to new @public_env directive

  • Loading branch information...
1 parent 9176810 commit 2536662d4ec2ea05acd3d4c9982fe68ee7564bbd @OpaOnWindowsNow OpaOnWindowsNow committed
View
5 libqmlcompil/qmlAst.ml
@@ -701,6 +701,10 @@ type slicer_directive =
| visibility_directive
]
+type closure_instrumentation_directive = [
+ `public_env
+]
+
(** Fun actions *)
type fun_action_content =
@@ -822,6 +826,7 @@ type qml_directive = [
| fun_action_directive
| simple_slicer_directive
| slicer_directive
+ | closure_instrumentation_directive
| thread_context_directive
| type_directive
View
99 libqmlcompil/qmlDirectives.ml
@@ -404,6 +404,10 @@ let ty directive exprs tys =
| `recval ->
Ty.id ()
+ (* === *)
+ (* closure_instrumentation *)
+ | `public_env -> Ty.id ()
+
(* utils *)
let create_lazy_record_arguments = function
@@ -415,3 +419,98 @@ let create_lazy_record_exprs record info =
match info with
| Some info -> [ record ; info ]
| None -> [ record ]
+
+module Format = Base.Format
+
+let to_string d =
+ match d with
+ | `deprecated -> "deprecated"
+ | `todo -> "todo"
+ | `at_init -> "at_init"
+ | `module_ -> "module"
+ | `module_field_lifting -> "module_field_lifting"
+ | `coerce -> "coerce"
+ | `nonexpansive -> "nonexpansive"
+ | `unsafe_cast -> "unsafe_cast"
+ | `opensums -> "opensums"
+ | `openrecord -> "openrecord"
+ | `assert_ -> "assert"
+ | `typeof -> "typeof"
+ | `atomic -> "atomic"
+ | `immovable -> "immovable"
+ | `thread_context -> "thread_context"
+ | `with_thread_context -> "with_thread_context"
+ | `js_ident -> "js_ident"
+ | `throw -> "throw"
+ | `catch -> "catch"
+ | `spawn -> "spawn"
+ | `wait -> "wait"
+ | `callcc -> "callcc"
+ | `restricted_bypass pass -> "restricted_bypass["^ pass ^ "]"
+ | `fail -> "fail"
+ | `create_lazy_record -> "create_lazy_record"
+ | `warncoerce -> "warncoerce"
+ | `apply_ty_arg _ -> "apply_ty_arg _"
+ | `abstract_ty_arg _ -> "abstract_ty_arg _"
+ | `closure_create _ -> "closure_create"
+ | `closure_apply -> "closure_apply"
+ | `closure_create_no_function _ -> "closure_create_no_function"
+ | `closure_define_function _ -> "closure_define_function"
+ | `ajax_publish b -> Printf.sprintf "ajax_publish(%s)" (match b with `sync -> "`sync" | `async -> "`async")
+ | `ajax_call b -> Printf.sprintf "ajax_call(%s)" (match b with `sync -> "`sync" | `async -> "`async")
+ | `comet_publish -> "comet_publish"
+ | `comet_call -> "comet_call"
+ | `insert_server_value i -> Printf.sprintf "insert_server_value(%s)" (Ident.to_string i)
+ | `doctype _ -> "doctype"
+ | `hybrid_value -> "hybrid_value"
+ | `backend_ident s -> Printf.sprintf "backend_ident[%s]" s
+ | `tracker _ -> "track"
+ | `expand _ -> "expand"
+ | `fun_action None -> "fun_action"
+ | `fun_action (Some Q.Client_id) -> "fun_action[Client_id]"
+ | `fun_action (Some Q.Deserialize) -> "fun_action[Deserialize]"
+ | `cps_stack_lambda _ -> "cps_stack_lambda"
+ | `cps_stack_apply _ -> "cps_stack_apply"
+ | `async -> "async"
+ | `sliced_expr -> "sliced_expr"
+ | `may_cps -> "may_cps"
+ | `stringifier -> "stringifier"
+ | `comparator -> "comparator"
+ | `serializer -> "serializer"
+ | `xmlizer -> "xmlizer"
+ | `llarray -> "llarray"
+ | `specialize variant -> Printf.sprintf "specialize%s" (match variant with `strict -> "_strict" | `polymorphic -> "")
+ | `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]]"
+ n
+ (Format.pp_list "@ " (fun f i -> Format.pp_print_string f (Ident.to_string i))) l
+ | `tagged_string (s, kind) ->
+ Printf.sprintf "tagged_string[%S, %s]" s
+ (match kind with
+ | Q.Rpc_use -> "rpc_use"
+ | Q.Rpc_def -> "rpc_def"
+ | Q.Type_def -> "type_def"
+ | Q.Type_use -> "type_use"
+ | Q.Client_closure_use -> "client_closure_use")
+ | `apply_cont -> "apply_cont"
+ | `recval -> "recval"
+ | `side_annotation a -> (
+ match a with
+ | `server -> "server"
+ | `client -> "client"
+ | `both -> "both"
+ | `prefer_server -> "prefer_server"
+ | `prefer_client -> "prefer_client"
+ | `prefer_both -> "prefer_both"
+ | `both_implem -> "both_implem"
+ )
+ | `visibility_annotation `private_ -> "server_private"
+ | `visibility_annotation (`public `sync) -> "publish"
+ | `visibility_annotation (`public `async) -> "publish_async"
+ | `visibility_annotation (`public `funaction) -> "publish_funaction"
+
+ | `public_env -> "public_env"
+
View
2 libqmlcompil/qmlDirectives.mli
@@ -70,3 +70,5 @@ val create_lazy_record_arguments :
val create_lazy_record_exprs :
QmlAst.expr -> QmlAst.expr option ->
QmlAst.expr list
+
+val to_string : directive -> string
View
94 libqmlcompil/qmlPrint.ml
@@ -84,100 +84,8 @@ let escaped_string s =
let s = String.escaped s in
String.replace s "{" "\\{"
-(*
- TODO: if possible (no problems of cyclic dependancies,
- put this function in qmlDirectives.ml,
- and remove the duplication of '@' as first char.
-*)
let directive (d:QmlAst.qml_directive) =
- match d with
- | `deprecated -> "@deprecated"
- | `todo -> "@todo"
- | `at_init -> "@at_init"
- | `module_ -> "@module"
- | `module_field_lifting -> "@module_field_lifting"
- | `coerce -> "@coerce"
- | `nonexpansive -> "@nonexpansive"
- | `unsafe_cast -> "@unsafe_cast"
- | `opensums -> "@opensums"
- | `openrecord -> "@openrecord"
- | `assert_ -> "@assert"
- | `typeof -> "@typeof"
- | `atomic -> "@atomic"
- | `immovable -> "@immovable"
- | `thread_context -> "@thread_context"
- | `with_thread_context -> "@with_thread_context"
- | `js_ident -> "@js_ident"
- | `throw -> "@throw"
- | `catch -> "@catch"
- | `spawn -> "@spawn"
- | `wait -> "@wait"
- | `callcc -> "@callcc"
- | `restricted_bypass pass -> "@restricted_bypass["^ pass ^ "]"
- | `fail -> "@fail"
- | `create_lazy_record -> "@create_lazy_record"
- | `warncoerce -> "@warncoerce"
- | `apply_ty_arg _ -> "@apply_ty_arg _"
- | `abstract_ty_arg _ -> "@abstract_ty_arg _"
- | `closure_create _ -> "@closure_create"
- | `closure_apply -> "@closure_apply"
- | `closure_create_no_function _ -> "@closure_create_no_function"
- | `closure_define_function _ -> "@closure_define_function"
- | `ajax_publish b -> Printf.sprintf "@ajax_publish(%s)" (match b with `sync -> "`sync" | `async -> "`async")
- | `ajax_call b -> Printf.sprintf "@ajax_call(%s)" (match b with `sync -> "`sync" | `async -> "`async")
- | `comet_publish -> "@comet_publish"
- | `comet_call -> "@comet_call"
- | `insert_server_value i -> Printf.sprintf "@insert_server_value(%s)" (Ident.to_string i)
- | `doctype _ -> "@doctype"
- | `hybrid_value -> "@hybrid_value"
- | `backend_ident s -> Printf.sprintf "@backend_ident[%s]" s
- | `tracker _ -> "@track"
- | `expand _ -> "@expand"
- | `fun_action None -> "@fun_action"
- | `fun_action (Some Q.Client_id) -> "@fun_action[Client_id]"
- | `fun_action (Some Q.Deserialize) -> "@fun_action[Deserialize]"
- | `cps_stack_lambda _ -> "@cps_stack_lambda"
- | `cps_stack_apply _ -> "@cps_stack_apply"
- | `async -> "@async"
- | `sliced_expr -> "@sliced_expr"
- | `may_cps -> "@may_cps"
- | `stringifier -> "@stringifier"
- | `comparator -> "@comparator"
- | `serializer -> "@serializer"
- | `xmlizer -> "@xmlizer"
- | `llarray -> "@llarray"
- | `specialize variant -> Printf.sprintf "@specialize%s" (match variant with `strict -> "_strict" | `polymorphic -> "")
- | `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]]"
- n
- (Format.pp_list "@ " (fun f i -> Format.pp_print_string f (Ident.to_string i))) l
- | `tagged_string (s, kind) ->
- Printf.sprintf "@tagged_string[%S, %s]" s
- (match kind with
- | Q.Rpc_use -> "rpc_use"
- | Q.Rpc_def -> "rpc_def"
- | Q.Type_def -> "type_def"
- | Q.Type_use -> "type_use"
- | Q.Client_closure_use -> "client_closure_use")
- | `apply_cont -> "@apply_cont"
- | `recval -> "@recval"
- | `side_annotation a -> (
- match a with
- | `server -> "@server"
- | `client -> "@client"
- | `both -> "@both"
- | `prefer_server -> "@prefer_server"
- | `prefer_client -> "@prefer_client"
- | `prefer_both -> "@prefer_both"
- | `both_implem -> "@both_implem"
- )
- | `visibility_annotation `private_ -> "@server_private"
- | `visibility_annotation (`public `sync) -> "@publish"
- | `visibility_annotation (`public `async) -> "@publish_async"
- | `visibility_annotation (`public `funaction) -> "@publish_funaction"
+ "@"^(QmlDirectives.to_string d)
(* ************************************************************************** *)
(** {b Descr}: Returns the string corresponding to a type definition
View
33 opa/s3Passes.ml
@@ -55,6 +55,25 @@ type env_OcamlCompilation = {
ocamlCompilation_returned_code : int ;
}
+(* when propagating to all environment is overkill
+ ensures that their is no package mismatch, and no mutability of extra env *)
+let pass_extra_output_env (default:'extra_env option) =
+ let r = ref None in
+ (fun () -> match !r with
+ | Some((pack,extra_env)) when ObjectFiles.get_current_package_name() = pack ->
+ extra_env
+ | _ -> match default with
+ | None -> failwith "pass_extra_output_env:not initalized"
+ | Some d -> d
+ ),
+ (fun (extra_env:'extra_env) ->
+ let cur_pack = ObjectFiles.get_current_package_name() in
+ match !r with
+ | Some((pack,_)) when cur_pack = pack && cur_pack<>"" -> (* something wrong here *)
+ failwith ("pass_extra_output_env:no mutability in <<"^pack^">>")
+ | _ -> r:= Some(cur_pack,extra_env)
+ )
+
(**********************************************************)
(* Private module : Provides some utils for make **********)
(* environnments ******************************************)
@@ -1074,13 +1093,19 @@ let pass_SimplifyMagic =
)
~invariant:(global_invariant ())
+let pass_InstrumentForClosureSerialization_instrumented,
+ pass_InstrumentForClosureSerialization_define_instrumented
+ = pass_extra_output_env (None:IdentSet.t option)
+
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 gamma, annotmap, code, instrumented =
+ Pass_InstrumentForClosureSerialization.process_code gamma annotmap code
+ in pass_InstrumentForClosureSerialization_define_instrumented instrumented;
let typerEnv = {typerEnv with QmlTypes.annotmap = annotmap; gamma} in
let env = {env with Passes.typerEnv = typerEnv; qmlAst = code} in
{e with PH.env = env}
@@ -1679,6 +1704,12 @@ let pass_JavascriptCompilation =
| Some id -> IdentSet.add id set
| None -> set
) IdentSet.empty (Opa_Roots.roots_for_s3 ~no_server:false) in
+ (* instrumented closure should not be cleaned *)
+ let client_roots = IdentSet.fold (fun id set ->
+ let id = QmlRenamingMap.new_from_original client_finalenv.P.newFinalCompile_renaming_client id in
+ IdentSet.add id set
+ ) (pass_InstrumentForClosureSerialization_instrumented()) client_roots
+ in
let typing = server_finalenv.P.newFinalCompile_qml_milkshake.QmlBlender.env in
let bsl_client = client_finalenv.P.newFinalCompile_bsl in
let server = server_finalenv.P.newFinalCompile_qml_milkshake in
View
2 opa/s3Warnings.ml
@@ -58,5 +58,7 @@ let warning_set =
!++ SurfaceAstStaticInclude.warning_set ;
+ !++ Pass_InstrumentForClosureSerialization.warning_set;
+
(* finally return the global warning_set *)
s
View
5 opalang/opaPrint.ml
@@ -152,11 +152,10 @@ struct
| None -> `no_sugar
end
-type userland_visibility_directive = QmlAst.userland_visibility_directive
type all_directives = SurfaceAst.all_directives
let userland_visibilities_to_whatever ds =
- (ds : userland_visibility_directive list :> [> all_directives] list)
+ (ds : QmlAst.userland_visibility_directive list :> [> all_directives] list)
class virtual ['ident] generic_printer =
object (self)
@@ -470,6 +469,8 @@ object (self)
| `specialize `strict -> Format.pp_print_string f "specialize_strict"
| `specialize `polymorphic -> Format.pp_print_string f "specialize"
| `recval -> Format.pp_print_string f "recval"
+ (* TODO add more qml directive type here instead of duplicating with QmlDirectives.to_string above *)
+ | #QmlAst.closure_instrumentation_directive as d -> Format.pp_print_string f (QmlDirectives.to_string d)
method string_elmt : 'dir. ('ident,[< all_directives ] as 'dir) expr pprinter = fun f (e,_) ->
match e with
View
1 opalang/opaToQml.ml
@@ -550,6 +550,7 @@ struct
| #SA.opavalue_directive
| #SA.distribution_directive
| `llarray
+ | #QA.closure_instrumentation_directive
) as variant, el, tl ->
let el = List.map expr el in
let tl = List.map ty tl in
View
3 opalang/surfaceAst.ml
@@ -388,6 +388,8 @@ type opavalue_directive = [
| `xmlizer
]
+type closure_instrumentation_directive = QmlAst.closure_instrumentation_directive
+
type basic_directive =
[ magic_directive
| string_directive
@@ -404,6 +406,7 @@ type basic_directive =
| opavalue_directive
| `create_lazy_record
| distribution_directive
+ | closure_instrumentation_directive
]
(** these directives are the ones that are not taken care of in the surfaceAst
they go straight to qml (or fail at the conversion when not implemented)
View
19 opalang/syntax/opa_parser.trx
@@ -569,9 +569,12 @@ declaration_directive0 <-
/ "async" {{ `async }}
/ "opacapi" {{ `opacapi }}
/ "package" {{ `package }}
+ / "public_env" {{ `public_env }}
/ "private" {{ `private_ }}
/ "public" {{ `public }}
/ "expand" {{ `expand None }} (* not allowing anymore to give an integer to expand, could be put back *)
+ / slicing_directive0
+
declaration_directive1_typ <-
/ "stringifier" {{ `stringifier }}
/ "comparator" {{ `comparator }}
@@ -581,7 +584,6 @@ declaration_directive1_typ <-
/** toplevel directive **/
declaration_directives <- (=deco(declaration_directive))*
declaration_directive <-
- / slicing_directive
/ "@" (=exact_ident(declaration_directive1)):v Opa_lexer.lpar_nosp expr:e rpar
{{ (v, [e], []) }}
/ "@" (=exact_ident(declaration_directive0)):v !"("
@@ -603,11 +605,13 @@ slicing_directive0 <-
/ "server_private" {{ `visibility_annotation `private_ }}
/ "server" {{ `side_annotation `server }}
/ "no_client_calls" {{ `no_client_calls }}
-slicing_directives <- (=deco(slicing_directive))*
-slicing_directive <-
- / "@" (=exact_ident(slicing_directive0)):v !"("
- {{ (v, [], []) }}
+closure_instrumentation_directive <- "public_env" {{ `public_env }}
+
+local_binding_directive <- "@" (=exact_ident(slicing_directive0
+ /closure_instrumentation_directive)):v !"("
+ {{ (v, [], []) }}
+local_binding_directives <- (=deco(local_binding_directive:v))*
(**
{7 Directives}
@@ -621,6 +625,7 @@ directive0 <-
/ "toplevel" {{ `toplevel }}
directive1 <-
+ / closure_instrumentation_directive
/ "assert" {{ `assert_ }}
/ "atomic" {{ `atomic }}
/ "callcc" {{ `callcc }}
@@ -861,14 +866,14 @@ lambda <-
Only identifiers on the left hand side of recursive values
*)
/** local binding **/
-letin <- pos:pos1 slicing_directives:dirs Opa_lexer.REC (=list1pos(rec_binding_pat, and)):l separator pos:pos_f expr:e
+letin <- pos:pos1 local_binding_directives:dirs Opa_lexer.REC (=list1pos(rec_binding_pat, and)):l separator pos:pos_f expr:e
{{ let l,posl = l in
push_hint (`same_indents ((pos1::posl) @ [pos_f]));
let l = List.concat_map pat_in_to_simple_bindings l in
let l = declaration_directive dirs l in
LetIn (true, l, e)
}}
- / pos:pos1 slicing_directives:dirs (binding_pat / do_block):b separator:pos2 expr:e
+ / pos:pos1 local_binding_directives:dirs (binding_pat / do_block):b separator:pos2 expr:e
{{ push_hint (`same_indent (pos1,pos2));
bind_in_to_expr_in dirs b e
}}
View
231 qmlpasses/pass_InstrumentForClosureSerialization.ml
@@ -16,14 +16,153 @@
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
+(* @author Valentin Gatien-Baron
+ @author Rudy Sicard *)
+
+(* road map:
+ add instrumented function as root on client
+ add support of @public_env on function definition (see detect_candidate_def)
+ fix TODO in detect_candidate_call
+ add static dependencies analysis to detect env that contains informations linked to a server_private
+ add option to force having @public_env on all functions *)
+
module Q = QmlAst
module Cons = QmlAstCons.TypedExpr
module List = BaseList
+let public_env_warn =
+ WarningClass.create
+ ~public:true
+ ~name:"public_env"
+ ~doc:"All public_env directive related warnings"
+ ~err:false
+ ~enable:true
+ ()
+
+let badarg_warn =
+ WarningClass.create
+ ~parent:public_env_warn
+ ~public:true
+ ~name:"badarg"
+ ~doc:"Warn if the argument of public_env is suspicious or incorrect"
+ ~err:false
+ ~enable:true
+ ()
+
+let badarg_unknownenv =
+ WarningClass.create
+ ~parent:badarg_warn
+ ~public:true
+ ~name:"unknownenv"
+ ~doc:"Warn if the argument of public_env is not a local definition or not a partial application or not a local function name"
+ ~err:true
+ ~enable:true
+ ()
+
+let badarg_emptyenv =
+ WarningClass.create
+ ~parent:badarg_warn
+ ~public:true
+ ~name:"emptyenv"
+ ~doc:"Warn if the argument of public_env is empty"
+ ~err:false
+ ~enable:true
+ ()
+
+let warning_set = WarningClass.Set.create_from_list [
+ public_env_warn;
+ badarg_warn;
+ badarg_unknownenv;
+ badarg_emptyenv
+]
+
+let warn_unknown annot =
+ QmlError.warning ~wclass:badarg_unknownenv (QmlError.Context.pos (Annot.pos annot))
+ "The argument of @@public_env is not a local function definition or not a partial application or not a local function name"
+
+let warn_empty annot =
+ QmlError.warning ~wclass:badarg_emptyenv (QmlError.Context.pos (Annot.pos annot))
+ "The argument of @@public_env has no real environment (toplevel or equivalent)"
+
type env = Ident.t * (Q.ty,unit) QmlGenericScheme.tsc option IdentMap.t
let empty = IdentMap.empty
+(* detect function declaration tagged with @public_env *)
+let rec is_public_env e = match e with
+ | Q.Directive (_, `public_env, _, _) -> true
+ | Q.Directive (_,_,[e],_) -> is_public_env e
+ | _ -> false
+
+let rec rm_top_public_env e =
+ match e with
+ | Q.Directive (_, `public_env, [e], _) -> e
+ | Q.Directive (a,b,[e],c) -> Q.Directive (a,b,[rm_top_public_env e],c)
+ | e -> e
+
+let detect_candidate_def1 set def = match def with
+ | (Q.NewVal (label,iel) | Q.NewValRec (label,iel)) when List.exists (fun (_,e) -> is_public_env e) iel ->
+ let set = List.fold_left (fun set (i,e) -> if is_public_env e then IdentSet.add i set else set) set iel in
+ set, Q.NewValRec (label,List.map (fun (i,e) -> i,rm_top_public_env e) iel)
+ | _ -> set, def
+
+let detect_candidate_def code = List.fold_left_map detect_candidate_def1 IdentSet.empty code
+
+(* detect elligible call site, i.e. tagged with @publish_env or calling @publish_env function (see above)
+ also warn for bad use of the directive => not a partial call
+
+ to simplify the usability of the directive, ident on explicit and implicit toplevel construction are considered as partial call (but with a warning class):
+ first, some explicit partial application like f(1,_) are translated to toplevel functions because their environement is static (=> no env in the closure)
+ second, environement of toplevel construct is empty so the directive would have no effect anyway
+*)
+let detect_candidate_call always_serialize code =
+ let force_rewrite = ref false in
+ let _, set = QmlAstWalk.CodeExpr.fold
+ (QmlAstWalk.Expr.fold
+ (fun (local,need_instrumentation) e ->
+ match e with
+ (* partial apply cases *)
+ | Q.Directive (_, `partial_apply (_,false),
+ [Q.Apply (_, Q.Ident (_, i), _args)]
+ , _)
+ when IdentSet.mem i always_serialize
+ -> local,IdentSet.add i need_instrumentation
+
+ | Q.Directive (_, `public_env ,[
+ Q.Directive (_, `partial_apply (_,false), [Q.Apply (_, Q.Ident (_, i), _args)], _)]
+ , _)
+ -> local,IdentSet.add i need_instrumentation
+
+
+ (* ident cases *)
+ | Q.Directive (a, `public_env , [Q.Ident(_, i)], _) ->
+ (if IdentSet.mem i local then warn_unknown else warn_empty) a;
+ force_rewrite:=true;
+ local,IdentSet.add i need_instrumentation
+
+ (* TODO bind in pattern are missing => bad warning class for some idents *)
+ | Q.LetIn(_, decl, _)
+ | Q.LetRecIn(_, decl, _) ->
+ let add local (id,_) = IdentSet.add id local in
+ (List.fold_left add local decl),need_instrumentation
+ | Q.Lambda(_ ,param, _ ) ->
+ let add local id = IdentSet.add id local in
+ (List.fold_left add local param),need_instrumentation
+
+ (* bad cases *)
+ | Q.Directive (a, `public_env , [_] , _) ->
+ warn_unknown a;
+ force_rewrite:=true;
+ local,need_instrumentation
+
+ | Q.Directive (a, `public_env , _ , _) -> (* should not parse *)
+ QmlError.error (QmlError.Context.pos (Annot.pos a)) "@publish_env with more than one parameter"
+
+ | _ -> local,need_instrumentation
+ )
+ ) (IdentSet.empty,IdentSet.empty) code
+ in set, !force_rewrite || not(IdentSet.is_empty set)
+
let extract_env_type env_size gamma ty =
match QmlTypesUtils.Inspect.get_arrow_through_alias_and_private gamma ty with
| Some (l1,ret) ->
@@ -32,9 +171,14 @@ let extract_env_type env_size gamma ty =
l1, Q.TypeArrow (l2, ret), l2, ret
| None -> assert false
-let generate_typeofer gamma annotmap env (i,e) =
+(* generate instrumented version of the function
+ a(env,p1,p2) = expr
+ =>
+ a'(env) = `partial_call(a(env)) with extra ei annotation
+*)
+let generate_typeofer need_instrumentation gamma annotmap env (i,e) =
match e with
- | Q.Directive (_, `lifted_lambda (env_size, function_of_origin), [_], _) ->
+ | Q.Directive (_, `lifted_lambda (env_size, function_of_origin), [_], _) when IdentSet.mem i need_instrumentation ->
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
@@ -84,53 +228,68 @@ let generate_typeofer gamma annotmap env (i,e) =
| _ ->
None
-let generate_new_binding (gamma, annotmap, env) iel =
+(* generate instrumented version of all declarations *)
+let generate_new_binding need_instrumentation (gamma, annotmap, env) iel =
List.fold_left_filter_map
(fun (gamma, annotmap, env) (i,e) ->
- match generate_typeofer gamma annotmap env (i,e) with
+ match generate_typeofer need_instrumentation 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 =
+let generate_instrumented_functions need_instrumentation gamma annotmap code =
+ List.fold_left_collect
+ (fun acc code_elt ->
+ match code_elt with
+ | Q.NewVal (label,iel) ->
+ let acc, new_iel = generate_new_binding need_instrumentation 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 need_instrumentation acc iel in
+ let code = [Q.NewValRec (label,iel @ new_iel)] in
+ acc, code
+ | _ ->
+ assert false
+ ) (gamma, annotmap, empty) code
+
+(* update call elligible site *)
+let rewrite_identifiers always_serialize env annotmap code =
+ let new_call_site annotmap labelapply i labeli args =
+ let new_ident, tsc_opt = IdentMap.find i env in
+ let e = Q.Apply (labelapply, Q.Ident (labeli, new_ident), args) in
+ let annotmap = QmlAnnotMap.remove_tsc_inst_label labeli annotmap in
+ let annotmap = QmlAnnotMap.add_tsc_inst_opt_label labeli tsc_opt annotmap in
+ annotmap, e
+ in
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
+ | Q.Directive (_, `public_env ,[Q.Directive (_, `partial_apply (_,false), [Q.Apply (labela, Q.Ident (labeli, i), args)], _)],_) ->
+ new_call_site annotmap labela i labeli args
+
+ | Q.Directive (_, `partial_apply (_,false), [Q.Apply (labela, Q.Ident (labeli, i), args)], _) when IdentSet.mem i always_serialize ->
+ new_call_site annotmap labela i labeli args
+
+ | Q.Directive (_, `public_env,[e], _ ) -> annotmap, e
+ | Q.Directive (_, `public_env, _ , _ ) -> assert false (* see detect_candidate_call *)
| _ ->
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
+ let always_serialize, code = detect_candidate_def code in
+ let need_instrumentation, need_rewrite = detect_candidate_call always_serialize code in
+ if not(need_rewrite) then (*return*) gamma, annotmap, code, IdentSet.empty else
+ let (gamma, annotmap, env), code = if not(IdentSet.is_empty need_instrumentation)
+ then generate_instrumented_functions need_instrumentation gamma annotmap code
+ else (gamma, annotmap, empty), code in
+ let annotmap, code = rewrite_identifiers always_serialize env annotmap code in
+ gamma, annotmap, code, need_instrumentation
View
4 qmlpasses/pass_InstrumentForClosureSerialization.mli
@@ -16,7 +16,9 @@
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
+val warning_set : WarningClass.Set.t
+
+val process_code : QmlTypes.gamma -> QmlAst.annotmap -> QmlAst.code -> QmlTypes.gamma * QmlAst.annotmap * QmlAst.code * IdentSet.t
(*
The transformation related to closure serialization is as follows:

0 comments on commit 2536662

Please sign in to comment.
Something went wrong with that request. Please try again.