Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 401 lines (367 sloc) 16.048 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 (*
19 @author Sebastien Briais
20 *)
21
22 module List = Base.List
23 module Q = QmlAst
24 module ConsT = QmlAstCons.TypedExpr
25 module ConsU = QmlAstCons.UntypedExpr
26
27 let bslclosure = "BslClosure"
28 let closure_runtime = "CR"
29
30
31 let make_closure_name ?(safe=false) ~side ~renaming_server ~renaming_client ident =
32 let client_ident =
33 match side with
34 | `client -> ident
35 | `server ->
36 try
37 let common_ident = QmlRenamingMap.original_from_new renaming_server ident in
38 (try QmlRenamingMap.new_from_original renaming_client common_ident
39 with Not_found -> ident)
40 with Not_found when safe ->
41 ident in
42 JsPrint.string_of_ident (JsAst.ExprIdent client_ident)
43
44 let is_other_side ~side ~renaming_server ~renaming_client ident =
45 let renaming, renaming_other_side =
46 match side with
47 | `client -> renaming_client, renaming_server
48 | `server -> renaming_server, renaming_client in
49 match QmlRenamingMap.original_from_new_opt renaming ident with
50 | None -> false (* No original ident perhaps a local function
51 (lambda lifting is after slicing)*)
52 | Some oident ->
53 match QmlRenamingMap.new_from_original_opt renaming_other_side oident with
54 | None -> false
55 | Some _ -> true
56
57 let mk_identifier ~typed ~side ~renaming_server ~renaming_client gamma annotmap ident =
58 (* presumably, any string that contains the filename should be ok
59 * (the filename will certainly be needed for separate compilation) *)
60 let name = make_closure_name ~safe:true ~side ~renaming_server ~renaming_client ident in
61 let is_other_side = is_other_side ~side ~renaming_server ~renaming_client ident in
62 let annotmap, s = ConsT.string annotmap name in
63 let annotmap, b =
64 if typed then
65 ConsT.bool_no_named_type (annotmap, gamma) is_other_side
66 else
67 annotmap, ConsU.bool is_other_side in
68 annotmap, s, b
69
70 let initial_needed_env_apply = -1
71 let initial_needed_args_apply = -1
72 let needed_env_apply = ref initial_needed_env_apply
73 let needed_args_apply = ref initial_needed_args_apply
74 let reset () =
75 needed_env_apply := initial_needed_env_apply;
76 needed_args_apply := initial_needed_args_apply
77
78 let env_apply_ident = Printf.sprintf "clos_env_%d"
79 let env_apply_exprident d = Ident.fake_source (env_apply_ident d)
80 let args_apply_ident = Printf.sprintf "clos_args_%d"
81 let args_apply_exprident d = Ident.fake_source (args_apply_ident d)
82 let export_ident = Printf.sprintf "clos_export_%d"
83
84 let type_of_env_apply gamma annotmap e env_size =
85 let ty = QmlAnnotMap.find_ty (Q.QAnnot.expr e) annotmap in
86 match QmlTypesUtils.Inspect.follow_alias_noopt_private gamma ty with
87 | Q.TypeArrow (params,return) ->
88 let env, args = List.split_at env_size params in
89 Q.TypeArrow (ty :: env, Q.TypeArrow (args,return))
90 | _ -> assert false
91
92 let type_of_args_apply gamma annotmap e =
93 let ty = QmlAnnotMap.find_ty (Q.QAnnot.expr e) annotmap in
94 match QmlTypesUtils.Inspect.follow_alias_noopt_private gamma ty with
95 | Q.TypeArrow (params,return) ->
96 Q.TypeArrow (ty :: params, return)
97 | _ ->
98 OManager.i_error "@[<v2>QmlClosure: applying an expression with a non arrow type:@ @[<v2>type:@ %a@]@ @[<v2>expr:@ %a@]@]@." QmlPrint.pp#ty ty QmlPrint.pp#expr e
99
100 let env_apply ~typed (gamma,annotmap) e es =
101 let env_size = List.length es in
102 needed_env_apply := max env_size !needed_env_apply;
103 let annot, annotmap =
104 if typed then
105 let annot = Annot.next () in
106 let ty = type_of_env_apply gamma annotmap e env_size in
107 let annotmap = QmlAnnotMap.add_ty annot ty annotmap in
108 annot, annotmap
109 else
110 Annot.next (), annotmap in
111 let label = Annot.make_label annot (Q.Pos.expr e) in
112 let ident = Q.Directive (label, `backend_ident (env_apply_ident env_size), [ConsU.ident (env_apply_exprident env_size)], []) in
113 if typed then
114 ConsT.apply gamma annotmap ident (e :: es)
115 else
116 annotmap, ConsU.apply ident (e :: es)
117
118 let args_apply ~typed (gamma,annotmap) e es =
119 let args_size = List.length es in
120 needed_args_apply := max args_size !needed_args_apply;
121 let annot, annotmap =
122 if typed then
123 let annot = Annot.next () in
124 let ty = type_of_args_apply gamma annotmap e in
125 let annotmap = QmlAnnotMap.add_ty annot ty annotmap in
126 annot, annotmap
127 else
128 Annot.next (), annotmap in
129 let label = Annot.make_label annot (Q.Pos.expr e) in
130 let ident = Q.Directive (label, `backend_ident (args_apply_ident args_size), [ConsU.ident (args_apply_exprident args_size)], []) in
131 if typed then
132 ConsT.apply gamma annotmap ident (e :: es)
133 else
134 annotmap, ConsU.apply ident (e :: es)
135
136 let rewrite_expr ~typed bp_typer ~side ~renaming_client ~renaming_server gamma annotmap e =
137 QmlAstWalk.Expr.self_traverse_foldmap
138 (fun self tra annotmap e ->
139 match e with
140 | Q.Directive (label, (`closure_create (f, _arity, _tsc) as d), _, _)
141 | Q.Directive (label, (`closure_create_no_function (f, _arity, _tsc) as d), _, _) ->
142 (* FIXME: this part generates untyped code, but this part of the code is
143 * so simple that who needs type anyway ? *)
144 let bp =
145 match d with
146 | `closure_create _ -> Opacapi.Opabsl.BslClosure.create_and_register
147 | `closure_create_no_function _ -> Opacapi.Opabsl.BslClosure.create_no_function_and_register in
148 let pos = Annot.pos label in
149 let annotmap, ccreate = QmlAstCons.TypedExpr.bypass ~pos annotmap bp (bp_typer bp) in
150 let annotmap, identifier, is_other_side = mk_identifier ~typed ~side ~renaming_client ~renaming_server gamma annotmap f in
151 let f = QmlAstCons.UntypedExpr.ident f in
152 let arity = QmlAstCons.UntypedExpr.int _arity in
153 let args =
154 let common_args = [arity;identifier;is_other_side] in
155 match d with
156 | `closure_create _ -> f :: common_args
157 | `closure_create_no_function _ -> common_args in
158 let e = QmlAstCons.UntypedExpr.apply ccreate args in
159 tra annotmap e
160 | Q.Directive (label, `closure_define_function (clos, code, _tsc), _, _) ->
161 (* FIXME: same as above *)
162 let bp = Opacapi.Opabsl.BslClosure.define_function in
163 let pos = Annot.pos label in
164 let annotmap, define = QmlAstCons.TypedExpr.bypass ~pos annotmap bp (bp_typer bp) in
165 let e_clos = QmlAstCons.UntypedExpr.ident clos in
166 let e_code = QmlAstCons.UntypedExpr.ident code in
167 let e = QmlAstCons.UntypedExpr.apply define [e_clos; e_code] in
168 annotmap, e
169 | Q.Directive (label, `partial_apply missing, [Q.Directive (_, `closure_apply, e :: es, _)], _) ->
170 let annotmap, e = self annotmap e in
171 let annotmap, es = List.fold_left_map self annotmap es in
172 let annotmap, e = env_apply ~typed (gamma,annotmap) e es in
173 let e = Q.Directive (label,`partial_apply missing, [e], []) in
174 annotmap,e
175 | Q.Directive (_, `partial_apply _, _, _) -> assert false
176 | Q.Directive(_, `closure_apply, e :: es, _) ->
177 let annotmap, e = self annotmap e in
178 let annotmap, es = List.fold_left_map self annotmap es in
179 let annotmap, e = args_apply ~typed (gamma,annotmap) e es in
180 annotmap,e
181 | _ -> tra annotmap e
182 ) annotmap e
183
184 let rewrite_code ~typed bymap ~side ~renaming_client ~renaming_server (gamma,annotmap) code =
185 QmlAstWalk.CodeExpr.fold_map (rewrite_expr ~typed bymap ~side ~renaming_client ~renaming_server gamma) annotmap code
186
187 let populate_gamma gamma =
188 gamma
189
190 let process_code ~typed ~side ~renaming_client ~renaming_server bymap gamma annotmap code =
191 let bp_typer key = Option.get (bymap key) in
192 let gamma = populate_gamma gamma in
193 let annotmap,code = rewrite_code ~typed bp_typer ~side ~renaming_client ~renaming_server (gamma,annotmap) code in
194 (gamma,annotmap),code
195
196 (*----------------------------------------*)
197 (*------- dynamic generation of code -----*)
198 (*----------------------------------------*)
199
200 (* Example of generated code
201 function clos_args_1(f,x0) {
202 if (f.takes_array_arg) return f.func([x0])
203 var args = f.args
204 switch (args.length) {
205 case 0: return f.func(x0)
206 case 1: return f.func(args[0],x0)
207 case 2: return f.func(args[0],args[1],x0)
208 case 3: return f.func(args[0],args[1],args[2],x0)
209 default: return args_apply(f,[x0]);
210 }
211 *)
212 let js_size_of_clos_args = 8 (* arbitrary *)
213 let js_clos_args n =
214 let clos_args = args_apply_exprident n in
215 let clos_args = JsCons.Ident.ident clos_args in
216 let fun_ = JsCons.Ident.native "f" in
217 let args = JsCons.Ident.native "args" in
218 let params = List.init n (fun i -> JsCons.Ident.native (Printf.sprintf "x%d" i)) in
219 let params_expr () = List.map JsCons.Expr.ident params in
220 JsCons.Statement.function_ clos_args (fun_ :: params) [
221 JsCons.Statement.if_no_else
222 (JsCons.Expr.dot (JsCons.Expr.ident fun_) "takes_array_arg")
223 (JsCons.Statement.return (JsCons.Expr.call ~pure:false (JsCons.Expr.dot (JsCons.Expr.ident fun_) "func") [JsCons.Expr.list (params_expr ())]));
224 JsCons.Statement.var args ~expr:(JsCons.Expr.dot (JsCons.Expr.ident fun_) "args");
225 JsCons.Statement.switch (JsCons.Expr.dot (JsCons.Expr.ident args) "length")
226 (List.init js_size_of_clos_args
227 (fun i ->
228 let test = JsCons.Expr.int i in
229 let env = List.init i (fun j -> JsCons.Expr.hashref (JsCons.Expr.ident args) (JsCons.Expr.int j)) in
230 let all_params = env @ params_expr () in
231 let call = JsCons.Expr.call ~pure:false (JsCons.Expr.dot (JsCons.Expr.ident fun_) "func") all_params in
232 let rhs = JsCons.Statement.return call in
233 test, rhs
234 )
235 )
236 ~default:(JsCons.Statement.return (JsCons.Expr.call ~pure:false (JsCons.Expr.native "args_apply") [JsCons.Expr.ident fun_; JsCons.Expr.list (params_expr ())]))
237 ]
238
239 let js_clos_env n =
240 let clos_env = env_apply_exprident n in
241 let clos_env = JsCons.Ident.ident clos_env in
242 let fun_ = JsCons.Ident.native "f" in
243 let params = List.init n (fun i -> JsCons.Ident.native (Printf.sprintf "x%d" i)) in
244 let mkfield field = field, JsCons.Expr.dot (JsCons.Expr.ident fun_) field in
245 JsCons.Statement.function_ clos_env (fun_ :: params) [
246 JsCons.Statement.return (
247 JsCons.Expr.obj [
248 mkfield "func";
249 mkfield "arity";
250 mkfield "identifier";
251 mkfield "takes_array_arg";
252 "args", JsCons.Expr.list (List.map JsCons.Expr.ident params);
253 ]
254 )
255 ]
256
257 module Gen =
258 struct
259 let rec repeat_aux f i n =
260 if i = n then () else (f i; repeat_aux f (i+1) n)
261 let repeat f n =
262 repeat_aux f 0 n
263
264 let array ~lang buffer make n =
265 let pp fmt = Printf.bprintf buffer fmt in
266 match lang,n with
267 | `caml, 0 -> pp "[||]"
268 | `caml, 1 -> pp "(Obj.magic {tuple1 = %s} : Obj.t array)" (make 0)
269 | `caml, _ -> pp "(Obj.magic (%s" (make 0); repeat_aux (fun d -> pp ", %s" (make d)) 1 n; pp ") : Obj.t array)"
270 | `js, 0 -> pp "[]"
271 | `js, _ -> pp "[%s" (make 0); repeat_aux (fun d -> pp ", %s" (make d)) 1 n; pp "]"
272
273 (* caml only *)
274 let pat_array buffer make n =
275 let pp fmt = Printf.bprintf buffer fmt in
276 match n with
277 | 0 -> pp "[||]"
278 | _ -> pp "[|%s" (make 0); repeat_aux (fun d -> pp "; %s" (make d)) 1 n; pp "|]"
279 end
280
281 (* [caml_generate_apply buffer N] generates
282 [let clos_applyN f x0 x1 ... xN-1 =
283 BslClosure.apply f (Obj.magic (x0,x1,...,xN-1) : Obj.t array)
284 (* using a tuple to avoid the float array optimization *)
285 ]
286 *)
287 let init_code ~lang buffer =
288 let pp fmt = Printf.bprintf buffer fmt in
289 match lang with
290 | `caml -> pp "type 'a tuple1 = { tuple1 : 'a }\n"
291 | `js -> ()
292
293 (* could generated more but then the code can increase dramatically *)
294 let max_opt = 9
295 let caml_apply buffer n =
296 let pp fmt = Printf.bprintf buffer fmt in
297 match n with
298 | 1 ->
299 (* apply1 is already written in the runtime library *)
300 pp "let %s = %s.args_apply1\n\n" (args_apply_ident n) closure_runtime
301 | _ ->
302 let arg = Printf.sprintf "a%d" in
303 let env = Printf.sprintf "e%d" in
304 pp "let %s closure %s =\n" (args_apply_ident n) (String.concat " " (List.init n arg));
305 if n > max_opt then (
306 pp " %s.args_apply closure " closure_runtime;
307 Gen.array ~lang:`caml buffer arg n;
308 pp "\n\n"
309 ) else (
310 pp "match closure.%s.args with\n" closure_runtime;
311 for i = 0 to max_opt do
312 pp " | ";
313 Gen.pat_array buffer env i;
314 pp " -> (Obj.magic closure.%s.func) " closure_runtime;
315 if i = 0 && n = 0 then (
316 pp "()"
317 ) else (
318 pp "%s%s%s" (String.concat " " (List.init i env)) (if n = 0 then "" else " ") (String.concat " " (List.init n arg))
319 );
320 pp "\n"
321 done;
322 pp " | _ -> %s.args_apply closure" closure_runtime;
323 Gen.array ~lang:`caml buffer arg n;
324 pp "\n\n"
325 )
326
327 let generate_env_apply ~lang buffer n =
328 let pp fmt = Printf.bprintf buffer fmt in
329 let x = Printf.sprintf "x%d" in
330 match lang with
331 | `caml ->
332 pp "let %s f %s =\n" (env_apply_ident n) (String.concat " " (List.init n x));
333 pp " %s.env_apply f " closure_runtime;
334 Gen.array ~lang buffer x n;
335 pp "\n"
336 | `js ->
337 pp "function %s(f%s%s) {\n" (env_apply_ident n) (if n = 0 then "" else ",") (String.concat "," (List.init n x));
338 pp " return env_apply(f,";
339 Gen.array ~lang buffer x n;
340 pp ");\n}\n"
341
342 let generate_args_apply ~lang buffer n =
343 let pp fmt = Printf.bprintf buffer fmt in
344 let x = Printf.sprintf "x%d" in
345 match lang with
346 | `caml ->
347 #<If:CLOSURE_OPT$maxlevel (-1)>
348 pp "let %s f %s =\n" (args_apply_ident n) (String.concat " " (List.init n x));
349 pp " %s.args_apply f " closure_runtime;
350 Gen.array ~lang buffer (Printf.sprintf "x%d") n;
351 pp "\n"
352 #<Else>
353 caml_apply buffer n
354 #<End>
355 | `js ->
356 pp "function %s(f%s%s) {\n" (args_apply_ident n) (if n = 0 then "" else ",") (String.concat "," (List.init n x));
357 pp " return args_apply(f,";
358 Gen.array ~lang buffer x n;
359 pp ");\n}\n"
360
361 let generate_export ~lang buffer i =
362 let pp fmt = Printf.bprintf buffer fmt in
363 match lang with
364 | `caml ->
365 let arg = Printf.sprintf "a%d" in
366 pp "let %s clos =\n" (export_ident i);
367 let args = (String.concat " " (List.init i arg)) in
368 pp " fun %s -> %s clos%s\n" (if args = "" then "()" else args) (args_apply_ident i) (if args = "" then "" else " "^args)
369 | `js -> ()
370
371 let generate_applys ?at_least lang =
372 let n = !needed_args_apply in
373 let n =
374 match at_least with
375 | None -> n
376 | Some n' -> max n n' in
377 let buffer = Buffer.create 100 in
378 init_code ~lang buffer;
379 for i = 0 to n do
380 generate_args_apply ~lang buffer i
381 done;
382 for i = 0 to n do
383 generate_export ~lang buffer i
384 done;
385 let n = !needed_env_apply in
386 for i = 0 to n do
387 generate_env_apply ~lang buffer i
388 done;
389 reset ();
390 Buffer.contents buffer
391
392 let generate_applys_js ?at_least () =
393 let n_args = !needed_args_apply in
394 let n_args =
395 match at_least with
396 | None -> n_args
397 | Some n -> max n_args n in
398 let n_env = !needed_env_apply in
399 List.init (n_args+1) (fun n -> args_apply_ident n, js_clos_args n) @
400 List.init (n_env+1) (fun n -> env_apply_ident n, js_clos_env n)
Something went wrong with that request. Please try again.