anil.recoil.org
My working unpac repository
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(*
17 # Translation of class and object expressions
18
19 ## Objects
20
21 ### Memory layout
22
23 Objects are represented in memory using two layers:
24 - The outer layer is a block with tag [Obj.object_tag].
25 It has a first field pointing to the inner layer (the methods),
26 a second field acting as a unique identifier to allow
27 polymorphic comparison, and the rest of the block contains
28 the values of the instance variables, class parameters, and
29 other values that can vary between two objects of the same class.
30
31 - The inner layer is a regular block (with tag zero). It contains
32 all values that are shared between all objects of the same class,
33 which means mostly methods. The first field corresponds to the number of
34 public methods, the second field is a mask used for optimising method
35 access, the following fields are alternating between the method closures
36 and the hash of their name (sorted in increasing hash order).
37 Additional fields are used for private methods.
38
39 +-------+------+-------+-------+-----+-------+-------+-----------+
40 | n_pub | mask | met_1 | tag_1 | ... | met_n | tag_n | other ... |
41 +-------+------+-------+-------+-----+-------+-------+-----------+
42
43 ### Primitives
44
45 Method access is compiled in one of three possible ways:
46 - Generic method access (outside a class, or to an object that is not
47 self or an ancestor) uses dynamic lookup. A dichotomic search in
48 the part of the method array that stores public methods finds
49 the expected closure and calls it on the current object.
50 In most cases, a fast path also exists: each method access in the
51 source code has an associated cache location that stores the offset
52 of the last method called at this point in its method array.
53 Before the dichotomic search, the last stored offset (clamped
54 to the actual size of the method array using the mask) is checked,
55 and if the tag matches the associated closure is called directly.
56 - Method access through the self object inside a class:
57 the (runtime) index of the method inside the method array
58 has been computed at class creation time, so the method is fetched
59 from the block through a dynamic block load (like an array load).
60 - Accessing the method of an ancestor inside a class (ancestors are
61 variables bound by [inherit ... as ancestor] constructions):
62 at class creation time, the closure of the ancestor method is bound
63 to a variable, and the method call just calls this function without
64 any (further) dynamic lookup.
65
66 Instance variable access (getting and setting) also computes offsets
67 at class initialisation time, with those offsets used to index directly
68 in the outer layer of the object.
69
70 Functional object copy [ {< ... >} ] copies the outer layer, resets the
71 unique ID, and performs the required instance variable updates.
72
73 There are no other object primitives (objects cannot be allocated
74 in the IR directly, they are allocated in [CamlinternalOO])
75
76 ## Classes
77
78 Classes are stored as module fields. The runtime value that represents
79 classes is used in two contexts:
80
81 - When using the [new] construction, to generate an object from a class.
82 - When referencing a class inside another class (either through
83 inheritance or other class expressions).
84
85 This is done by storing classes as blocks where the first field
86 is used to generate objects, and the second field is used to derive
87 classes (in a general sense, not only for inheritance).
88 In practice classes also contain one other field, which is used to
89 implement some optimisations in the main compiler (to ensure that each
90 class only runs its initialisation code once in the whole program, even
91 if its definition is in a context that is expected to be run several
92 times like a functor).
93 So the block layout is the following:
94 - A field named [obj_init] that is used for creating objects
95 - A field named [class_init] that is used for deriving classes
96 - A field named [env] containing values for all the variables
97 captured by [Translobj.oo_wrap] calls.
98
99 The module [CamlinternalOO] also defines a type [table] that represents
100 class layouts. Such values are not stored in the class block directly,
101 but the [obj_init] field captures the table for the class and [class_init]
102 manipulates such tables.
103
104 ### The [obj_init] field
105
106 As described earlier, each object contains an inner layer that is computed
107 only once at class initialisation time; it seems natural to store this
108 block in the runtime value of the class (this block is one of the fields of
109 the [CamlinternalOO.table] type). However, given that creating an
110 object also involves setting up the instance variables and running the
111 initialisers, in practice the class only exports a function that creates
112 objects, and the table is captured in this function's closure along with
113 any value necessary to properly initialise the object.
114 Classes can have parameters, so in practice this object creation function
115 takes a first unit parameter (to ensure that it is always a function)
116 and returns a regular OCaml value that is either an object (if the class
117 doesn't have parameters) or a function which, given values
118 for the class parameters, will return an object.
119
120 Here is the type of the [obj_init] function for a class which type is
121 [p1 -> ... -> pn -> object method m1 : t1 ... method mn : tn end]:
122 [unit -> p1 -> ... -> pn -> < m1 : t1; ... mn : tn >]
123 (If the class has instance variables or initialisers, they are not
124 reflected in the type of [obj_init]).
125
126 ### The [class_init] field
127
128 This field is used in two cases:
129 - When a class is defined in terms of another class, for instance as an
130 alias, a partial application, or some other kind of wrapper.
131 - When a class structure (i.e. the [object ... end] syntactic construction)
132 contains inheritance fields (e.g. [inherit cl as super]).
133
134 In both cases, we only have access to the other class' public type at
135 compile time, but we must still make sure all of the private fields
136 are setup correctly, in a way that is compatible with the current
137 class.
138
139 This is where tables come into play: the [class_init] field is a function
140 taking a table as parameter, updates it in-place, and returns a function
141 that is very similar to the [obj_init] function, except that instead of
142 taking [unit] as its first parameter and returning an object, it takes
143 a partially initialised object, and updates the parts of it that are
144 relevant for the corresponding class. It also takes the [env] field as
145 a parameter, so that different instances of the class can share the
146 same [class_init] function.
147
148 Thus, the type of [class_init] is:
149 [table -> env -> Obj.t -> p1 -> ... -> pn -> unit]
150
151 ### The [env] field
152
153 The [env] field is a structure similar to a function's closure, storing
154 the value of free variables of the class expression. The actual
155 representation is a bit complex and not very important.
156
157 ### Compilation scheme
158
159 The algorithm implemented below aims at sharing code as much as possible
160 between the various similar parts of the class.
161
162 - The code of the [obj_init] function is very similar to the code of
163 the function returned by [class_init]. The main difference is that
164 [obj_init] starts from scratch, allocating then initialising the object,
165 while inside [class_init] we want to run initialisation code on an already
166 allocated object (that we don't need to return).
167 So in practice we will build a single function that, depending on the value
168 of its first parameter, will either do the allocation and return the object
169 (if the parameter is the integer constant 0), or assume the parameter is
170 an already allocated and update it.
171 The body of this function is returned by [build_object_init].
172 - The table for the current class (that [obj_init] will read from) is
173 computed by allocating a basic table, then passing it to [class_init],
174 and finally calling [CamlinternalOO.init_class] on it.
175 This means that all the code for setting up the class (computing instance
176 variable indices, calling inherited class initialisers, and so on) is only
177 generated once, in the [class_init] function.
178 After building [obj_init], [build_class_init] wraps it with the class
179 initialization code to build the [class_init] function.
180
181 That's all for the high-level algorithm; the rest will be detailed close to
182 the corresponding code.
183
184*)
185
186open Asttypes
187open Types
188open Typedtree
189open Lambda
190open Translobj
191open Translcore
192open Debuginfo.Scoped_location
193
194(* XXX Rajouter des evenements... | Add more events... *)
195
196type error = Tags of label * label
197
198exception Error of Location.t * error
199
200let lfunction params body =
201 if params = [] then body else
202 match body with
203 | Lfunction {kind = Curried; params = params'; body = body'; attr; loc}
204 when attr.may_fuse_arity &&
205 List.length params + List.length params' <= Lambda.max_arity() ->
206 lfunction ~kind:Curried ~params:(params @ params')
207 ~return:Pgenval
208 ~body:body'
209 ~attr
210 ~loc
211 | _ ->
212 lfunction ~kind:Curried ~params ~return:Pgenval
213 ~body
214 ~attr:default_function_attribute
215 ~loc:Loc_unknown
216
217let lapply ap =
218 match ap.ap_func with
219 Lapply ap' ->
220 Lapply {ap with ap_func = ap'.ap_func; ap_args = ap'.ap_args @ ap.ap_args}
221 | _ ->
222 Lapply ap
223
224let mkappl (func, args) =
225 Lapply {
226 ap_loc=Loc_unknown;
227 ap_func=func;
228 ap_args=args;
229 ap_tailcall=Default_tailcall;
230 ap_inlined=Default_inline;
231 ap_specialised=Default_specialise;
232 }
233
234let lsequence l1 l2 =
235 if l2 = lambda_unit then l1 else Lsequence(l1, l2)
236
237let lfield v i = Lprim(Pfield (i, Pointer, Mutable),
238 [Lvar v], Loc_unknown)
239
240let transl_label l = share (Const_immstring l)
241
242let transl_meth_list lst =
243 if lst = [] then Lconst (const_int 0) else
244 share (Const_block
245 (0, List.map (fun lab -> Const_immstring lab) lst))
246
247let set_inst_var ~scopes obj id expr =
248 Lprim(Psetfield_computed (Typeopt.maybe_pointer expr, Assignment),
249 [Lvar obj; Lvar id; transl_exp ~scopes expr], Loc_unknown)
250
251let transl_val tbl create name =
252 mkappl (oo_prim (if create then "new_variable" else "get_variable"),
253 [Lvar tbl; transl_label name])
254
255let transl_vals tbl create strict vals rem =
256 List.fold_right
257 (fun (name, id) rem ->
258 Llet(strict, Pgenval, id, transl_val tbl create name, rem))
259 vals rem
260
261let meths_super tbl meths inh_meths =
262 List.fold_right
263 (fun (nm, id) rem ->
264 try
265 (nm, id,
266 mkappl(oo_prim "get_method", [Lvar tbl; Lvar (Meths.find nm meths)]))
267 :: rem
268 with Not_found -> rem)
269 inh_meths []
270
271(*
272[build_class_init] has two parameters ([cstr] and [super]) that are set when
273translating the expression of a class that will be inherited in an outer class.
274
275They could be replaced with the following type:
276
277```
278type inheritance_status =
279 | Normal (** Not under an [inherit] construct *)
280 | Inheriting of {
281 must_narrow : bool;
282 (** [false] if we already went through a call to [narrow] *)
283 method_getters : (Ident.t * lambda) list;
284 (** Ancestor methods are accessed through identifiers.
285 These identifiers are bound at class initialisation time,
286 by fetching the actual closures from the table just
287 after setting up the inherited class. *)
288 instance_vars : (string * Ident.t) list;
289 (** Inherited instance variables need to have their index bound
290 in the scope of the child class *)
291 }
292```
293
294[cstr] is the negation of [must_narrow], and [super] is the pair
295[(instance_vars, method_getters)].
296*)
297
298let bind_super tbl (vals, meths) cl_init =
299 transl_vals tbl false StrictOpt vals
300 (List.fold_right (fun (_nm, id, def) rem ->
301 Llet(StrictOpt, Pgenval, id, def, rem))
302 meths cl_init)
303
304let create_object cl obj init =
305 let obj' = Ident.create_local "self" in
306 let (inh_init, obj_init, has_init) = init obj' in
307 if obj_init = lambda_unit then
308 (inh_init,
309 mkappl (oo_prim (if has_init then "create_object_and_run_initializers"
310 else "create_object_opt"),
311 [obj; Lvar cl]))
312 else begin
313 (inh_init,
314 Llet(Strict, Pgenval, obj',
315 mkappl (oo_prim "create_object_opt", [obj; Lvar cl]),
316 Lsequence(obj_init,
317 if not has_init then Lvar obj' else
318 mkappl (oo_prim "run_initializers_opt",
319 [obj; Lvar obj'; Lvar cl]))))
320 end
321
322let name_pattern default p =
323 match p.pat_desc with
324 | Tpat_var (id, _, _) -> id
325 | Tpat_alias(_, id, _, _, _) -> id
326 | _ -> Ident.create_local default
327
328(*
329 [build_object_init] returns an expression that creates and initialises new
330 objects. If the class takes parameters, it is a function that, given values
331 for the parameters, performs the initialisations and (if needed) object
332 creation.
333 The [obj] expression will be bound to either the integer 0, in which case
334 [obj_init] must allocate the object and return it, or to an already allocated
335 object, in which case [obj_init] will initialize the relevant parts of it
336 through side-effects. In the case of an immediate object it is always 0.
337 Parameters:
338 - [scopes] corresponds to the location scopes (as in the rest of the
339 translation code)
340 - [cl_table] is the variable to which the table for the current class is
341 bound
342 - [obj] is the parameter of the [obj_init] function we want to create.
343 As explained above at runtime it might point to either an already allocated
344 object, when inheriting, or a dummy zero value, when calling [new].
345 - [params] stores the anonymous instance variables associated with all
346 variables that occur inside the class definition but outside the
347 [object ... end] structure: class parameters and class let bindings.
348 The definition is always the identifier corresponding to the original
349 variable.
350 - [inh_init] accumulates data about the class identifiers encountered, and is
351 returned at the end to be reused in [build_class_init].
352 - [cl] is the class we're compiling *)
353
354let rec build_object_init ~scopes cl_table obj params inh_init obj_init cl =
355 match cl.cl_desc with
356 Tcl_ident (path, _, _) ->
357 (* The object initialiser for the class in [path], specialised
358 to the class being defined *)
359 let obj_init = Ident.create_local "obj_init" in
360 let envs, inh_init = inh_init in
361 let env =
362 match envs with None -> []
363 | Some envs ->
364 [Lprim(Pfield (List.length inh_init + 1, Pointer, Mutable),
365 [Lvar envs],
366 Loc_unknown)]
367 in
368 let loc = of_location ~scopes cl.cl_loc in
369 let path_lam = transl_class_path loc cl.cl_env path in
370 (* Note: we don't need to bind [params] here, as they are
371 only used in structures. Outside structures (in class lets or
372 applications) we use the regular identifiers. *)
373 ((envs, (path, path_lam, obj_init) :: inh_init),
374 mkappl(Lvar obj_init, env @ [obj]))
375 | Tcl_structure str ->
376 (* Initialising a concrete class structure *)
377 create_object cl_table obj (fun obj ->
378 (* [obj] will be bound to the allocated object,
379 unlike the original [obj] which might be zero if called directly
380 from an object creation expression. *)
381 let (inh_init, obj_init, has_init) =
382 List.fold_right
383 (fun field (inh_init, obj_init, has_init) ->
384 match field.cf_desc with
385 Tcf_inherit (_, cl, _, _, _) ->
386 let (inh_init, obj_init') =
387 (* Reset [params]. The current ones will be bound
388 outside the structure. *)
389 build_object_init ~scopes cl_table (Lvar obj) [] inh_init
390 (fun _ -> lambda_unit) cl
391 in
392 (* Since [obj] is bound to a concrete object,
393 only the side-effects of [obj_init'] are relevant. *)
394 (inh_init, lsequence obj_init' obj_init, true)
395 | Tcf_val (_, _, id, Tcfk_concrete (_, exp), _) ->
396 (inh_init,
397 lsequence (set_inst_var ~scopes obj id exp) obj_init,
398 has_init)
399 | Tcf_method _ | Tcf_val _ | Tcf_constraint _ | Tcf_attribute _->
400 (inh_init, obj_init, has_init)
401 | Tcf_initializer _ ->
402 (inh_init, obj_init, true)
403 )
404 str.cstr_fields
405 (inh_init, obj_init obj, false)
406 in
407 (* Set the instance variables associated to the class parameters and
408 let bindings to their expected value. *)
409 (inh_init,
410 List.fold_right
411 (fun (id, expr) rem ->
412 lsequence (Lifused (id, set_inst_var ~scopes obj id expr)) rem)
413 params obj_init,
414 has_init))
415 | Tcl_fun (_, pat, vals, cl, partial) ->
416 let (inh_init, obj_init) =
417 (* [vals] maps all pattern variables to idents for use inside methods *)
418 build_object_init ~scopes cl_table obj (vals @ params)
419 inh_init obj_init cl
420 in
421 (inh_init,
422 let build params rem =
423 let param = name_pattern "param" pat in
424 Lambda.lfunction
425 ~kind:Curried ~params:((param, Pgenval)::params)
426 ~return:Pgenval
427 ~attr:default_function_attribute
428 ~loc:(of_location ~scopes pat.pat_loc)
429 ~body:(Matching.for_function ~scopes pat.pat_loc
430 None (Lvar param) [pat, rem] partial)
431 in
432 begin match obj_init with
433 Lfunction {kind = Curried; params; body = rem} -> build params rem
434 | rem -> build [] rem
435 end)
436 | Tcl_apply (cl, oexprs) ->
437 let (inh_init, obj_init) =
438 build_object_init ~scopes cl_table obj params inh_init obj_init cl
439 in
440 (inh_init, transl_apply ~scopes obj_init oexprs Loc_unknown)
441 | Tcl_let (rec_flag, defs, vals, cl) ->
442 (* See comment on the [Tcl_fun] case for the meaning of [vals] *)
443 let (inh_init, obj_init) =
444 build_object_init ~scopes cl_table obj (vals @ params)
445 inh_init obj_init cl
446 in
447 (inh_init, Translcore.transl_let ~scopes rec_flag defs obj_init)
448 | Tcl_open (_, cl)
449 (* Class local opens are restricted to paths only, so no code is generated
450 *)
451 | Tcl_constraint (cl, _, _, _, _) ->
452 build_object_init ~scopes cl_table obj params inh_init obj_init cl
453
454(* The manual specifies that toplevel lets *must* be evaluated outside of the
455 class. This piece of code makes sure we skip them. *)
456let rec build_object_init_0
457 ~scopes cl_table params cl copy_env subst_env top ids =
458 match cl.cl_desc with
459 Tcl_let (_rec_flag, _defs, vals, cl) ->
460 build_object_init_0
461 ~scopes cl_table (vals@params) cl copy_env subst_env top ids
462 | Tcl_open (_descr, cl) ->
463 build_object_init_0
464 ~scopes cl_table params cl copy_env subst_env top ids
465 | _ ->
466 let self = Ident.create_local "self" in
467 let env = Ident.create_local "env" in
468 let obj = if ids = [] then lambda_unit else Lvar self in
469 let envs = if top then None else Some env in
470 let ((_,inh_init), obj_init) =
471 build_object_init ~scopes cl_table obj params (envs,[]) copy_env cl in
472 let obj_init =
473 if ids = [] then obj_init else lfunction [self, Pgenval] obj_init in
474 (inh_init, lfunction [env, Pgenval] (subst_env env inh_init obj_init))
475
476
477let bind_method tbl lab id cl_init =
478 Llet(Strict, Pgenval, id, mkappl (oo_prim "get_method_label",
479 [Lvar tbl; transl_label lab]),
480 cl_init)
481
482let bind_methods tbl meths vals cl_init =
483 let methl = Meths.fold (fun lab id tl -> (lab,id) :: tl) meths [] in
484 let len = List.length methl and nvals = List.length vals in
485 if len < 2 && nvals = 0 then Meths.fold (bind_method tbl) meths cl_init else
486 if len = 0 && nvals < 2 then transl_vals tbl true Strict vals cl_init else
487 let ids = Ident.create_local "ids" in
488 let i = ref (len + nvals) in
489 let getter, names =
490 if nvals = 0 then "get_method_labels", [] else
491 "new_methods_variables", [transl_meth_list (List.map fst vals)]
492 in
493 Llet(Strict, Pgenval, ids,
494 mkappl (oo_prim getter,
495 [Lvar tbl; transl_meth_list (List.map fst methl)] @ names),
496 List.fold_right
497 (fun (_lab,id) lam -> decr i; Llet(StrictOpt, Pgenval, id,
498 lfield ids !i, lam))
499 (methl @ vals) cl_init)
500
501let output_methods tbl methods lam =
502 match methods with
503 [] -> lam
504 | [lab; code] ->
505 lsequence (mkappl(oo_prim "set_method", [Lvar tbl; lab; code])) lam
506 | _ ->
507 lsequence (mkappl(oo_prim "set_methods",
508 [Lvar tbl; Lprim(Pmakeblock(0,Immutable,None),
509 methods, Loc_unknown)]))
510 lam
511
512let rec ignore_cstrs cl =
513 match cl.cl_desc with
514 Tcl_constraint (cl, _, _, _, _) -> ignore_cstrs cl
515 | Tcl_apply (cl, _) -> ignore_cstrs cl
516 | _ -> cl
517
518let rec index a = function
519 [] -> raise Not_found
520 | b :: l ->
521 if b = a then 0 else 1 + index a l
522
523let bind_id_as_val (id, _) = ("", id)
524
525(** Build the class initialisation code.
526 Parameters:
527 - [scopes] corresponds to the location scopes (as in the rest of the
528 translation code)
529 - [cla] is the variable to which the table for the current class is bound
530 - [cstr] is [true] when called from outside, but [false] when called
531 from an [inherit] field. Narrowing is necessary during inheritance to
532 prevent clashes between methods/variables in the child class and private
533 methods/variables in the parent.
534 - [super] stores, if we're building an inherited class, the variables and
535 methods exposed to the child. The variables need to have their associated
536 index exposed, and methods have to be bound in case the child refers to
537 them through the ancestor variables.
538 - [inh_init] is the sequence of inheritance paths computed during
539 [build_object_init].
540 - [cl_init] is the expression we're building.
541 - [msubst] replaces methods with builtin methods when possible.
542 - [top] is [false] if the current class is under [Translobj.oo_wrap].
543 - [cl] is the class we're compiling *)
544let rec build_class_init ~scopes cla cstr super inh_init cl_init msubst top cl =
545 match cl.cl_desc with
546 | Tcl_ident _ ->
547 begin match inh_init with
548 | (_, path_lam, obj_init)::inh_init ->
549 (inh_init,
550 Llet (Strict, Pgenval, obj_init,
551 (* Load the [class_init] field of the class,
552 and apply it to our current table and the class' environment.
553 This gets us the object initialiser. *)
554 mkappl(Lprim(Pfield (1, Pointer, Mutable),
555 [path_lam], Loc_unknown), Lvar cla ::
556 if top then [Lprim(Pfield (2, Pointer, Mutable),
557 [path_lam], Loc_unknown)]
558 else []),
559 (* The methods and variables for this class are fully registered
560 in the table. If we are in an inheritance context, we can now
561 bind everything. *)
562 bind_super cla super cl_init))
563 | _ ->
564 assert false
565 end
566 | Tcl_structure str ->
567 let cl_init = bind_super cla super cl_init in
568 let (inh_init, cl_init, methods, values) =
569 List.fold_right
570 (fun field (inh_init, cl_init, methods, values) ->
571 match field.cf_desc with
572 Tcf_inherit (_, cl, _, vals, meths) ->
573 let cl_init = output_methods cla methods cl_init in
574 let inh_init, cl_init =
575 (* Build the initialisation code for the inherited class,
576 plus its wrappers.
577 Make sure the wrappers bind the inherited methods
578 and variables. *)
579 build_class_init ~scopes cla false
580 (vals, meths_super cla str.cstr_meths meths)
581 inh_init cl_init msubst top cl in
582 (inh_init, cl_init, [], values)
583 | Tcf_val (name, _, id, _, over) ->
584 (* If this is an override, the variable is the same as
585 the one from the earlier definition, and must not be
586 bound again. *)
587 let values =
588 if over then values else (name.txt, id) :: values
589 in
590 (inh_init, cl_init, methods, values)
591 | Tcf_method (_, _, Tcfk_virtual _)
592 | Tcf_constraint _
593 ->
594 (inh_init, cl_init, methods, values)
595 | Tcf_method (name, _, Tcfk_concrete (_, exp)) ->
596 let scopes = enter_method_definition ~scopes name.txt in
597 let met_code =
598 msubst true (transl_scoped_exp ~scopes exp) in
599 let met_code =
600 if !Clflags.native_code && List.length met_code = 1 then
601 (* Force correct naming of method for profiles *)
602 let met = Ident.create_local ("method_" ^ name.txt) in
603 [Llet(Strict, Pgenval, met, List.hd met_code, Lvar met)]
604 else met_code
605 in
606 (inh_init, cl_init,
607 Lvar(Meths.find name.txt str.cstr_meths) :: met_code @ methods,
608 values)
609 | Tcf_initializer exp ->
610 (inh_init,
611 Lsequence(mkappl (oo_prim "add_initializer",
612 Lvar cla :: msubst false
613 (transl_exp ~scopes exp)),
614 cl_init),
615 methods, values)
616 | Tcf_attribute _ ->
617 (inh_init, cl_init, methods, values))
618 str.cstr_fields
619 (inh_init, cl_init, [], [])
620 in
621 (* In order of execution at runtime:
622 - Bind the method and variable indices for the current class
623 ([bind_methods])
624 - Run the code for setting up the individual fields ([cl_init], plus
625 [output_methods] for the remaining unset methods)
626 - If we are in an inheritance context, bind the inherited variables
627 and methods for use in the child ([bind_super] at the top of this
628 branch) *)
629 let cl_init = output_methods cla methods cl_init in
630 (inh_init, bind_methods cla str.cstr_meths values cl_init)
631 | Tcl_fun (_, _pat, vals, cl, _) ->
632 let (inh_init, cl_init) =
633 build_class_init ~scopes cla cstr super inh_init cl_init msubst top cl
634 in
635 (* Create anonymous instance variables and define them in the table *)
636 let vals = List.map bind_id_as_val vals in
637 (inh_init, transl_vals cla true StrictOpt vals cl_init)
638 | Tcl_apply (cl, _exprs) ->
639 build_class_init ~scopes cla cstr super inh_init cl_init msubst top cl
640 | Tcl_let (_rec_flag, _defs, vals, cl) ->
641 let (inh_init, cl_init) =
642 build_class_init ~scopes cla cstr super inh_init cl_init msubst top cl
643 in
644 (* Create anonymous instance variables and define them in the table *)
645 let vals = List.map bind_id_as_val vals in
646 (inh_init, transl_vals cla true StrictOpt vals cl_init)
647 | Tcl_constraint (cl, _, vals, meths, concr_meths) ->
648 let virt_meths =
649 List.filter (fun lab -> not (MethSet.mem lab concr_meths)) meths in
650 let concr_meths = MethSet.elements concr_meths in
651 let narrow_args =
652 [Lvar cla;
653 transl_meth_list vals;
654 transl_meth_list virt_meths;
655 transl_meth_list concr_meths] in
656 let cl = ignore_cstrs cl in
657 begin match cl.cl_desc, inh_init with
658 | Tcl_ident (path, _, _), (path', path_lam, obj_init)::inh_init ->
659 assert (Path.same path path');
660 let inh = Ident.create_local "inh"
661 and ofs = List.length vals + 1
662 and valids, methids = super in
663 let cl_init =
664 List.fold_left
665 (fun init (nm, id, _) ->
666 Llet(StrictOpt, Pgenval, id,
667 lfield inh (index nm concr_meths + ofs),
668 init))
669 cl_init methids in
670 let cl_init =
671 List.fold_left
672 (fun init (nm, id) ->
673 Llet(StrictOpt, Pgenval, id,
674 lfield inh (index nm vals + 1), init))
675 cl_init valids in
676 (inh_init,
677 Llet (Strict, Pgenval, inh,
678 mkappl(oo_prim "inherits", narrow_args @
679 [path_lam;
680 Lconst(const_int (if top then 1 else 0))]),
681 Llet(StrictOpt, Pgenval, obj_init, lfield inh 0, cl_init)))
682 | _ ->
683 let core cl_init =
684 build_class_init
685 ~scopes cla true super inh_init cl_init msubst top cl
686 in
687 (* Skip narrowing if we're not directly under [inherit] *)
688 if cstr then core cl_init else
689 let (inh_init, cl_init) =
690 core (Lsequence (mkappl (oo_prim "widen", [Lvar cla]), cl_init))
691 in
692 (inh_init,
693 Lsequence(mkappl (oo_prim "narrow", narrow_args),
694 cl_init))
695 end
696 | Tcl_open (_, cl) ->
697 build_class_init ~scopes cla cstr super inh_init cl_init msubst top cl
698
699let rec build_class_lets ~scopes cl =
700 match cl.cl_desc with
701 Tcl_let (rec_flag, defs, _vals, cl') ->
702 let env, wrap = build_class_lets ~scopes cl' in
703 (env, fun lam_and_kind ->
704 let lam, rkind = wrap lam_and_kind in
705 Translcore.transl_let ~scopes rec_flag defs lam, rkind)
706 | Tcl_open (open_descr, cl) ->
707 (* Failsafe to ensure we get a compilation error if arbitrary
708 module expressions become allowed *)
709 let _ : Path.t * Longident.t loc = open_descr.open_expr in
710 build_class_lets ~scopes cl
711 | _ ->
712 (cl.cl_env, fun lam_and_kind -> lam_and_kind)
713
714let rec get_class_meths cl =
715 match cl.cl_desc with
716 Tcl_structure cl ->
717 Meths.fold (fun _ -> Ident.Set.add) cl.cstr_meths Ident.Set.empty
718 | Tcl_ident _ -> Ident.Set.empty
719 | Tcl_fun (_, _, _, cl, _)
720 | Tcl_let (_, _, _, cl)
721 | Tcl_apply (cl, _)
722 | Tcl_open (_, cl)
723 | Tcl_constraint (cl, _, _, _, _) -> get_class_meths cl
724
725(*
726 XXX Il devrait etre peu couteux d'ecrire des classes :
727 | Writing classes should be cheap
728 class c x y = d e f
729*)
730let rec transl_class_rebind ~scopes obj_init cl vf =
731 match cl.cl_desc with
732 Tcl_ident (path, _, _) ->
733 if vf = Concrete then begin
734 try if (Env.find_class path cl.cl_env).cty_new = None then raise Exit
735 with Not_found -> raise Exit
736 end;
737 let cl_loc = of_location ~scopes cl.cl_loc in
738 let path_lam = transl_class_path cl_loc cl.cl_env path in
739 (path, path_lam, obj_init)
740 | Tcl_fun (_, pat, _, cl, partial) ->
741 let path, path_lam, obj_init =
742 transl_class_rebind ~scopes obj_init cl vf in
743 let build params rem =
744 let param = name_pattern "param" pat in
745 Lambda.lfunction
746 ~kind:Curried ~params:((param, Pgenval)::params)
747 ~return:Pgenval
748 ~attr:default_function_attribute
749 ~loc:(of_location ~scopes pat.pat_loc)
750 ~body:(Matching.for_function ~scopes pat.pat_loc
751 None (Lvar param) [pat, rem] partial)
752 in
753 (path, path_lam,
754 match obj_init with
755 Lfunction {kind = Curried; params; body} -> build params body
756 | rem -> build [] rem)
757 | Tcl_apply (cl, oexprs) ->
758 let path, path_lam, obj_init =
759 transl_class_rebind ~scopes obj_init cl vf in
760 (path, path_lam, transl_apply ~scopes obj_init oexprs Loc_unknown)
761 | Tcl_let (rec_flag, defs, _vals, cl) ->
762 let path, path_lam, obj_init =
763 transl_class_rebind ~scopes obj_init cl vf in
764 (path, path_lam, Translcore.transl_let ~scopes rec_flag defs obj_init)
765 | Tcl_structure _ -> raise Exit
766 | Tcl_constraint (cl', _, _, _, _) ->
767 let path, path_lam, obj_init =
768 transl_class_rebind ~scopes obj_init cl' vf in
769 let rec check_constraint = function
770 Cty_constr(path', _, _) when Path.same path path' -> ()
771 | Cty_arrow (_, _, cty) -> check_constraint cty
772 | _ -> raise Exit
773 in
774 check_constraint cl.cl_type;
775 (path, path_lam, obj_init)
776 | Tcl_open (_, cl) ->
777 transl_class_rebind ~scopes obj_init cl vf
778
779let rec transl_class_rebind_0 ~scopes (self:Ident.t) obj_init cl vf =
780 match cl.cl_desc with
781 Tcl_let (rec_flag, defs, _vals, cl) ->
782 let path, path_lam, obj_init =
783 transl_class_rebind_0 ~scopes self obj_init cl vf
784 in
785 (path, path_lam, Translcore.transl_let ~scopes rec_flag defs obj_init)
786 | _ ->
787 let path, path_lam, obj_init =
788 transl_class_rebind ~scopes obj_init cl vf in
789 (path, path_lam, lfunction [self, Pgenval] obj_init)
790
791let transl_class_rebind ~scopes cl vf =
792 try
793 let obj_init = Ident.create_local "obj_init"
794 and self = Ident.create_local "self" in
795 let obj_init0 =
796 lapply {
797 ap_loc=Loc_unknown;
798 ap_func=Lvar obj_init;
799 ap_args=[Lvar self];
800 ap_tailcall=Default_tailcall;
801 ap_inlined=Default_inline;
802 ap_specialised=Default_specialise;
803 }
804 in
805 let _, path_lam, obj_init' =
806 transl_class_rebind_0 ~scopes self obj_init0 cl vf in
807 let id = (obj_init' = lfunction [self, Pgenval] obj_init0) in
808 if id then path_lam else
809
810 let cla = Ident.create_local "class"
811 and new_init = Ident.create_local "new_init"
812 and env_init = Ident.create_local "env_init"
813 and table = Ident.create_local "table"
814 and envs = Ident.create_local "envs" in
815 Llet(
816 Strict, Pgenval, new_init, lfunction [obj_init, Pgenval] obj_init',
817 Llet(
818 Alias, Pgenval, cla, path_lam,
819 Lprim(Pmakeblock(0, Immutable, None),
820 [mkappl(Lvar new_init, [lfield cla 0]);
821 lfunction [table, Pgenval]
822 (Llet(Strict, Pgenval, env_init,
823 mkappl(lfield cla 1, [Lvar table]),
824 lfunction [envs, Pgenval]
825 (mkappl(Lvar new_init,
826 [mkappl(Lvar env_init, [Lvar envs])]))));
827 lfield cla 2],
828 Loc_unknown)))
829 with Exit ->
830 lambda_unit
831
832(* Rewrite a closure using builtins. Improves native code size. *)
833
834let const_path local = function
835 Lvar id -> not (List.mem id local)
836 | Lconst _ -> true
837 | Lfunction {kind = Curried; body} ->
838 let fv = free_variables body in
839 List.for_all (fun x -> not (Ident.Set.mem x fv)) local
840 | _ -> false
841
842let rec builtin_meths self env env2 body =
843 let const_path = const_path (env::self) in
844 let conv = function
845 (* Lvar s when List.mem s self -> "_self", [] *)
846 | p when const_path p -> "const", [p]
847 | Lprim(Parrayrefu _, [Lvar s; Lvar n], _) when List.mem s self ->
848 "var", [Lvar n]
849 | Lprim(Pfield(n, _, _), [Lvar e], _) when Ident.same e env ->
850 "env", [Lvar env2; Lconst(const_int n)]
851 | Lsend(Self, met, Lvar s, [], _) when List.mem s self ->
852 "meth", [met]
853 | _ -> raise Not_found
854 in
855 match body with
856 | Llet(_str, _k, s', Lvar s, body) when List.mem s self ->
857 builtin_meths (s'::self) env env2 body
858 | Lapply{ap_func = f; ap_args = [arg]} when const_path f ->
859 let s, args = conv arg in ("app_"^s, f :: args)
860 | Lapply{ap_func = f; ap_args = [arg; p]} when const_path f && const_path p ->
861 let s, args = conv arg in
862 ("app_"^s^"_const", f :: args @ [p])
863 | Lapply{ap_func = f; ap_args = [p; arg]} when const_path f && const_path p ->
864 let s, args = conv arg in
865 ("app_const_"^s, f :: p :: args)
866 | Lsend(Self, Lvar n, Lvar s, [arg], _) when List.mem s self ->
867 let s, args = conv arg in
868 ("meth_app_"^s, Lvar n :: args)
869 | Lsend(Self, met, Lvar s, [], _) when List.mem s self ->
870 ("get_meth", [met])
871 | Lsend(Public, met, arg, [], _) ->
872 let s, args = conv arg in
873 ("send_"^s, met :: args)
874 | Lsend(Cached, met, arg, [_;_], _) ->
875 let s, args = conv arg in
876 ("send_"^s, met :: args)
877 | Lfunction {kind = Curried; params = [x, _]; body} ->
878 let rec enter self = function
879 | Lprim(Parraysetu _, [Lvar s; Lvar n; Lvar x'], _)
880 when Ident.same x x' && List.mem s self ->
881 ("set_var", [Lvar n])
882 | Llet(_str, _k, s', Lvar s, body) when List.mem s self ->
883 enter (s'::self) body
884 | _ -> raise Not_found
885 in enter self body
886 | Lfunction _ -> raise Not_found
887 | _ ->
888 let s, args = conv body in ("get_"^s, args)
889
890module M = struct
891 open CamlinternalOO
892 let builtin_meths self env env2 body =
893 let builtin, args = builtin_meths self env env2 body in
894 (* if not arr then [mkappl(oo_prim builtin, args)] else *)
895 let tag = match builtin with
896 "get_const" -> GetConst
897 | "get_var" -> GetVar
898 | "get_env" -> GetEnv
899 | "get_meth" -> GetMeth
900 | "set_var" -> SetVar
901 | "app_const" -> AppConst
902 | "app_var" -> AppVar
903 | "app_env" -> AppEnv
904 | "app_meth" -> AppMeth
905 | "app_const_const" -> AppConstConst
906 | "app_const_var" -> AppConstVar
907 | "app_const_env" -> AppConstEnv
908 | "app_const_meth" -> AppConstMeth
909 | "app_var_const" -> AppVarConst
910 | "app_env_const" -> AppEnvConst
911 | "app_meth_const" -> AppMethConst
912 | "meth_app_const" -> MethAppConst
913 | "meth_app_var" -> MethAppVar
914 | "meth_app_env" -> MethAppEnv
915 | "meth_app_meth" -> MethAppMeth
916 | "send_const" -> SendConst
917 | "send_var" -> SendVar
918 | "send_env" -> SendEnv
919 | "send_meth" -> SendMeth
920 | _ -> assert false
921 in Lconst(const_int (Obj.magic tag)) :: args
922end
923open M
924
925
926(*
927 Class translation.
928 Three subcases:
929 * reapplication of a known class -> transl_class_rebind
930 * class without local dependencies -> direct translation
931 * with local dependencies -> generate a stubs tree,
932 with a node for every local classes inherited
933 A class is a 3-tuple:
934 (obj_init, class_init, env)
935 obj_init: creation function (unit -> params -> obj)
936 class_init: inheritance function (table -> env -> obj_init)
937 (one by source code)
938 env: local environment
939
940 The local environment is used for cached classes. When a
941 class definition occurs under a call to Translobj.oo_wrap
942 (typically inside a functor), the class creation code is
943 split between a static part (depending only on toplevel names)
944 and a dynamic part, the environment. The static part is cached
945 in a toplevel structure, so that only the first class creation
946 computes it and the subsequent classes can reuse it.
947 Because of that, the (static) [class_init] function takes both
948 the class table to be filled and the environment as parameters,
949 and when called is given the [env] field of the class.
950 For the [obj_init] part, an [env_init] function (of type [env -> obj_init])
951 is stored in the cache, and called on the environment to generate
952 the [obj_init] at class creation time.
953*)
954
955(*
956let prerr_ids msg ids =
957 let names = List.map Ident.unique_toplevel_name ids in
958 prerr_endline (String.concat " " (msg :: names))
959*)
960
961let free_methods l =
962 let fv = ref Ident.Set.empty in
963 let rec free l =
964 Lambda.iter_head_constructor free l;
965 match l with
966 | Lsend(Self, Lvar meth, _, _, _) ->
967 fv := Ident.Set.add meth !fv
968 | Lsend _ -> ()
969 | Lfunction{params} ->
970 List.iter (fun (param, _) -> fv := Ident.Set.remove param !fv) params
971 | Llet(_, _k, id, _arg, _body)
972 | Lmutlet(_k, id, _arg, _body) ->
973 fv := Ident.Set.remove id !fv
974 | Lletrec(decl, _body) ->
975 List.iter (fun { id } -> fv := Ident.Set.remove id !fv) decl
976 | Lstaticcatch(_e1, (_,vars), _e2) ->
977 List.iter (fun (id, _) -> fv := Ident.Set.remove id !fv) vars
978 | Ltrywith(_e1, exn, _e2) ->
979 fv := Ident.Set.remove exn !fv
980 | Lfor(v, _e1, _e2, _dir, _e3) ->
981 fv := Ident.Set.remove v !fv
982 | Lassign _
983 | Lvar _ | Lmutvar _ | Lconst _ | Lapply _
984 | Lprim _ | Lswitch _ | Lstringswitch _ | Lstaticraise _
985 | Lifthenelse _ | Lsequence _ | Lwhile _
986 | Levent _ | Lifused _ -> ()
987 in free l; !fv
988
989let transl_class ~scopes ids cl_id pub_meths cl vflag =
990 let open Value_rec_types in
991 (* First check if it is not only a rebind *)
992 let rebind = transl_class_rebind ~scopes cl vflag in
993 if rebind <> lambda_unit then rebind, Dynamic else
994
995 (* Prepare for heavy environment handling *)
996 let scopes = enter_class_definition ~scopes cl_id in
997 let tables = Ident.create_local (Ident.name cl_id ^ "_tables") in
998 let (top_env, req) = oo_add_class tables in
999 let top = not req in
1000 (* The manual specifies that toplevel lets *must* be evaluated outside of the
1001 class *)
1002 let cl_env, llets = build_class_lets ~scopes cl in
1003 let new_ids = if top then [] else Env.diff top_env cl_env in
1004 let env2 = Ident.create_local "env" in
1005 let meth_ids = get_class_meths cl in
1006 let subst env lam i0 new_ids' =
1007 let fv = free_variables lam in
1008 (* prerr_ids "cl_id =" [cl_id]; prerr_ids "fv =" (Ident.Set.elements fv); *)
1009 let fv = List.fold_right Ident.Set.remove !new_ids' fv in
1010 (* We need to handle method ids specially, as they do not appear
1011 in the typing environment (PR#3576, PR#4560) *)
1012 (* very hacky: we add and remove free method ids on the fly,
1013 depending on the visit order... *)
1014 method_ids :=
1015 Ident.Set.diff (Ident.Set.union (free_methods lam) !method_ids) meth_ids;
1016 (* prerr_ids "meth_ids =" (Ident.Set.elements meth_ids);
1017 prerr_ids "method_ids =" (Ident.Set.elements !method_ids); *)
1018 let new_ids = List.fold_right Ident.Set.add new_ids !method_ids in
1019 let fv = Ident.Set.inter fv new_ids in
1020 new_ids' := !new_ids' @ Ident.Set.elements fv;
1021 (* prerr_ids "new_ids' =" !new_ids'; *)
1022 let i = ref (i0-1) in
1023 List.fold_left
1024 (fun subst id ->
1025 incr i; Ident.Map.add id (lfield env !i) subst)
1026 Ident.Map.empty !new_ids'
1027 in
1028 let new_ids_meths = ref [] in
1029 let no_env_update _ _ env = env in
1030 let msubst arr = function
1031 Lfunction {kind = Curried; params = (self, Pgenval) :: args; body} ->
1032 let env = Ident.create_local "env" in
1033 let body' =
1034 if new_ids = [] then body else
1035 Lambda.subst no_env_update (subst env body 0 new_ids_meths) body in
1036 begin try
1037 (* Doesn't seem to improve size for bytecode *)
1038 (* if not !Clflags.native_code then raise Not_found; *)
1039 if not arr || !Clflags.debug then raise Not_found;
1040 builtin_meths [self] env env2 (lfunction args body')
1041 with Not_found ->
1042 [lfunction ((self, Pgenval) :: args)
1043 (if not (Ident.Set.mem env (free_variables body')) then body' else
1044 Llet(Alias, Pgenval, env,
1045 Lprim(Pfield_computed,
1046 [Lvar self; Lvar env2],
1047 Loc_unknown),
1048 body'))]
1049 end
1050 | _ -> assert false
1051 in
1052 let new_ids_init = ref [] in
1053 let env1 = Ident.create_local "env" and env1' = Ident.create_local "env'" in
1054 let copy_env self =
1055 if top then lambda_unit else
1056 Lifused(env2, Lprim(Psetfield_computed (Pointer, Assignment),
1057 [Lvar self; Lvar env2; Lvar env1'],
1058 Loc_unknown))
1059 and subst_env envs l lam =
1060 if top then lam else
1061 (* must be called only once! *)
1062 let lam = Lambda.subst no_env_update (subst env1 lam 1 new_ids_init) lam in
1063 Llet(Alias, Pgenval, env1, (if l = [] then Lvar envs else lfield envs 0),
1064 Llet(Alias, Pgenval, env1',
1065 (if !new_ids_init = [] then Lvar env1 else lfield env1 0),
1066 lam))
1067 in
1068
1069 (* Now we start compiling the class *)
1070 let cla = Ident.create_local "class" in
1071 let (inh_init, obj_init) =
1072 build_object_init_0 ~scopes cla [] cl copy_env subst_env top ids in
1073 let inh_init' = List.rev inh_init in
1074 let (inh_init', cl_init) =
1075 build_class_init ~scopes cla true ([],[]) inh_init' obj_init msubst top cl
1076 in
1077 assert (inh_init' = []);
1078 let table = Ident.create_local "table"
1079 and class_init = Ident.create_local (Ident.name cl_id ^ "_init")
1080 and env_init = Ident.create_local "env_init"
1081 and obj_init = Ident.create_local "obj_init" in
1082 (* Sort methods by hash *)
1083 let pub_meths =
1084 List.sort
1085 (fun s s' -> compare (Btype.hash_variant s) (Btype.hash_variant s'))
1086 pub_meths in
1087 (* Check for hash conflicts *)
1088 let tags = List.map Btype.hash_variant pub_meths in
1089 let rev_map = List.combine tags pub_meths in
1090 List.iter2
1091 (fun tag name ->
1092 let name' = List.assoc tag rev_map in
1093 if name' <> name then raise(Error(cl.cl_loc, Tags(name, name'))))
1094 tags pub_meths;
1095 let ltable table lam =
1096 Llet(Strict, Pgenval, table,
1097 mkappl (oo_prim "create_table", [transl_meth_list pub_meths]), lam)
1098 and ldirect obj_init =
1099 Llet(Strict, Pgenval, obj_init, cl_init,
1100 Lsequence(mkappl (oo_prim "init_class", [Lvar cla]),
1101 mkappl (Lvar obj_init, [lambda_unit])))
1102 in
1103 (* Simplest case: an object defined at toplevel (ids=[]) *)
1104 if top && ids = [] then llets (ltable cla (ldirect obj_init), Dynamic) else
1105
1106 let concrete = (vflag = Concrete)
1107 and lclass mk_lam_and_kind =
1108 let cl_init, _ =
1109 llets (Lambda.lfunction
1110 ~kind:Curried
1111 ~attr:default_function_attribute
1112 ~loc:Loc_unknown
1113 ~return:Pgenval
1114 ~params:[cla, Pgenval]
1115 ~body:cl_init,
1116 Dynamic (* Placeholder, real kind is computed in [lbody] below *))
1117 in
1118 let lam, rkind = mk_lam_and_kind (free_variables cl_init) in
1119 Llet(Strict, Pgenval, class_init, cl_init, lam), rkind
1120 and lbody fv =
1121 if List.for_all (fun id -> not (Ident.Set.mem id fv)) ids then
1122 (* Not recursive: can use make_class directly *)
1123 mkappl (oo_prim "make_class",[transl_meth_list pub_meths;
1124 Lvar class_init]),
1125 Dynamic
1126 else
1127 (* Recursive: need to have an actual allocation for let rec compilation
1128 to work, so hardcode make_class *)
1129 ltable table (
1130 Llet(
1131 Strict, Pgenval, env_init, mkappl (Lvar class_init, [Lvar table]),
1132 Lsequence(
1133 mkappl (oo_prim "init_class", [Lvar table]),
1134 Lprim(Pmakeblock(0, Immutable, None),
1135 [mkappl (Lvar env_init, [lambda_unit]);
1136 Lvar class_init; lambda_unit],
1137 Loc_unknown)))),
1138 Static
1139 and lbody_virt lenvs =
1140 (* Virtual classes only need to provide the [class_init] and [env]
1141 fields. [obj_init] is filled with a dummy [lambda_unit] value. *)
1142 Lprim(Pmakeblock(0, Immutable, None),
1143 [lambda_unit; Lambda.lfunction
1144 ~kind:Curried
1145 ~attr:default_function_attribute
1146 ~loc:Loc_unknown
1147 ~return:Pgenval
1148 ~params:[cla, Pgenval] ~body:cl_init;
1149 lenvs],
1150 Loc_unknown),
1151 Static
1152 in
1153 (* Still easy: a class defined at toplevel *)
1154 if top && concrete then lclass lbody else
1155 if top then llets (lbody_virt lambda_unit) else
1156
1157 (* Now for the hard stuff: prepare for table caching *)
1158 let envs = Ident.create_local "envs"
1159 and cached = Ident.create_local "cached" in
1160 let lenvs =
1161 if !new_ids_meths = [] && !new_ids_init = [] && inh_init = []
1162 then lambda_unit
1163 else Lvar envs in
1164 let lenv =
1165 let menv =
1166 if !new_ids_meths = [] then lambda_unit else
1167 Lprim(Pmakeblock(0, Immutable, None),
1168 List.map (fun id -> Lvar id) !new_ids_meths,
1169 Loc_unknown) in
1170 if !new_ids_init = [] then menv else
1171 Lprim(Pmakeblock(0, Immutable, None),
1172 menv :: List.map (fun id -> Lvar id) !new_ids_init,
1173 Loc_unknown)
1174 and linh_envs =
1175 List.map
1176 (fun (_, path_lam, _) ->
1177 Lprim(Pfield (2, Pointer, Mutable), [path_lam], Loc_unknown))
1178 (List.rev inh_init)
1179 in
1180 let make_envs (lam, rkind) =
1181 Llet(StrictOpt, Pgenval, envs,
1182 (if linh_envs = [] then lenv else
1183 Lprim(Pmakeblock(0, Immutable, None),
1184 lenv :: linh_envs, Loc_unknown)),
1185 lam),
1186 rkind
1187 and def_ids cla lam =
1188 Llet(StrictOpt, Pgenval, env2,
1189 mkappl (oo_prim "new_variable", [Lvar cla; transl_label ""]),
1190 lam)
1191 in
1192 let inh_paths =
1193 List.filter
1194 (fun (path, _, _) -> List.mem (Path.head path) new_ids) inh_init
1195 in
1196 let inh_keys =
1197 List.map
1198 (fun (_, path_lam, _) ->
1199 Lprim(Pfield (1, Pointer, Mutable), [path_lam], Loc_unknown))
1200 inh_paths
1201 in
1202 let lclass lam =
1203 Llet(Strict, Pgenval, class_init,
1204 Lambda.lfunction
1205 ~kind:Curried ~params:[cla, Pgenval]
1206 ~return:Pgenval
1207 ~attr:default_function_attribute
1208 ~loc:Loc_unknown
1209 ~body:(def_ids cla cl_init), lam)
1210 and lset cached i lam =
1211 Lprim(Psetfield(i, Pointer, Assignment),
1212 [Lvar cached; lam], Loc_unknown)
1213 in
1214 let ldirect () =
1215 ltable cla
1216 (Llet(Strict, Pgenval, env_init, def_ids cla cl_init,
1217 Lsequence(mkappl (oo_prim "init_class", [Lvar cla]),
1218 lset cached 0 (Lvar env_init))))
1219 and lclass_virt () =
1220 lset cached 0
1221 (Lambda.lfunction
1222 ~kind:Curried
1223 ~attr:default_function_attribute
1224 ~loc:Loc_unknown
1225 ~return:Pgenval
1226 ~params:[cla, Pgenval]
1227 ~body:(def_ids cla cl_init))
1228 in
1229 let lupdate_cache =
1230 if ids = [] then ldirect () else
1231 if not concrete then lclass_virt () else
1232 lclass (
1233 mkappl (oo_prim "make_class_store",
1234 [transl_meth_list pub_meths;
1235 Lvar class_init; Lvar cached])) in
1236 let lcheck_cache =
1237 if !Clflags.native_code && !Clflags.afl_instrument then
1238 (* When afl-fuzz instrumentation is enabled, ignore the cache
1239 so that the program's behaviour does not change between runs *)
1240 lupdate_cache
1241 else
1242 Lifthenelse(lfield cached 0, lambda_unit, lupdate_cache) in
1243 let lcache (lam, rkind) =
1244 let lam = Lsequence (lcheck_cache, lam) in
1245 let lam =
1246 if inh_keys = []
1247 then Llet(Alias, Pgenval, cached, Lvar tables, lam)
1248 else
1249 Llet(Strict, Pgenval, cached,
1250 mkappl (oo_prim "lookup_tables",
1251 [Lvar tables; Lprim(Pmakeblock(0, Immutable, None),
1252 inh_keys, Loc_unknown)]),
1253 lam)
1254 in
1255 lam, rkind
1256 in
1257 llets (
1258 lcache (
1259 make_envs (
1260 if ids = []
1261 then mkappl (lfield cached 0, [lenvs]), Dynamic
1262 else
1263 Lprim(Pmakeblock(0, Immutable, None),
1264 (if concrete then
1265 [mkappl (lfield cached 0, [lenvs]);
1266 lfield cached 1;
1267 lenvs]
1268 else [lambda_unit; lfield cached 0; lenvs]),
1269 Loc_unknown
1270 ),
1271 Static)))
1272
1273(* Wrapper for class compilation *)
1274(*
1275 let cl_id = ci.ci_id_class in
1276(* TODO: cl_id is used somewhere else as typesharp ? *)
1277 let _arity = List.length ci.ci_params in
1278 let pub_meths = m in
1279 let cl = ci.ci_expr in
1280 let vflag = vf in
1281*)
1282
1283let transl_class ~scopes ids id pub_meths cl vf =
1284 oo_wrap_gen cl.cl_env false (transl_class ~scopes ids id pub_meths cl) vf
1285
1286let () =
1287 transl_object := (fun ~scopes id meths cl ->
1288 let lam, _rkind = transl_class ~scopes [] id meths cl Concrete in
1289 lam)
1290
1291(* Error report *)
1292
1293open Format_doc
1294module Style = Misc.Style
1295
1296let report_error_doc ppf = function
1297 | Tags (lab1, lab2) ->
1298 fprintf ppf "Method labels %a and %a are incompatible.@ %s"
1299 Style.inline_code lab1
1300 Style.inline_code lab2
1301 "Change one of them."
1302
1303let () =
1304 Location.register_error_of_exn
1305 (function
1306 | Error (loc, err) ->
1307 Some (Location.error_of_printer ~loc report_error_doc err)
1308 | _ ->
1309 None
1310 )
1311
1312let report_error = Format_doc.compat report_error_doc