Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 421 lines (378 sloc) 16.113 kB
fccc685 Initial open-source release
MLstate authored
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 module Q = QmlAst
19 module List = Base.List
20
21 type ignored_directive = [ Q.type_directive | `expanded_bypass ]
22
23 (* for each top level function, we record
24 1-its defining identifier,
25 2-the name of its closure
26 3-its arity
27 4-its typescheme (as found in \Gamma)
28 *)
29 type func_info = {
30 arity: int;
31 code : Ident.t; (* name of the function *)
32 closure : Ident.t; (* name of the closure *)
33 used : bool ref; (* shared between a real function and its aliases,
34 * which would not be possible if the field was mutable *)
35 tsc : QmlTypes.typescheme option; (* None everywhere in untyped mode
36 * Some everywhere in typed mode *)
37 from_current_package : bool; (* true if the closure is defined in the current package *)
38 }
39
40 let _count_closures = ref 0
41 let _count_rec_closures = ref 0
42 let _count_cleaned = ref 0
43 let _count_rec_cleaned = ref 0
44
45 (* the global knowledge *)
46 type env = { funcs: func_info IdentMap.t }
47
48 module S =
49 struct
50 type t = env
51 let pass = "qmlUncurry"
52 let pp f _ = Format.pp_print_string f "<dummy>"
53 end
54
55 module R =
56 struct
57 include ObjectFiles.MakeClientServer(S)
58 let load ~side env =
59 let funcs =
60 fold_with_name ~side
61 (fun package acc env ->
62 let refreshed_env =
63 IdentMap.map
64 (fun r ->
65 assert r.from_current_package;
66 {r with
67 from_current_package = false;
68 tsc = Option.map (QmlRefresh.refresh_typevars_from_tsc package) r.tsc
69 })
70 env.funcs in
71 IdentMap.safe_merge acc refreshed_env
72 ) env.funcs in
73 {funcs = funcs}
74 end
75
76 (* utility function *)
77 let get_ty annotmap ann =
78 QmlAnnotMap.find_ty ann annotmap
79
80 (* classify between the three kind of objects that we deal with
81 * - functions
82 * - aliases on function identifier (as an optimization)
83 * - everything else (we don't care about it)
84 *)
85 let classify e =
86 let o =
87 QmlAstWalk.Expr.traverse_findmap
88 (fun tra e ->
89 match e with
90 | Q.Lambda _ -> Some `lambda
91 | Q.Ident (_, i) -> Some (`alias i)
92 | Q.Coerce _
93 | Q.Directive(_, #ignored_directive, _, _) -> tra e
94 | _ -> None) e in
95 Option.default `nothing o
96
97 (* a special of the previous function: returns whether e is a function or not *)
98 let is_lambda e =
99 QmlAstWalk.Expr.traverse_exists
100 (fun tra e ->
101 match e with
102 | Q.Lambda _ -> true
103 | Q.Coerce _
104 | Q.Directive (_, #ignored_directive, _, _) -> tra e
105 | _ -> false) e
106
107 (* returns the arity of a function *)
108 let get_arity e =
109 let o =
110 QmlAstWalk.Expr.traverse_findmap
111 (fun tra e ->
112 match e with
113 | Q.Lambda (_, l, _) -> Some (List.length l)
114 | Q.Coerce _
115 | Q.Directive (_, #ignored_directive, _, _) -> tra e
116 | _ -> None) e in
117 Option.default 0 o
118
119 (* rewrite code by inserting closure_create and closure_apply, etc. directives *)
120 (* build the directive `closure_create using stored information in func_info *)
121 let closure_create cons label info =
122 #<If:CLOSURE_STAT>incr _count_closures#<End>;
123 let expr = Q.Directive (label, `closure_create(info.code, info.arity, info.tsc),[],[]) in
124 cons#make_from_annot expr (Annot.annot label)
125
126 (* build the directive `closure_apply *)
127 let closure_apply cons label f args =
128 let expr = Q.Directive (label, `closure_apply, (f :: args), []) in
129 cons#make_from_annot expr (Annot.annot label)
130
131 (* build the closure without the implementation, for recursive definitions *)
132 let closure_create_no_function cons label info =
133 #<If:CLOSURE_STAT>incr _count_rec_closures#<End>;
134 let expr = Q.Directive (label, `closure_create_no_function (info.code,info.arity,info.tsc), [], []) in
135 cons#make_from_annot expr (Annot.annot label)
136
137 (* define the implementation of an existing closure, for use on closure defined with the above line *)
138 let closure_define_function cons label info =
139 let expr = Q.Directive (label, `closure_define_function (info.closure, info.code, info.tsc), [],[]) in
140 let void_ty = Q.TypeRecord (Q.TyRow ([], None)) in
141 cons#make expr void_ty
142
143 (* get the identifier of the closure identified by info *)
144 let get_closure_ident cons annot info =
145 info.used := true;
146 cons#ident_from_annot info.closure annot
147
148
149 (* register each function in the environment *)
150 (* register one function val x = body
151 we compute the arity from body
152 and get the typescheme from \Gamma *)
153 let make_clos ident =
154 Ident.refresh ~map:(fun s -> "clos_"^s) ident
155 let register_function cons env (x,body) =
156 let n = get_arity body in
157 let tsc =
158 if cons#typed then
159 Some (QmlTypes.Env.Ident.find x cons#gamma)
160 else
161 None in
162 let info =
163 { arity = n
164 ; code = x
165 ; closure = make_clos x
166 ; used = ref false
167 ; tsc = tsc
168 ; from_current_package = true } in
169 let funcs = IdentMap.add x info env.funcs in
170 { funcs = funcs }, info
171
172 (* Do not spamm the list manipulated by the compiler with dummy nodes *)
173 let cons_dec code_elt code =
174 match code_elt with
175 | Q.NewVal (_, [])
176 | Q.NewValRec (_, []) -> code
177 | _ -> code_elt :: code
178
179 (* go through the code and register each function
180 * and add the closure definitions in the code *)
181 let register_code_elt cons env elt =
182 match elt with
183 | Q.NewVal (label, bnds) as c ->
184 (* [val f(x) = 2
185 * and g(y) = 2]
186 *
187 * becomes
188 *
189 * [val f(x) = 2
190 * and g(y) = 2
191 * val clos_f = closure_create f 1 "f"
192 * and clos_g = closure_create g 1 "g"]
193 *)
194 let env, clos_bnds =
195 List.fold_left_filter_map
196 (fun env ((i,body) as fun_bnd) ->
197 match classify body with
198 | `nothing ->
199 env, None
200 | `alias ident -> (
201 try
202 (* when we have an alias g = f where f is a lambda
203 * we also create an alias clos_g = clos_f and we won't rewrite g = f
204 * so that the implementation is still reachable *)
205 let info = IdentMap.find ident env.funcs in
206 if info.from_current_package then
207 (* avoiding introducing useless aliases and also avoid confusing
208 * the cleaning below (because we don't clean the aliases introduced
209 * so we should make sure that they never have to been cleaned in
210 * the first place) *)
211 let env = {funcs = IdentMap.add i info env.funcs} in
212 env, None
213 else (
214 let clos_ident = make_clos i in
215 let new_info =
216 (* same arity, tsc, used *)
217 {info with code = i; closure = clos_ident; from_current_package = true} in
218 let code_elt = (clos_ident, cons#ident_from_annot info.closure (Q.QAnnot.expr body)) in
219 let env = {funcs = IdentMap.add i new_info env.funcs} in
220 env, Some code_elt
221 )
222 with Not_found ->
223 (* not an alias to a toplevel function *)
224 env, None
225 )
226 | `lambda ->
227 let env, info = register_function cons env fun_bnd in
228 let expr = closure_create cons (Q.Label.expr body) info in
229 let closure_decl = (info.closure, expr) in
230 env, Some closure_decl)
231 env
232 bnds in
233 env, (cons_dec c (cons_dec (Q.NewVal (label, clos_bnds)) []))
234 | Q.NewValRec (label, bnds) as c ->
235 (* [val rec f(x) = g(x)
236 * and g(y) = f(y)]
237 *
238 * becomes
239 *
240 * [val clos_f = closure_create_no_function 1 "f"
241 * and clos_g = closure_create_no_function 1 "g"
242 * val rec f(x) = g(x)
243 * and g(y) = f(y)
244 * val _ = closure_define_function clos_f f
245 * and _ = closure_define_function clos_g g]
246 *)
247 (* no need to look for aliases, there can't be any in letrec *)
248 let fun_bnds = List.filter (fun (_,e) -> is_lambda e) bnds in
249 let env, closure_decl =
250 List.fold_left_map
251 (fun env ((_,body) as fun_bnd) ->
252 let env, info = register_function cons env fun_bnd in
253 let expr = closure_create_no_function cons (Q.Label.expr body) info in
254 let pre_closure_decl = (info.closure, expr) in
255 let expr = closure_define_function cons (Q.Label.expr body) info in
256 let post_closure_decl = (Ident.next "_", expr) in
257 env, (pre_closure_decl, post_closure_decl))
258 env
259 fun_bnds in
260 let pre_closure_decls, post_closure_decls = List.split closure_decl in
261 env, cons_dec
262 (Q.NewVal (label, pre_closure_decls))
263 (cons_dec c (cons_dec (Q.NewVal (label, post_closure_decls)) []))
264 | c -> env, [c]
265
266
267 (* the rewriting process:
268 it basically rewrites each Apply node into a `closure_apply directive
269 there are two exceptions:
270 1- bypass:
271 After BypassHoisting pass, it is guaranteed that each bypass application is total.
272 Some care must be taken if bypass are allowed to take qml functions as argument.
273
274 2- non partial calls of toplevel functions.
275
276 Hence, each remaining Apply node in the code is guaranteed to be non partial.
277 *)
278 let rewrite_expr cons env e =
279 QmlAstWalk.Expr.self_traverse_map
280 (fun self tra e ->
281 match e with
282 | Q.Ident (_, x) -> (
283 try
284 let func_info = IdentMap.find x env.funcs in
285 get_closure_ident cons (Q.QAnnot.expr e) func_info
286 with Not_found -> e
287 )
288
289 | Q.Directive (label2, `partial_apply missing, [Q.Apply (_, Q.Ident (label, x), args)], []) ->
290 let args = List.map self args in
291 let func_info =
292 try IdentMap.find x env.funcs
293 with Not_found ->
294 OManager.i_error "Partial application on %s, which is not in env.funcs" (Ident.to_string x) in
295 (*
296 we can only do partial application on toplevel lambdas (syntactically)
297 because only the lambda lifting introduces such cases
298 *)
299 let f = get_closure_ident cons (Annot.annot label) func_info in
300 Q.Directive (label2, `partial_apply missing, [closure_apply cons label2 f args], [])
301
302 | Q.Directive (_, `partial_apply _, _, _) -> assert false
303
304 | Q.Apply (label, (Q.Ident (_, x) as f), args) -> (
305 (*
306 since we are in n-ary, this case can be either a full application of a toplevel function
307 or the application of a closure to its argument
308 *)
309 let args = List.map self args in
310 match IdentMap.find_opt x env.funcs with
311 | None ->
312 closure_apply cons (Q.Label.expr e) f args
313
314 | Some func_info ->
315 (* full application *)
316 assert (
317 List.length args = func_info.arity ||
318 (Format.printf "%d arguments given vs arity of %d on %s in %a@."
319 (List.length args) func_info.arity (Ident.to_string x) QmlPrint.pp#expr e; false)
320 );
321 Q.Apply (label, f, args)
322 )
323
324 | Q.Apply (_, (Q.Bypass _ | Q.Directive (_, (`may_cps | `restricted_bypass _), _, _)), _) ->
325 (*
326 bypass application, it must be full
327 FIXME: assert it
328 *)
329 tra e
330
331 | Q.Apply (label, f, args) ->
332 let args = List.map self args in
333 let f = self f in
334 closure_apply cons label f args
335
336 | _ ->
337 tra e
338
339 ) e
340
341 (* some 'specialized' cleaning for closures
342 * since we know which closure we used and which one was useless, there is no
343 * to go through the whole code to find that information
344 * it is a good idea to clean useless since we create them for every toplevel function
345 * when often, they aren't useful because the function is always fully applied *)
346 let clean_binding ~can_be_cleaned env (_,e) =
347 match e with
348 | Q.Directive (_, `closure_create (i, _, _), _, _) ->
349 let info = IdentMap.find i env.funcs in
350 let kept = !(info.used) || not (can_be_cleaned i) in
351 #<If:CLOSURE_STAT> if not kept then incr _count_cleaned#<End>;
352 kept
353 | Q.Directive (_, `closure_create_no_function (i, _, _), _, _)
354 | Q.Directive (_, `closure_define_function (_, i, _), _, _) ->
355 let info = IdentMap.find i env.funcs in
356 let kept = !(info.used) || not (can_be_cleaned i) in
357 #<If:CLOSURE_STAT> if not kept then incr _count_rec_cleaned#<End>;
358 kept
359 | _ ->
360 true
361
362 let clean_code ~can_be_cleaned env code =
363 QmlAstWalk.Code.filter_binding (clean_binding ~can_be_cleaned env) code
364
365 (* initial env
366 for separate compilation: it must be populated initially
367 *)
368 let empty_env = { funcs = IdentMap.empty }
369
370 (* register each toplevel functions *)
371 let register_code cons env code =
372 List.fold_left_collect (register_code_elt cons) env code
373
374 let rewrite_bnd cons env ((i,e) as bnd) =
375 match classify e with
376 | `alias i when IdentMap.mem i env.funcs -> bnd
377 | _ -> (i,rewrite_expr cons env e)
378
379 (* rewrite the entire code *)
380 let rewrite_code cons env code =
381 QmlAstWalk.CodeExpr.map_name_expr (fun bnd -> rewrite_bnd cons env bnd) code
382
383 (* by default, since we don't have separate compilation
384 * we allow ourselves to clean every unused closures
385 * FIXME we should only clean the closures that cannot be accessed
386 * by other modules (ie from local functions, or from functions hidden by the signatures) *)
387 let process_code ?(can_be_cleaned=fun _ -> ObjectFiles.compilation_mode () = `linking) ~side ~typed gamma annotmap code =
388 #<If:CLOSURE_STAT>
389 _count_closures := 0;
390 _count_cleaned := 0;
391 #<End>;
392 let cons, get_state = QmlAstCons.make_cons ~typed gamma annotmap in
393 let loaded_env = R.load ~side empty_env in
394 let computed_env, code = register_code cons loaded_env code in
395 let diff_env = {funcs = IdentMap.diff computed_env.funcs loaded_env.funcs} in
396 R.save ~side diff_env;
397 let exported_map =
398 IdentMap.fold
399 (fun _ {closure; code} acc -> IdentMap.add closure code acc)
400 diff_env.funcs
401 IdentMap.empty in
402 let code = rewrite_code cons computed_env code in
403 let code = clean_code ~can_be_cleaned computed_env code in
404 #<If:CLOSURE_STAT>
405 let c = !_count_closures in
406 let rc = !_count_rec_closures in
407 let cleaned = !_count_cleaned in
408 let rcleaned = !_count_rec_cleaned / 2 in (* the counter was increment once when removing
409 * the @closure_define and @closure_create_no_function *)
410 let total = c + rc in
411 let total_cleaned = cleaned + rcleaned in
412 let percentage c t = if t = 0 then " - " else Printf.sprintf "%2d%%" (c * 100 / t) in
413 Printf.printf "Total closures created: %d\n" total;
414 Printf.printf " Simple closure: %d\t%s\n" c (percentage c total);
415 Printf.printf " Recursive closure: %d\t%s\n" rc (percentage rc total);
416 Printf.printf "Total closures removed: %d\t%s\n" total_cleaned (percentage total_cleaned total);
417 Printf.printf " Simple closure: %d\t%s\n" cleaned (percentage cleaned c);
418 Printf.printf " Recursive closure: %d\t%s\n%!" rcleaned (percentage rcleaned rc)
419 #<End>;
420 get_state (), exported_map, code
Something went wrong with that request. Please try again.