Skip to content
This repository
Newer
Older
100644 327 lines (287 sloc) 13.14 kb
936d60af »
2011-06-23 [feature] closure serialisation: adding closure instrumentation (comp…
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18
2536662d »
2011-09-23 [feature] closure serialisation: restrict to new @public_env directive
19 (* @author Valentin Gatien-Baron
20 @author Rudy Sicard *)
21
22 (* road map:
23 add instrumented function as root on client
24 add support of @public_env on function definition (see detect_candidate_def)
25 fix TODO in detect_candidate_call
26 add static dependencies analysis to detect env that contains informations linked to a server_private
27 add option to force having @public_env on all functions *)
28
936d60af »
2011-06-23 [feature] closure serialisation: adding closure instrumentation (comp…
29 module Q = QmlAst
30 module Cons = QmlAstCons.TypedExpr
31 module List = BaseList
32
2536662d »
2011-09-23 [feature] closure serialisation: restrict to new @public_env directive
33 let public_env_warn =
34 WarningClass.create
35 ~public:true
36 ~name:"public_env"
37 ~doc:"All public_env directive related warnings"
38 ~err:false
39 ~enable:true
40 ()
41
42 let badarg_warn =
43 WarningClass.create
44 ~parent:public_env_warn
45 ~public:true
46 ~name:"badarg"
47 ~doc:"Warn if the argument of public_env is suspicious or incorrect"
48 ~err:false
49 ~enable:true
50 ()
51
52 let badarg_unknownenv =
53 WarningClass.create
54 ~parent:badarg_warn
55 ~public:true
56 ~name:"unknownenv"
57 ~doc:"Warn if the argument of public_env is not a local definition or not a partial application or not a local function name"
58 ~err:true
59 ~enable:true
60 ()
61
62 let badarg_emptyenv =
63 WarningClass.create
64 ~parent:badarg_warn
65 ~public:true
66 ~name:"emptyenv"
67 ~doc:"Warn if the argument of public_env is empty"
68 ~err:false
69 ~enable:true
70 ()
71
72 let warning_set = WarningClass.Set.create_from_list [
73 public_env_warn;
74 badarg_warn;
75 badarg_unknownenv;
76 badarg_emptyenv
77 ]
78
79 let warn_unknown annot =
80 QmlError.warning ~wclass:badarg_unknownenv (QmlError.Context.pos (Annot.pos annot))
81 "The argument of @@public_env is not a local function definition or not a partial application or not a local function name"
82
83 let warn_empty annot =
84 QmlError.warning ~wclass:badarg_emptyenv (QmlError.Context.pos (Annot.pos annot))
85 "The argument of @@public_env has no real environment (toplevel or equivalent)"
86
936d60af »
2011-06-23 [feature] closure serialisation: adding closure instrumentation (comp…
87 type env = Ident.t * (Q.ty,unit) QmlGenericScheme.tsc option IdentMap.t
88
89 let empty = IdentMap.empty
90
62b1c37e »
2011-11-22 [fix] closure serialisation: make it more robust in presence of other…
91 type ignored_directive = [
92 | Q.type_directive
93 | Q.slicer_directive
94 ]
95
2536662d »
2011-09-23 [feature] closure serialisation: restrict to new @public_env directive
96 (* detect function declaration tagged with @public_env *)
97 let rec is_public_env e = match e with
98 | Q.Directive (_, `public_env, _, _) -> true
62b1c37e »
2011-11-22 [fix] closure serialisation: make it more robust in presence of other…
99 | Q.Directive (_, #ignored_directive,[e],_) -> is_public_env e
2536662d »
2011-09-23 [feature] closure serialisation: restrict to new @public_env directive
100 | _ -> false
101
102 let rec rm_top_public_env e =
103 match e with
104 | Q.Directive (_, `public_env, [e], _) -> e
62b1c37e »
2011-11-22 [fix] closure serialisation: make it more robust in presence of other…
105 | Q.Directive (a,(#ignored_directive as b),[e],c) -> Q.Directive (a,b,[rm_top_public_env e],c)
2536662d »
2011-09-23 [feature] closure serialisation: restrict to new @public_env directive
106 | e -> e
107
108 let detect_candidate_def1 set def = match def with
109 | (Q.NewVal (label,iel) | Q.NewValRec (label,iel)) when List.exists (fun (_,e) -> is_public_env e) iel ->
110 let set = List.fold_left (fun set (i,e) -> if is_public_env e then IdentSet.add i set else set) set iel in
111 set, Q.NewValRec (label,List.map (fun (i,e) -> i,rm_top_public_env e) iel)
112 | _ -> set, def
113
114 let detect_candidate_def code = List.fold_left_map detect_candidate_def1 IdentSet.empty code
115
116 (* detect elligible call site, i.e. tagged with @publish_env or calling @publish_env function (see above)
117 also warn for bad use of the directive => not a partial call
118
119 to simplify the usability of the directive, ident on explicit and implicit toplevel construction are considered as partial call (but with a warning class):
120 first, some explicit partial application like f(1,_) are translated to toplevel functions because their environement is static (=> no env in the closure)
121 second, environement of toplevel construct is empty so the directive would have no effect anyway
122 *)
123 let detect_candidate_call always_serialize code =
124 let force_rewrite = ref false in
62b1c37e »
2011-11-22 [fix] closure serialisation: make it more robust in presence of other…
125 let rec public_env a local need_instrumentation e = match e with
126 (* partial apply cases *)
127 | Q.Directive (_, `partial_apply (_,false), [Q.Apply (_, Q.Ident (_, i), _args)], _) ->
128 local,IdentSet.add i need_instrumentation
129
130 (* ident cases *)
131 | Q.Ident(_, i) ->
132 (if IdentSet.mem i local then warn_unknown else warn_empty) a;
133 force_rewrite:=true;
134 local,IdentSet.add i need_instrumentation
135
136 (* traverse directives *)
137 | Q.Directive (_, #ignored_directive , [e], _) -> public_env a local need_instrumentation e
138
139 (* bad cases *)
140 | _ ->
141 warn_unknown a;
142 force_rewrite:=true;
143 local,need_instrumentation
144
145 in
2536662d »
2011-09-23 [feature] closure serialisation: restrict to new @public_env directive
146 let _, set = QmlAstWalk.CodeExpr.fold
147 (QmlAstWalk.Expr.fold
148 (fun (local,need_instrumentation) e ->
149 match e with
62b1c37e »
2011-11-22 [fix] closure serialisation: make it more robust in presence of other…
150 | Q.Directive (a, `public_env ,[e], _ ) -> public_env a local need_instrumentation e
151 | Q.Directive (a, `public_env , _ , _) -> (* should not parse *)
152 QmlError.error (QmlError.Context.pos (Annot.pos a)) "@publish_env with more than one parameter"
153
2536662d »
2011-09-23 [feature] closure serialisation: restrict to new @public_env directive
154 (* partial apply cases *)
155 | Q.Directive (_, `partial_apply (_,false),
156 [Q.Apply (_, Q.Ident (_, i), _args)]
157 , _)
158 when IdentSet.mem i always_serialize
159 -> local,IdentSet.add i need_instrumentation
160
161 (* TODO bind in pattern are missing => bad warning class for some idents *)
162 | Q.LetIn(_, decl, _)
163 | Q.LetRecIn(_, decl, _) ->
164 let add local (id,_) = IdentSet.add id local in
165 (List.fold_left add local decl),need_instrumentation
166 | Q.Lambda(_ ,param, _ ) ->
167 let add local id = IdentSet.add id local in
168 (List.fold_left add local param),need_instrumentation
169
170 | _ -> local,need_instrumentation
171 )
172 ) (IdentSet.empty,IdentSet.empty) code
173 in set, !force_rewrite || not(IdentSet.is_empty set)
174
936d60af »
2011-06-23 [feature] closure serialisation: adding closure instrumentation (comp…
175 let extract_env_type env_size gamma ty =
176 match QmlTypesUtils.Inspect.get_arrow_through_alias_and_private gamma ty with
177 | Some (l1,ret) ->
178 assert (List.length l1 >= env_size);
179 let l1, l2 = List.split_at env_size l1 in
180 l1, Q.TypeArrow (l2, ret), l2, ret
181 | None -> assert false
182
2536662d »
2011-09-23 [feature] closure serialisation: restrict to new @public_env directive
183 (* generate instrumented version of the function
184 a(env,p1,p2) = expr
185 =>
186 a'(env) = `partial_call(a(env)) with extra ei annotation
187 *)
188 let generate_typeofer need_instrumentation gamma annotmap env (i,e) =
936d60af »
2011-06-23 [feature] closure serialisation: adding closure instrumentation (comp…
189 match e with
2536662d »
2011-09-23 [feature] closure serialisation: restrict to new @public_env directive
190 | Q.Directive (_, `lifted_lambda (env_size, function_of_origin), [_], _) when IdentSet.mem i need_instrumentation ->
936d60af »
2011-06-23 [feature] closure serialisation: adding closure instrumentation (comp…
191 let new_i = Ident.refreshf ~map:"%s_ser" i in
192 let tsc_gen_opt = QmlAnnotMap.find_tsc_opt (Q.QAnnot.expr e) annotmap in
193 let ty_i = QmlAnnotMap.find_ty (Q.QAnnot.expr e) annotmap in
194 let ty_i =
195 (* refreshing or else ei will stupidly propagate type vars to the original def *)
196 let tsc = QmlTypes.Scheme.quantify ty_i in
197 let tsc = QmlTypes.Scheme.refresh tsc in
198 let _quant, ty_i, () = QmlGenericScheme.export_unsafe tsc in
199 ty_i in
200 let ty_env, ty_remaining, ty_args, _ty_ret = extract_env_type env_size gamma ty_i in
201 let annotmap, g = Cons.ident annotmap i (*ty_i*) (Q.TypeArrow (ty_env, ty_remaining)) in
202 let annotmap = QmlAnnotMap.add_tsc_inst_opt (Q.QAnnot.expr g) tsc_gen_opt annotmap in
203 let new_tsc_gen_opt, gamma =
204 let ty = Q.TypeArrow (ty_env,ty_remaining) in
205 let tsc = QmlTypes.Scheme.quantify ty in
206 let gamma = QmlTypes.Env.Ident.add i tsc gamma in
207 let tsc_opt =
208 if QmlGenericScheme.is_empty tsc then
209 None
210 else
211 Some tsc in
212 tsc_opt, gamma in
213 let params = List.init env_size (fun i -> Ident.next ("eta_" ^ string_of_int i)) in
214 let annotmap, args = List.fold_left_map2 (fun annotmap i ty -> Cons.ident annotmap i ty) annotmap params ty_env in
215 let annotmap, apply_g = Cons.apply_partial gamma annotmap g args in
216 let partial_apply = `partial_apply (Some (List.length ty_args), true) in
217 let annotmap, typeofs =
218 List.fold_left_map2
219 (fun annotmap i ty ->
220 let annotmap, i = Cons.ident annotmap i ty in
221 Cons.directive annotmap `typeof [i] []
222 ) annotmap params ty_env in
223 let annotmap, body =
224 let label = Annot.refresh (Q.Label.expr e) in
225 let annotmap = QmlAnnotMap.add_ty_label label ty_remaining annotmap in
226 annotmap, Q.Directive (label,partial_apply,apply_g::typeofs,[]) in
227 let annotmap, fun_ = Cons.lambda annotmap (List.combine params ty_env) body in
228 (* the @lifted_lambda is for the slicer, so that it puts the function on the right side
229 * (which is the side of function_of_origin)
230 * this probably won't work when we have local annotation, because this function should
231 * be on the side of the lambda it is created from instead *)
232 let annotmap, fun_ = Cons.directive_id annotmap (`lifted_lambda (0, function_of_origin)) fun_ in
233 let annotmap =
234 QmlAnnotMap.add_tsc_opt (Q.QAnnot.expr fun_) new_tsc_gen_opt annotmap in
235 let env = IdentMap.add i (new_i, new_tsc_gen_opt) env in
236 Some (gamma, annotmap, env, new_i, fun_)
237 | _ ->
238 None
239
2536662d »
2011-09-23 [feature] closure serialisation: restrict to new @public_env directive
240 (* generate instrumented version of all declarations *)
241 let generate_new_binding need_instrumentation (gamma, annotmap, env) iel =
936d60af »
2011-06-23 [feature] closure serialisation: adding closure instrumentation (comp…
242 List.fold_left_filter_map
243 (fun (gamma, annotmap, env) (i,e) ->
2536662d »
2011-09-23 [feature] closure serialisation: restrict to new @public_env directive
244 match generate_typeofer need_instrumentation gamma annotmap env (i,e) with
936d60af »
2011-06-23 [feature] closure serialisation: adding closure instrumentation (comp…
245 | None -> (gamma, annotmap, env), None
246 | Some (gamma, annotmap, env, i, e) -> (gamma, annotmap, env), Some (i,e)
247 ) (gamma, annotmap, env) iel
248
2536662d »
2011-09-23 [feature] closure serialisation: restrict to new @public_env directive
249 let generate_instrumented_functions need_instrumentation gamma annotmap code =
250 List.fold_left_collect
251 (fun acc code_elt ->
252 match code_elt with
253 | Q.NewVal (label,iel) ->
254 let acc, new_iel = generate_new_binding need_instrumentation acc iel in
255 let code =
256 if new_iel = [] then
257 [code_elt]
258 else
259 [code_elt; Q.NewVal (Annot.refresh label,new_iel)] in
260 acc, code
261 | Q.NewValRec (label,iel) ->
262 let acc, new_iel = generate_new_binding need_instrumentation acc iel in
263 let code = [Q.NewValRec (label,iel @ new_iel)] in
264 acc, code
265 | _ ->
266 assert false
267 ) (gamma, annotmap, empty) code
268
269 (* update call elligible site *)
270 let rewrite_identifiers always_serialize env annotmap code =
1eff341b »
2011-11-22 [fix] closure serialisation: fix a bug introduced in 62b1c37
271 let new_call_site labeli i =
2536662d »
2011-09-23 [feature] closure serialisation: restrict to new @public_env directive
272 let new_ident, tsc_opt = IdentMap.find i env in
62b1c37e »
2011-11-22 [fix] closure serialisation: make it more robust in presence of other…
273 let rw_ident e = match e with | Q.Ident (label, _) when label=labeli -> Q.Ident (labeli, new_ident)
274 | _-> e in
1eff341b »
2011-11-22 [fix] closure serialisation: fix a bug introduced in 62b1c37
275 fun annotmap e ->
276 let e = QmlAstWalk.Expr.map rw_ident e in
2536662d »
2011-09-23 [feature] closure serialisation: restrict to new @public_env directive
277 let annotmap = QmlAnnotMap.remove_tsc_inst_label labeli annotmap in
278 let annotmap = QmlAnnotMap.add_tsc_inst_opt_label labeli tsc_opt annotmap in
1eff341b »
2011-11-22 [fix] closure serialisation: fix a bug introduced in 62b1c37
279 annotmap, e
62b1c37e »
2011-11-22 [fix] closure serialisation: make it more robust in presence of other…
280 in
281 let rec get_ident e = match e with
282 | Q.Ident (labeli, i) -> Some((labeli,i))
283 | Q.Directive (_,#ignored_directive,[e],_) -> get_ident e
284 | _ -> None
285 in
592098e9 »
2011-11-22 [fix] closure serialisation: fix a bug introduced in 62b1c37
286 let rm_public_env e = match e with
62b1c37e »
2011-11-22 [fix] closure serialisation: make it more robust in presence of other…
287 | Q.Directive (_, `public_env, ([]|_::_::_) , _ ) -> assert false (* see detect_candidate_call *)
592098e9 »
2011-11-22 [fix] closure serialisation: fix a bug introduced in 62b1c37
288 | Q.Directive (_, `public_env, [e], _ ) -> true,e
289 | _ -> false,e
290 in
fd162ba7 »
2011-12-15 [fix] closure serialisation: fix a bug introduced in 62b1c37
291 let rec rw_call_site ~has_public_env annotmap e =
292 let no_changes = e in
293 match e with
294 | (Q.Ident _ as id) as e
295 | Q.Directive (_, `partial_apply (_,false), [Q.Apply (_, id , _ ) as e], _)
62b1c37e »
2011-11-22 [fix] closure serialisation: make it more robust in presence of other…
296 -> begin match get_ident id with
297 | Some((labeli,id)) when has_public_env || IdentSet.mem id always_serialize ->
fd162ba7 »
2011-12-15 [fix] closure serialisation: fix a bug introduced in 62b1c37
298 new_call_site labeli id annotmap e
299 | _ -> (annotmap,no_changes)
62b1c37e »
2011-11-22 [fix] closure serialisation: make it more robust in presence of other…
300 end
1eff341b »
2011-11-22 [fix] closure serialisation: fix a bug introduced in 62b1c37
301
fd162ba7 »
2011-12-15 [fix] closure serialisation: fix a bug introduced in 62b1c37
302 | Q.Directive (a,(#ignored_directive as b),[e],c) ->
303 let annotmap,e = rw_call_site ~has_public_env annotmap e in
304 annotmap, Q.Directive (a,b,[e],c)
1eff341b »
2011-11-22 [fix] closure serialisation: fix a bug introduced in 62b1c37
305
fd162ba7 »
2011-12-15 [fix] closure serialisation: fix a bug introduced in 62b1c37
306 | _ -> (annotmap,no_changes)
2536662d »
2011-09-23 [feature] closure serialisation: restrict to new @public_env directive
307 in
592098e9 »
2011-11-22 [fix] closure serialisation: fix a bug introduced in 62b1c37
308 let rw annotmap e =
309 let has_public_env, e = rm_public_env e in
fd162ba7 »
2011-12-15 [fix] closure serialisation: fix a bug introduced in 62b1c37
310 rw_call_site ~has_public_env annotmap e
592098e9 »
2011-11-22 [fix] closure serialisation: fix a bug introduced in 62b1c37
311 in
936d60af »
2011-06-23 [feature] closure serialisation: adding closure instrumentation (comp…
312 QmlAstWalk.CodeExpr.fold_map
313 (QmlAstWalk.Expr.foldmap
1eff341b »
2011-11-22 [fix] closure serialisation: fix a bug introduced in 62b1c37
314 rw
936d60af »
2011-06-23 [feature] closure serialisation: adding closure instrumentation (comp…
315 ) annotmap code
316
2536662d »
2011-09-23 [feature] closure serialisation: restrict to new @public_env directive
317
936d60af »
2011-06-23 [feature] closure serialisation: adding closure instrumentation (comp…
318 let process_code gamma annotmap code =
2536662d »
2011-09-23 [feature] closure serialisation: restrict to new @public_env directive
319 let always_serialize, code = detect_candidate_def code in
320 let need_instrumentation, need_rewrite = detect_candidate_call always_serialize code in
321 if not(need_rewrite) then (*return*) gamma, annotmap, code, IdentSet.empty else
322 let (gamma, annotmap, env), code = if not(IdentSet.is_empty need_instrumentation)
323 then generate_instrumented_functions need_instrumentation gamma annotmap code
324 else (gamma, annotmap, empty), code in
325 let annotmap, code = rewrite_identifiers always_serialize env annotmap code in
326 gamma, annotmap, code, need_instrumentation
Something went wrong with that request. Please try again.