1 (**************************************************************************)
2 (* *)
3 (* OCaml *)
4 (* *)
5 (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
6 (* *)
7 (* Copyright 1996 Institut National de Recherche en Informatique et *)
8 (* en Automatique. *)
9 (* *)
10 (* All rights reserved. This file is distributed under the terms of *)
11 (* the GNU Lesser General Public License version 2.1, with the *)
12 (* special exception on linking described in the file LICENSE. *)
13 (* *)
14 (**************************************************************************)
15
16 open Asttypes
17 open Types
18 open Typedtree
19 open Lambda
20 open Translobj
21 open Translcore
22
23 (* XXX Rajouter des evenements... | Add more events... *)
24
25 type error = Tags of label * label
26
27 exception Error of Location.t * error
28
29 let lfunction params body =
30 if params = [] then body else
31 match body with
32 | Lfunction {kind = Curried; params = params'; body = body'; attr; loc} ->
33 Lfunction {kind = Curried; params = params @ params';
34 return = Pgenval;
35 body = body'; attr;
36 loc}
37 | _ ->
38 Lfunction {kind = Curried; params; return = Pgenval;
39 body;
40 attr = default_function_attribute;
41 loc = Location.none}
42
43 let lapply ap =
44 match ap.ap_func with
45 Lapply ap' ->
46 Lapply {ap with ap_func = ap'.ap_func; ap_args = ap'.ap_args @ ap.ap_args}
47 | _ ->
48 Lapply ap
49
50 let mkappl (func, args) =
51 Lapply {ap_should_be_tailcall=false;
52 ap_loc=Location.none;
53 ap_func=func;
54 ap_args=args;
55 ap_inlined=Default_inline;
56 ap_specialised=Default_specialise};;
57
58 let lsequence l1 l2 =
59 if l2 = lambda_unit then l1 else Lsequence(l1, l2)
60
61 let lfield v i = Lprim(Pfield i, [Lvar v], Location.none)
62
63 let transl_label l = share (Const_immstring l)
64
65 let transl_meth_list lst =
66 if lst = [] then Lconst (Const_pointer 0) else
67 share (Const_block
68 (0, List.map (fun lab -> Const_immstring lab) lst))
69
70 let set_inst_var obj id expr =
71 Lprim(Psetfield_computed (Typeopt.maybe_pointer expr, Assignment),
72 [Lvar obj; Lvar id; transl_exp expr], Location.none)
73
74 let transl_val tbl create name =
75 mkappl (oo_prim (if create then "new_variable" else "get_variable"),
76 [Lvar tbl; transl_label name])
77
78 let transl_vals tbl create strict vals rem =
79 List.fold_right
80 (fun (name, id) rem ->
81 Llet(strict, Pgenval, id, transl_val tbl create name, rem))
82 vals rem
83
84 let meths_super tbl meths inh_meths =
85 List.fold_right
86 (fun (nm, id) rem ->
87 try
88 (nm, id,
89 mkappl(oo_prim "get_method", [Lvar tbl; Lvar (Meths.find nm meths)]))
90 :: rem
91 with Not_found -> rem)
92 inh_meths []
93
94 let bind_super tbl (vals, meths) cl_init =
95 transl_vals tbl false StrictOpt vals
96 (List.fold_right (fun (_nm, id, def) rem ->
97 Llet(StrictOpt, Pgenval, id, def, rem))
98 meths cl_init)
99
100 let create_object cl obj init =
101 let obj' = Ident.create_local "self" in
102 let (inh_init, obj_init, has_init) = init obj' in
103 if obj_init = lambda_unit then
104 (inh_init,
105 mkappl (oo_prim (if has_init then "create_object_and_run_initializers"
106 else"create_object_opt"),
107 [obj; Lvar cl]))
108 else begin
109 (inh_init,
110 Llet(Strict, Pgenval, obj',
111 mkappl (oo_prim "create_object_opt", [obj; Lvar cl]),
112 Lsequence(obj_init,
113 if not has_init then Lvar obj' else
114 mkappl (oo_prim "run_initializers_opt",
115 [obj; Lvar obj'; Lvar cl]))))
116 end
117
118 let name_pattern default p =
119 match p.pat_desc with
120 | Tpat_var (id, _) -> id
121 | Tpat_alias(_, id, _) -> id
122 | _ -> Ident.create_local default
123
124 let rec build_object_init cl_table obj params inh_init obj_init cl =
125 match cl.cl_desc with
126 Tcl_ident (path, _, _) ->
127 let obj_init = Ident.create_local "obj_init" in
128 let envs, inh_init = inh_init in
129 let env =
130 match envs with None -> []
131 | Some envs ->
132 [Lprim(Pfield (List.length inh_init + 1),
133 [Lvar envs],
134 Location.none)]
135 in
136 let path_lam = transl_class_path cl.cl_loc cl.cl_env path in
137 ((envs, (path, path_lam, obj_init) :: inh_init),
138 mkappl(Lvar obj_init, env @ [obj]))
139 | Tcl_structure str ->
140 create_object cl_table obj (fun obj ->
141 let (inh_init, obj_init, has_init) =
142 List.fold_right
143 (fun field (inh_init, obj_init, has_init) ->
144 match field.cf_desc with
145 Tcf_inherit (_, cl, _, _, _) ->
146 let (inh_init, obj_init') =
147 build_object_init cl_table (Lvar obj) [] inh_init
148 (fun _ -> lambda_unit) cl
149 in
150 (inh_init, lsequence obj_init' obj_init, true)
151 | Tcf_val (_, _, id, Tcfk_concrete (_, exp), _) ->
152 (inh_init, lsequence (set_inst_var obj id exp) obj_init,
153 has_init)
154 | Tcf_method _ | Tcf_val _ | Tcf_constraint _ | Tcf_attribute _->
155 (inh_init, obj_init, has_init)
156 | Tcf_initializer _ ->
157 (inh_init, obj_init, true)
158 )
159 str.cstr_fields
160 (inh_init, obj_init obj, false)
161 in
162 (inh_init,
163 List.fold_right
164 (fun (id, expr) rem ->
165 lsequence (Lifused (id, set_inst_var obj id expr)) rem)
166 params obj_init,
167 has_init))
168 | Tcl_fun (_, pat, vals, cl, partial) ->
169 let (inh_init, obj_init) =
170 build_object_init cl_table obj (vals @ params) inh_init obj_init cl
171 in
172 (inh_init,
173 let build params rem =
174 let param = name_pattern "param" pat in
175 Lfunction {kind = Curried; params = (param, Pgenval)::params;
176 return = Pgenval;
177 attr = default_function_attribute;
178 loc = pat.pat_loc;
179 body = Matching.for_function
180 pat.pat_loc None (Lvar param) [pat, rem] partial}
181 in
182 begin match obj_init with
183 Lfunction {kind = Curried; params; body = rem} -> build params rem
184 | rem -> build [] rem
185 end)
186 | Tcl_apply (cl, oexprs) ->
187 let (inh_init, obj_init) =
188 build_object_init cl_table obj params inh_init obj_init cl
189 in
190 (inh_init, transl_apply obj_init oexprs Location.none)
191 | Tcl_let (rec_flag, defs, vals, cl) ->
192 let (inh_init, obj_init) =
193 build_object_init cl_table obj (vals @ params) inh_init obj_init cl
194 in
195 (inh_init, Translcore.transl_let rec_flag defs obj_init)
196 | Tcl_open (_, cl)
197 | Tcl_constraint (cl, _, _, _, _) ->
198 build_object_init cl_table obj params inh_init obj_init cl
199
200 let rec build_object_init_0 cl_table params cl copy_env subst_env top ids =
201 match cl.cl_desc with
202 Tcl_let (_rec_flag, _defs, vals, cl) ->
203 build_object_init_0 cl_table (vals@params) cl copy_env subst_env top ids
204 | _ ->
205 let self = Ident.create_local "self" in
206 let env = Ident.create_local "env" in
207 let obj = if ids = [] then lambda_unit else Lvar self in
208 let envs = if top then None else Some env in
209 let ((_,inh_init), obj_init) =
210 build_object_init cl_table obj params (envs,[]) copy_env cl in
211 let obj_init =
212 if ids = [] then obj_init else lfunction [self, Pgenval] obj_init in
213 (inh_init, lfunction [env, Pgenval] (subst_env env inh_init obj_init))
214
215
216 let bind_method tbl lab id cl_init =
217 Llet(Strict, Pgenval, id, mkappl (oo_prim "get_method_label",
218 [Lvar tbl; transl_label lab]),
219 cl_init)
220
221 let bind_methods tbl meths vals cl_init =
222 let methl = Meths.fold (fun lab id tl -> (lab,id) :: tl) meths [] in
223 let len = List.length methl and nvals = List.length vals in
224 if len < 2 && nvals = 0 then Meths.fold (bind_method tbl) meths cl_init else
225 if len = 0 && nvals < 2 then transl_vals tbl true Strict vals cl_init else
226 let ids = Ident.create_local "ids" in
227 let i = ref (len + nvals) in
228 let getter, names =
229 if nvals = 0 then "get_method_labels", [] else
230 "new_methods_variables", [transl_meth_list (List.map fst vals)]
231 in
232 Llet(Strict, Pgenval, ids,
233 mkappl (oo_prim getter,
234 [Lvar tbl; transl_meth_list (List.map fst methl)] @ names),
235 List.fold_right
236 (fun (_lab,id) lam -> decr i; Llet(StrictOpt, Pgenval, id,
237 lfield ids !i, lam))
238 (methl @ vals) cl_init)
239
240 let output_methods tbl methods lam =
241 match methods with
242 [] -> lam
243 | [lab; code] ->
244 lsequence (mkappl(oo_prim "set_method", [Lvar tbl; lab; code])) lam
245 | _ ->
246 lsequence (mkappl(oo_prim "set_methods",
247 [Lvar tbl; Lprim(Pmakeblock(0,Immutable,None),
248 methods, Location.none)]))
249 lam
250
251 let rec ignore_cstrs cl =
252 match cl.cl_desc with
253 Tcl_constraint (cl, _, _, _, _) -> ignore_cstrs cl
254 | Tcl_apply (cl, _) -> ignore_cstrs cl
255 | _ -> cl
256
257 let rec index a = function
258 [] -> raise Not_found
259 | b :: l ->
260 if b = a then 0 else 1 + index a l
261
262 let bind_id_as_val (id, _) = ("", id)
263
264 let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
265 match cl.cl_desc with
266 | Tcl_ident _ ->
267 begin match inh_init with
268 | (_, path_lam, obj_init)::inh_init ->
269 (inh_init,
270 Llet (Strict, Pgenval, obj_init,
271 mkappl(Lprim(Pfield 1, [path_lam], Location.none), Lvar cla ::
272 if top then [Lprim(Pfield 3, [path_lam], Location.none)]
273 else []),
274 bind_super cla super cl_init))
275 | _ ->
276 assert false
277 end
278 | Tcl_structure str ->
279 let cl_init = bind_super cla super cl_init in
280 let (inh_init, cl_init, methods, values) =
281 List.fold_right
282 (fun field (inh_init, cl_init, methods, values) ->
283 match field.cf_desc with
284 Tcf_inherit (_, cl, _, vals, meths) ->
285 let cl_init = output_methods cla methods cl_init in
286 let inh_init, cl_init =
287 build_class_init cla false
288 (vals, meths_super cla str.cstr_meths meths)
289 inh_init cl_init msubst top cl in
290 (inh_init, cl_init, [], values)
291 | Tcf_val (name, _, id, _, over) ->
292 let values =
293 if over then values else (name.txt, id) :: values
294 in
295 (inh_init, cl_init, methods, values)
296 | Tcf_method (_, _, Tcfk_virtual _)
297 | Tcf_constraint _
298 ->
299 (inh_init, cl_init, methods, values)
300 | Tcf_method (name, _, Tcfk_concrete (_, exp)) ->
301 let met_code = msubst true (transl_exp exp) in
302 let met_code =
303 if !Clflags.native_code && List.length met_code = 1 then
304 (* Force correct naming of method for profiles *)
305 let met = Ident.create_local ("method_" ^ name.txt) in
306 [Llet(Strict, Pgenval, met, List.hd met_code, Lvar met)]
307 else met_code
308 in
309 (inh_init, cl_init,
310 Lvar(Meths.find name.txt str.cstr_meths) :: met_code @ methods,
311 values)
312 | Tcf_initializer exp ->
313 (inh_init,
314 Lsequence(mkappl (oo_prim "add_initializer",
315 Lvar cla :: msubst false (transl_exp exp)),
316 cl_init),
317 methods, values)
318 | Tcf_attribute _ ->
319 (inh_init, cl_init, methods, values))
320 str.cstr_fields
321 (inh_init, cl_init, [], [])
322 in
323 let cl_init = output_methods cla methods cl_init in
324 (inh_init, bind_methods cla str.cstr_meths values cl_init)
325 | Tcl_fun (_, _pat, vals, cl, _) ->
326 let (inh_init, cl_init) =
327 build_class_init cla cstr super inh_init cl_init msubst top cl
328 in
329 let vals = List.map bind_id_as_val vals in
330 (inh_init, transl_vals cla true StrictOpt vals cl_init)
331 | Tcl_apply (cl, _exprs) ->
332 build_class_init cla cstr super inh_init cl_init msubst top cl
333 | Tcl_let (_rec_flag, _defs, vals, cl) ->
334 let (inh_init, cl_init) =
335 build_class_init cla cstr super inh_init cl_init msubst top cl
336 in
337 let vals = List.map bind_id_as_val vals in
338 (inh_init, transl_vals cla true StrictOpt vals cl_init)
339 | Tcl_constraint (cl, _, vals, meths, concr_meths) ->
340 let virt_meths =
341 List.filter (fun lab -> not (Concr.mem lab concr_meths)) meths in
342 let concr_meths = Concr.elements concr_meths in
343 let narrow_args =
344 [Lvar cla;
345 transl_meth_list vals;
346 transl_meth_list virt_meths;
347 transl_meth_list concr_meths] in
348 let cl = ignore_cstrs cl in
349 begin match cl.cl_desc, inh_init with
350 | Tcl_ident (path, _, _), (path', path_lam, obj_init)::inh_init ->
351 assert (Path.same path path');
352 let inh = Ident.create_local "inh"
353 and ofs = List.length vals + 1
354 and valids, methids = super in
355 let cl_init =
356 List.fold_left
357 (fun init (nm, id, _) ->
358 Llet(StrictOpt, Pgenval, id,
359 lfield inh (index nm concr_meths + ofs),
360 init))
361 cl_init methids in
362 let cl_init =
363 List.fold_left
364 (fun init (nm, id) ->
365 Llet(StrictOpt, Pgenval, id,
366 lfield inh (index nm vals + 1), init))
367 cl_init valids in
368 (inh_init,
369 Llet (Strict, Pgenval, inh,
370 mkappl(oo_prim "inherits", narrow_args @
371 [path_lam;
372 Lconst(Const_pointer(if top then 1 else 0))]),
373 Llet(StrictOpt, Pgenval, obj_init, lfield inh 0, cl_init)))
374 | _ ->
375 let core cl_init =
376 build_class_init cla true super inh_init cl_init msubst top cl
377 in
378 if cstr then core cl_init else
379 let (inh_init, cl_init) =
380 core (Lsequence (mkappl (oo_prim "widen", [Lvar cla]), cl_init))
381 in
382 (inh_init,
383 Lsequence(mkappl (oo_prim "narrow", narrow_args),
384 cl_init))
385 end
386 | Tcl_open (_, cl) ->
387 build_class_init cla cstr super inh_init cl_init msubst top cl
388
389 let rec build_class_lets cl =
390 match cl.cl_desc with
391 Tcl_let (rec_flag, defs, _vals, cl') ->
392 let env, wrap = build_class_lets cl' in
393 (env, fun x ->
394 Translcore.transl_let rec_flag defs (wrap x))
395 | _ ->
396 (cl.cl_env, fun x -> x)
397
398 let rec get_class_meths cl =
399 match cl.cl_desc with
400 Tcl_structure cl ->
401 Meths.fold (fun _ -> Ident.Set.add) cl.cstr_meths Ident.Set.empty
402 | Tcl_ident _ -> Ident.Set.empty
403 | Tcl_fun (_, _, _, cl, _)
404 | Tcl_let (_, _, _, cl)
405 | Tcl_apply (cl, _)
406 | Tcl_open (_, cl)
407 | Tcl_constraint (cl, _, _, _, _) -> get_class_meths cl
408
409 (*
410 XXX Il devrait etre peu couteux d'ecrire des classes :
411 | Writing classes should be cheap
412 class c x y = d e f
413 *)
414 let rec transl_class_rebind obj_init cl vf =
415 match cl.cl_desc with
416 Tcl_ident (path, _, _) ->
417 if vf = Concrete then begin
418 try if (Env.find_class path cl.cl_env).cty_new = None then raise Exit
419 with Not_found -> raise Exit
420 end;
421 let path_lam = transl_class_path cl.cl_loc cl.cl_env path in
422 (path, path_lam, obj_init)
423 | Tcl_fun (_, pat, _, cl, partial) ->
424 let path, path_lam, obj_init = transl_class_rebind obj_init cl vf in
425 let build params rem =
426 let param = name_pattern "param" pat in
427 Lfunction {kind = Curried; params = (param, Pgenval)::params;
428 return = Pgenval;
429 attr = default_function_attribute;
430 loc = pat.pat_loc;
431 body = Matching.for_function
432 pat.pat_loc None (Lvar param) [pat, rem] partial}
433 in
434 (path, path_lam,
435 match obj_init with
436 Lfunction {kind = Curried; params; body} -> build params body
437 | rem -> build [] rem)
438 | Tcl_apply (cl, oexprs) ->
439 let path, path_lam, obj_init = transl_class_rebind obj_init cl vf in
440 (path, path_lam, transl_apply obj_init oexprs Location.none)
441 | Tcl_let (rec_flag, defs, _vals, cl) ->
442 let path, path_lam, obj_init = transl_class_rebind obj_init cl vf in
443 (path, path_lam, Translcore.transl_let rec_flag defs obj_init)
444 | Tcl_structure _ -> raise Exit
445 | Tcl_constraint (cl', _, _, _, _) ->
446 let path, path_lam, obj_init = transl_class_rebind obj_init cl' vf in
447 let rec check_constraint = function
448 Cty_constr(path', _, _) when Path.same path path' -> ()
449 | Cty_arrow (_, _, cty) -> check_constraint cty
450 | _ -> raise Exit
451 in
452 check_constraint cl.cl_type;
453 (path, path_lam, obj_init)
454 | Tcl_open (_, cl) ->
455 transl_class_rebind obj_init cl vf
456
457 let rec transl_class_rebind_0 (self:Ident.t) obj_init cl vf =
458 match cl.cl_desc with
459 Tcl_let (rec_flag, defs, _vals, cl) ->
460 let path, path_lam, obj_init =
461 transl_class_rebind_0 self obj_init cl vf
462 in
463 (path, path_lam, Translcore.transl_let rec_flag defs obj_init)
464 | _ ->
465 let path, path_lam, obj_init = transl_class_rebind obj_init cl vf in
466 (path, path_lam, lfunction [self, Pgenval] obj_init)
467
468 let transl_class_rebind cl vf =
469 try
470 let obj_init = Ident.create_local "obj_init"
471 and self = Ident.create_local "self" in
472 let obj_init0 =
473 lapply {ap_should_be_tailcall=false;
474 ap_loc=Location.none;
475 ap_func=Lvar obj_init;
476 ap_args=[Lvar self];
477 ap_inlined=Default_inline;
478 ap_specialised=Default_specialise}
479 in
480 let _, path_lam, obj_init' = transl_class_rebind_0 self obj_init0 cl vf in
481 let id = (obj_init' = lfunction [self, Pgenval] obj_init0) in
482 if id then path_lam else
483
484 let cla = Ident.create_local "class"
485 and new_init = Ident.create_local "new_init"
486 and env_init = Ident.create_local "env_init"
487 and table = Ident.create_local "table"
488 and envs = Ident.create_local "envs" in
489 Llet(
490 Strict, Pgenval, new_init, lfunction [obj_init, Pgenval] obj_init',
491 Llet(
492 Alias, Pgenval, cla, path_lam,
493 Lprim(Pmakeblock(0, Immutable, None),
494 [mkappl(Lvar new_init, [lfield cla 0]);
495 lfunction [table, Pgenval]
496 (Llet(Strict, Pgenval, env_init,
497 mkappl(lfield cla 1, [Lvar table]),
498 lfunction [envs, Pgenval]
499 (mkappl(Lvar new_init,
500 [mkappl(Lvar env_init, [Lvar envs])]))));
501 lfield cla 2;
502 lfield cla 3],
503 Location.none)))
504 with Exit ->
505 lambda_unit
506
507 (* Rewrite a closure using builtins. Improves native code size. *)
508
509 let rec module_path = function
510 Lvar id ->
511 let s = Ident.name id in s <> "" && s.[0] >= 'A' && s.[0] <= 'Z'
512 | Lprim(Pfield _, [p], _) -> module_path p
513 | Lprim(Pgetglobal _, [], _) -> true
514 | _ -> false
515
516 let const_path local = function
517 Lvar id -> not (List.mem id local)
518 | Lconst _ -> true
519 | Lfunction {kind = Curried; body} ->
520 let fv = free_variables body in
521 List.for_all (fun x -> not (Ident.Set.mem x fv)) local
522 | p -> module_path p
523
524 let rec builtin_meths self env env2 body =
525 let const_path = const_path (env::self) in
526 let conv = function
527 (* Lvar s when List.mem s self -> "_self", [] *)
528 | p when const_path p -> "const", [p]
529 | Lprim(Parrayrefu _, [Lvar s; Lvar n], _) when List.mem s self ->
530 "var", [Lvar n]
531 | Lprim(Pfield n, [Lvar e], _) when Ident.same e env ->
532 "env", [Lvar env2; Lconst(Const_pointer n)]
533 | Lsend(Self, met, Lvar s, [], _) when List.mem s self ->
534 "meth", [met]
535 | _ -> raise Not_found
536 in
537 match body with
538 | Llet(_str, _k, s', Lvar s, body) when List.mem s self ->
539 builtin_meths (s'::self) env env2 body
540 | Lapply{ap_func = f; ap_args = [arg]} when const_path f ->
541 let s, args = conv arg in ("app_"^s, f :: args)
542 | Lapply{ap_func = f; ap_args = [arg; p]} when const_path f && const_path p ->
543 let s, args = conv arg in
544 ("app_"^s^"_const", f :: args @ [p])
545 | Lapply{ap_func = f; ap_args = [p; arg]} when const_path f && const_path p ->
546 let s, args = conv arg in
547 ("app_const_"^s, f :: p :: args)
548 | Lsend(Self, Lvar n, Lvar s, [arg], _) when List.mem s self ->
549 let s, args = conv arg in
550 ("meth_app_"^s, Lvar n :: args)
551 | Lsend(Self, met, Lvar s, [], _) when List.mem s self ->
552 ("get_meth", [met])
553 | Lsend(Public, met, arg, [], _) ->
554 let s, args = conv arg in
555 ("send_"^s, met :: args)
556 | Lsend(Cached, met, arg, [_;_], _) ->
557 let s, args = conv arg in
558 ("send_"^s, met :: args)
559 | Lfunction {kind = Curried; params = [x, _]; body} ->
560 let rec enter self = function
561 | Lprim(Parraysetu _, [Lvar s; Lvar n; Lvar x'], _)
562 when Ident.same x x' && List.mem s self ->
563 ("set_var", [Lvar n])
564 | Llet(_str, _k, s', Lvar s, body) when List.mem s self ->
565 enter (s'::self) body
566 | _ -> raise Not_found
567 in enter self body
568 | Lfunction _ -> raise Not_found
569 | _ ->
570 let s, args = conv body in ("get_"^s, args)
571
572 module M = struct
573 open CamlinternalOO
574 let builtin_meths self env env2 body =
575 let builtin, args = builtin_meths self env env2 body in
576 (* if not arr then [mkappl(oo_prim builtin, args)] else *)
577 let tag = match builtin with
578 "get_const" -> GetConst
579 | "get_var" -> GetVar
580 | "get_env" -> GetEnv
581 | "get_meth" -> GetMeth
582 | "set_var" -> SetVar
583 | "app_const" -> AppConst
584 | "app_var" -> AppVar
585 | "app_env" -> AppEnv
586 | "app_meth" -> AppMeth
587 | "app_const_const" -> AppConstConst
588 | "app_const_var" -> AppConstVar
589 | "app_const_env" -> AppConstEnv
590 | "app_const_meth" -> AppConstMeth
591 | "app_var_const" -> AppVarConst
592 | "app_env_const" -> AppEnvConst
593 | "app_meth_const" -> AppMethConst
594 | "meth_app_const" -> MethAppConst
595 | "meth_app_var" -> MethAppVar
596 | "meth_app_env" -> MethAppEnv
597 | "meth_app_meth" -> MethAppMeth
598 | "send_const" -> SendConst
599 | "send_var" -> SendVar
600 | "send_env" -> SendEnv
601 | "send_meth" -> SendMeth
602 | _ -> assert false
603 in Lconst(Const_pointer(Obj.magic tag)) :: args
604 end
605 open M
606
607
608 (*
609 Class translation.
610 Three subcases:
611 * reapplication of a known class -> transl_class_rebind
612 * class without local dependencies -> direct translation
613 * with local dependencies -> generate a stubs tree,
614 with a node for every local classes inherited
615 A class is a 4-tuple:
616 (obj_init, class_init, env_init, env)
617 obj_init: creation function (unit -> obj)
618 class_init: inheritance function (table -> env_init)
619 (one by source code)
620 env_init: parameterisation by the local environment
621 (env -> params -> obj_init)
622 (one for each combination of inherited class_init )
623 env: local environment
624 If ids=0 (immediate object), then only env_init is conserved.
625 *)
626
627 (*
628 let prerr_ids msg ids =
629 let names = List.map Ident.unique_toplevel_name ids in
630 prerr_endline (String.concat " " (msg :: names))
631 *)
632
633 let free_methods l =
634 let fv = ref Ident.Set.empty in
635 let rec free l =
636 Lambda.iter_head_constructor free l;
637 match l with
638 | Lsend(Self, Lvar meth, _, _, _) ->
639 fv := Ident.Set.add meth !fv
640 | Lsend _ -> ()
641 | Lfunction{params} ->
642 List.iter (fun (param, _) -> fv := Ident.Set.remove param !fv) params
643 | Llet(_str, _k, id, _arg, _body) ->
644 fv := Ident.Set.remove id !fv
645 | Lletrec(decl, _body) ->
646 List.iter (fun (id, _exp) -> fv := Ident.Set.remove id !fv) decl
647 | Lstaticcatch(_e1, (_,vars), _e2) ->
648 List.iter (fun (id, _) -> fv := Ident.Set.remove id !fv) vars
649 | Ltrywith(_e1, exn, _e2) ->
650 fv := Ident.Set.remove exn !fv
651 | Lfor(v, _e1, _e2, _dir, _e3) ->
652 fv := Ident.Set.remove v !fv
653 | Lassign _
654 | Lvar _ | Lconst _ | Lapply _
655 | Lprim _ | Lswitch _ | Lstringswitch _ | Lstaticraise _
656 | Lifthenelse _ | Lsequence _ | Lwhile _
657 | Levent _ | Lifused _ -> ()
658 in free l; !fv
659
660 let transl_class ids cl_id pub_meths cl vflag =
661 (* First check if it is not only a rebind *)
662 let rebind = transl_class_rebind cl vflag in
663 if rebind <> lambda_unit then rebind else
664
665 (* Prepare for heavy environment handling *)
666 let tables = Ident.create_local (Ident.name cl_id ^ "_tables") in
667 let (top_env, req) = oo_add_class tables in
668 let top = not req in
669 let cl_env, llets = build_class_lets cl in
670 let new_ids = if top then [] else Env.diff top_env cl_env in
671 let env2 = Ident.create_local "env" in
672 let meth_ids = get_class_meths cl in
673 let subst env lam i0 new_ids' =
674 let fv = free_variables lam in
675 (* prerr_ids "cl_id =" [cl_id]; prerr_ids "fv =" (Ident.Set.elements fv); *)
676 let fv = List.fold_right Ident.Set.remove !new_ids' fv in
677 (* We need to handle method ids specially, as they do not appear
678 in the typing environment (PR#3576, PR#4560) *)
679 (* very hacky: we add and remove free method ids on the fly,
680 depending on the visit order... *)
681 method_ids :=
682 Ident.Set.diff (Ident.Set.union (free_methods lam) !method_ids) meth_ids;
683 (* prerr_ids "meth_ids =" (Ident.Set.elements meth_ids);
684 prerr_ids "method_ids =" (Ident.Set.elements !method_ids); *)
685 let new_ids = List.fold_right Ident.Set.add new_ids !method_ids in
686 let fv = Ident.Set.inter fv new_ids in
687 new_ids' := !new_ids' @ Ident.Set.elements fv;
688 (* prerr_ids "new_ids' =" !new_ids'; *)
689 let i = ref (i0-1) in
690 List.fold_left
691 (fun subst id ->
692 incr i; Ident.Map.add id (lfield env !i) subst)
693 Ident.Map.empty !new_ids'
694 in
695 let new_ids_meths = ref [] in
696 let no_env_update _ _ env = env in
697 let msubst arr = function
698 Lfunction {kind = Curried; params = (self, Pgenval) :: args; body} ->
699 let env = Ident.create_local "env" in
700 let body' =
701 if new_ids = [] then body else
702 Lambda.subst no_env_update (subst env body 0 new_ids_meths) body in
703 begin try
704 (* Doesn't seem to improve size for bytecode *)
705 (* if not !Clflags.native_code then raise Not_found; *)
706 if not arr || !Clflags.debug then raise Not_found;
707 builtin_meths [self] env env2 (lfunction args body')
708 with Not_found ->
709 [lfunction ((self, Pgenval) :: args)
710 (if not (Ident.Set.mem env (free_variables body')) then body' else
711 Llet(Alias, Pgenval, env,
712 Lprim(Pfield_computed,
713 [Lvar self; Lvar env2],
714 Location.none),
715 body'))]
716 end
717 | _ -> assert false
718 in
719 let new_ids_init = ref [] in
720 let env1 = Ident.create_local "env" and env1' = Ident.create_local "env'" in
721 let copy_env self =
722 if top then lambda_unit else
723 Lifused(env2, Lprim(Psetfield_computed (Pointer, Assignment),
724 [Lvar self; Lvar env2; Lvar env1'],
725 Location.none))
726 and subst_env envs l lam =
727 if top then lam else
728 (* must be called only once! *)
729 let lam = Lambda.subst no_env_update (subst env1 lam 1 new_ids_init) lam in
730 Llet(Alias, Pgenval, env1, (if l = [] then Lvar envs else lfield envs 0),
731 Llet(Alias, Pgenval, env1',
732 (if !new_ids_init = [] then Lvar env1 else lfield env1 0),
733 lam))
734 in
735
736 (* Now we start compiling the class *)
737 let cla = Ident.create_local "class" in
738 let (inh_init, obj_init) =
739 build_object_init_0 cla [] cl copy_env subst_env top ids in
740 let inh_init' = List.rev inh_init in
741 let (inh_init', cl_init) =
742 build_class_init cla true ([],[]) inh_init' obj_init msubst top cl
743 in
744 assert (inh_init' = []);
745 let table = Ident.create_local "table"
746 and class_init = Ident.create_local (Ident.name cl_id ^ "_init")
747 and env_init = Ident.create_local "env_init"
748 and obj_init = Ident.create_local "obj_init" in
749 let pub_meths =
750 List.sort
751 (fun s s' -> compare (Btype.hash_variant s) (Btype.hash_variant s'))
752 pub_meths in
753 let tags = List.map Btype.hash_variant pub_meths in
754 let rev_map = List.combine tags pub_meths in
755 List.iter2
756 (fun tag name ->
757 let name' = List.assoc tag rev_map in
758 if name' <> name then raise(Error(cl.cl_loc, Tags(name, name'))))
759 tags pub_meths;
760 let ltable table lam =
761 Llet(Strict, Pgenval, table,
762 mkappl (oo_prim "create_table", [transl_meth_list pub_meths]), lam)
763 and ldirect obj_init =
764 Llet(Strict, Pgenval, obj_init, cl_init,
765 Lsequence(mkappl (oo_prim "init_class", [Lvar cla]),
766 mkappl (Lvar obj_init, [lambda_unit])))
767 in
768 (* Simplest case: an object defined at toplevel (ids=[]) *)
769 if top && ids = [] then llets (ltable cla (ldirect obj_init)) else
770
771 let concrete = (vflag = Concrete)
772 and lclass lam =
773 let cl_init = llets (Lfunction{kind = Curried;
774 attr = default_function_attribute;
775 loc = Location.none;
776 return = Pgenval;
777 params = [cla, Pgenval]; body = cl_init}) in
778 Llet(Strict, Pgenval, class_init, cl_init, lam (free_variables cl_init))
779 and lbody fv =
780 if List.for_all (fun id -> not (Ident.Set.mem id fv)) ids then
781 mkappl (oo_prim "make_class",[transl_meth_list pub_meths;
782 Lvar class_init])
783 else
784 ltable table (
785 Llet(
786 Strict, Pgenval, env_init, mkappl (Lvar class_init, [Lvar table]),
787 Lsequence(
788 mkappl (oo_prim "init_class", [Lvar table]),
789 Lprim(Pmakeblock(0, Immutable, None),
790 [mkappl (Lvar env_init, [lambda_unit]);
791 Lvar class_init; Lvar env_init; lambda_unit],
792 Location.none))))
793 and lbody_virt lenvs =
794 Lprim(Pmakeblock(0, Immutable, None),
795 [lambda_unit; Lfunction{kind = Curried;
796 attr = default_function_attribute;
797 loc = Location.none;
798 return = Pgenval;
799 params = [cla, Pgenval]; body = cl_init};
800 lambda_unit; lenvs],
801 Location.none)
802 in
803 (* Still easy: a class defined at toplevel *)
804 if top && concrete then lclass lbody else
805 if top then llets (lbody_virt lambda_unit) else
806
807 (* Now for the hard stuff: prepare for table caching *)
808 let envs = Ident.create_local "envs"
809 and cached = Ident.create_local "cached" in
810 let lenvs =
811 if !new_ids_meths = [] && !new_ids_init = [] && inh_init = []
812 then lambda_unit
813 else Lvar envs in
814 let lenv =
815 let menv =
816 if !new_ids_meths = [] then lambda_unit else
817 Lprim(Pmakeblock(0, Immutable, None),
818 List.map (fun id -> Lvar id) !new_ids_meths,
819 Location.none) in
820 if !new_ids_init = [] then menv else
821 Lprim(Pmakeblock(0, Immutable, None),
822 menv :: List.map (fun id -> Lvar id) !new_ids_init,
823 Location.none)
824 and linh_envs =
825 List.map
826 (fun (_, path_lam, _) -> Lprim(Pfield 3, [path_lam], Location.none))
827 (List.rev inh_init)
828 in
829 let make_envs lam =
830 Llet(StrictOpt, Pgenval, envs,
831 (if linh_envs = [] then lenv else
832 Lprim(Pmakeblock(0, Immutable, None),
833 lenv :: linh_envs, Location.none)),
834 lam)
835 and def_ids cla lam =
836 Llet(StrictOpt, Pgenval, env2,
837 mkappl (oo_prim "new_variable", [Lvar cla; transl_label ""]),
838 lam)
839 in
840 let inh_paths =
841 List.filter
842 (fun (path, _, _) -> List.mem (Path.head path) new_ids) inh_init
843 in
844 let inh_keys =
845 List.map
846 (fun (_, path_lam, _) -> Lprim(Pfield 1, [path_lam], Location.none))
847 inh_paths
848 in
849 let lclass lam =
850 Llet(Strict, Pgenval, class_init,
851 Lfunction{kind = Curried; params = [cla, Pgenval];
852 return = Pgenval;
853 attr = default_function_attribute;
854 loc = Location.none;
855 body = def_ids cla cl_init}, lam)
856 and lcache lam =
857 if inh_keys = [] then Llet(Alias, Pgenval, cached, Lvar tables, lam) else
858 Llet(Strict, Pgenval, cached,
859 mkappl (oo_prim "lookup_tables",
860 [Lvar tables; Lprim(Pmakeblock(0, Immutable, None),
861 inh_keys, Location.none)]),
862 lam)
863 and lset cached i lam =
864 Lprim(Psetfield(i, Pointer, Assignment),
865 [Lvar cached; lam], Location.none)
866 in
867 let ldirect () =
868 ltable cla
869 (Llet(Strict, Pgenval, env_init, def_ids cla cl_init,
870 Lsequence(mkappl (oo_prim "init_class", [Lvar cla]),
871 lset cached 0 (Lvar env_init))))
872 and lclass_virt () =
873 lset cached 0
874 (Lfunction
875 {
876 kind = Curried;
877 attr = default_function_attribute;
878 loc = Location.none;
879 return = Pgenval;
880 params = [cla, Pgenval];
881 body = def_ids cla cl_init;
882 }
883 )
884 in
885 let lupdate_cache =
886 if ids = [] then ldirect () else
887 if not concrete then lclass_virt () else
888 lclass (
889 mkappl (oo_prim "make_class_store",
890 [transl_meth_list pub_meths;
891 Lvar class_init; Lvar cached])) in
892 let lcheck_cache =
893 if !Clflags.native_code && !Clflags.afl_instrument then
894 (* When afl-fuzz instrumentation is enabled, ignore the cache
895 so that the program's behaviour does not change between runs *)
896 lupdate_cache
897 else
898 Lifthenelse(lfield cached 0, lambda_unit, lupdate_cache) in
899 llets (
900 lcache (
901 Lsequence(lcheck_cache,
902 make_envs (
903 if ids = [] then mkappl (lfield cached 0, [lenvs]) else
904 Lprim(Pmakeblock(0, Immutable, None),
905 (if concrete then
906 [mkappl (lfield cached 0, [lenvs]);
907 lfield cached 1;
908 lfield cached 0;
909 lenvs]
910 else [lambda_unit; lfield cached 0; lambda_unit; lenvs]),
911 Location.none
912 )))))
913
914 (* Wrapper for class compilation *)
915 (*
916 let cl_id = ci.ci_id_class in
917 (* TODO: cl_id is used somewhere else as typesharp ? *)
918 let _arity = List.length ci.ci_params in
919 let pub_meths = m in
920 let cl = ci.ci_expr in
921 let vflag = vf in
922 *)
923
924 let transl_class ids id pub_meths cl vf =
925 oo_wrap cl.cl_env false (transl_class ids id pub_meths cl) vf
926
927 let () =
928 transl_object := (fun id meths cl -> transl_class [] id meths cl Concrete)
929
930 (* Error report *)
931
932 open Format
933
934 let report_error ppf = function
935 | Tags (lab1, lab2) ->
936 fprintf ppf "Method labels `%s' and `%s' are incompatible.@ %s"
937 lab1 lab2 "Change one of them."
938
939 let () =
940 Location.register_error_of_exn
941 (function
942 | Error (loc, err) ->
943 Some (Location.error_of_printer ~loc report_error err)
944 | _ ->
945 None
946 )
947