(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(*
   # Translation of class and object expressions

   ## Objects

   ### Memory layout

   Objects are represented in memory using two layers:
   - The outer layer is a block with tag [Obj.object_tag].
     It has a first field pointing to the inner layer (the methods),
     a second field acting as a unique identifier to allow
     polymorphic comparison, and the rest of the block contains
     the values of the instance variables, class parameters, and
     other values that can vary between two objects of the same class.

   - The inner layer is a regular block (with tag zero). It contains
     all values that are shared between all objects of the same class,
     which means mostly methods. The first field corresponds to the number of
     public methods, the second field is a mask used for optimising method
     access, the following fields are alternating between the method closures
     and the hash of their name (sorted in increasing hash order).
     Additional fields are used for private methods.

   +-------+------+-------+-------+-----+-------+-------+-----------+
   | n_pub | mask | met_1 | tag_1 | ... | met_n | tag_n | other ... |
   +-------+------+-------+-------+-----+-------+-------+-----------+

   ### Primitives

   Method access is compiled in one of three possible ways:
   - Generic method access (outside a class, or to an object that is not
     self or an ancestor) uses dynamic lookup. A dichotomic search in
     the part of the method array that stores public methods finds
     the expected closure and calls it on the current object.
     In most cases, a fast path also exists: each method access in the
     source code has an associated cache location that stores the offset
     of the last method called at this point in its method array.
     Before the dichotomic search, the last stored offset (clamped
     to the actual size of the method array using the mask) is checked,
     and if the tag matches the associated closure is called directly.
   - Method access through the self object inside a class:
     the (runtime) index of the method inside the method array
     has been computed at class creation time, so the method is fetched
     from the block through a dynamic block load (like an array load).
   - Accessing the method of an ancestor inside a class (ancestors are
     variables bound by [inherit ... as ancestor] constructions):
     at class creation time, the closure of the ancestor method is bound
     to a variable, and the method call just calls this function without
     any (further) dynamic lookup.

   Instance variable access (getting and setting) also computes offsets
   at class initialisation time, with those offsets used to index directly
   in the outer layer of the object.

   Functional object copy [ {< ... >} ] copies the outer layer, resets the
   unique ID, and performs the required instance variable updates.

   There are no other object primitives (objects cannot be allocated
   in the IR directly, they are allocated in [CamlinternalOO])

   ## Classes

   Classes are stored as module fields. The runtime value that represents
   classes is used in two contexts:

   - When using the [new] construction, to generate an object from a class.
   - When referencing a class inside another class (either through
     inheritance or other class expressions).

   This is done by storing classes as blocks where the first field
   is used to generate objects, and the second field is used to derive
   classes (in a general sense, not only for inheritance).
   In practice classes also contain one other field, which is used to
   implement some optimisations in the main compiler (to ensure that each
   class only runs its initialisation code once in the whole program, even
   if its definition is in a context that is expected to be run several
   times like a functor).
   So the block layout is the following:
   - A field named [obj_init] that is used for creating objects
   - A field named [class_init] that is used for deriving classes
   - A field named [env] containing values for all the variables
     captured by [Translobj.oo_wrap] calls.

   The module [CamlinternalOO] also defines a type [table] that represents
   class layouts. Such values are not stored in the class block directly,
   but the [obj_init] field captures the table for the class and [class_init]
   manipulates such tables.

   ### The [obj_init] field

   As described earlier, each object contains an inner layer that is computed
   only once at class initialisation time; it seems natural to store this
   block in the runtime value of the class (this block is one of the fields of
   the [CamlinternalOO.table] type). However, given that creating an
   object also involves setting up the instance variables and running the
   initialisers, in practice the class only exports a function that creates
   objects, and the table is captured in this function's closure along with
   any value necessary to properly initialise the object.
   Classes can have parameters, so in practice this object creation function
   takes a first unit parameter (to ensure that it is always a function)
   and returns a regular OCaml value that is either an object (if the class
   doesn't have parameters) or a function which, given values
   for the class parameters, will return an object.

   Here is the type of the [obj_init] function for a class which type is
   [p1 -> ... -> pn -> object method m1 : t1 ... method mn : tn end]:
   [unit -> p1 -> ... -> pn -> < m1 : t1; ... mn : tn >]
   (If the class has instance variables or initialisers, they are not
   reflected in the type of [obj_init]).

   ### The [class_init] field

   This field is used in two cases:
   - When a class is defined in terms of another class, for instance as an
     alias, a partial application, or some other kind of wrapper.
   - When a class structure (i.e. the [object ... end] syntactic construction)
     contains inheritance fields (e.g. [inherit cl as super]).

   In both cases, we only have access to the other class' public type at
   compile time, but we must still make sure all of the private fields
   are setup correctly, in a way that is compatible with the current
   class.

   This is where tables come into play: the [class_init] field is a function
   taking a table as parameter, updates it in-place, and returns a function
   that is very similar to the [obj_init] function, except that instead of
   taking [unit] as its first parameter and returning an object, it takes
   a partially initialised object, and updates the parts of it that are
   relevant for the corresponding class. It also takes the [env] field as
   a parameter, so that different instances of the class can share the
   same [class_init] function.

   Thus, the type of [class_init] is:
   [table -> env -> Obj.t -> p1 -> ... -> pn -> unit]

   ### The [env] field

   The [env] field is a structure similar to a function's closure, storing
   the value of free variables of the class expression. The actual
   representation is a bit complex and not very important.

   ### Compilation scheme

   The algorithm implemented below aims at sharing code as much as possible
   between the various similar parts of the class.

   - The code of the [obj_init] function is very similar to the code of
     the function returned by [class_init]. The main difference is that
     [obj_init] starts from scratch, allocating then initialising the object,
     while inside [class_init] we want to run initialisation code on an already
     allocated object (that we don't need to return).
     So in practice we will build a single function that, depending on the value
     of its first parameter, will either do the allocation and return the object
     (if the parameter is the integer constant 0), or assume the parameter is
     an already allocated and update it.
     The body of this function is returned by [build_object_init].
   - The table for the current class (that [obj_init] will read from) is
     computed by allocating a basic table, then passing it to [class_init],
     and finally calling [CamlinternalOO.init_class] on it.
     This means that all the code for setting up the class (computing instance
     variable indices, calling inherited class initialisers, and so on) is only
     generated once, in the [class_init] function.
     After building [obj_init], [build_class_init] wraps it with the class
     initialization code to build the [class_init] function.

   That's all for the high-level algorithm; the rest will be detailed close to
   the corresponding code.

*)

open Asttypes
open Types
open Typedtree
open Lambda
open Translobj
open Translcore
open Debuginfo.Scoped_location

(* XXX Rajouter des evenements... | Add more events... *)

type error = Tags of label * label

exception Error of Location.t * error

let lfunction params body =
  if params = [] then body else
  match body with
  | Lfunction {kind = Curried; params = params'; body = body'; attr; loc}
    when attr.may_fuse_arity &&
         List.length params + List.length params' <= Lambda.max_arity() ->
      lfunction ~kind:Curried ~params:(params @ params')
                ~return:Pgenval
                ~body:body'
                ~attr
                ~loc
  |  _ ->
      lfunction ~kind:Curried ~params ~return:Pgenval
                ~body
                ~attr:default_function_attribute
                ~loc:Loc_unknown

let lapply ap =
  match ap.ap_func with
    Lapply ap' ->
      Lapply {ap with ap_func = ap'.ap_func; ap_args = ap'.ap_args @ ap.ap_args}
  | _ ->
      Lapply ap

let mkappl (func, args) =
  Lapply {
    ap_loc=Loc_unknown;
    ap_func=func;
    ap_args=args;
    ap_tailcall=Default_tailcall;
    ap_inlined=Default_inline;
    ap_specialised=Default_specialise;
  }

let lsequence l1 l2 =
  if l2 = lambda_unit then l1 else Lsequence(l1, l2)

let lfield v i = Lprim(Pfield (i, Pointer, Mutable),
                       [Lvar v], Loc_unknown)

let transl_label l = share (Const_immstring l)

let transl_meth_list lst =
  if lst = [] then Lconst (const_int 0) else
  share (Const_block
            (0, List.map (fun lab -> Const_immstring lab) lst))

let set_inst_var ~scopes obj id expr =
  Lprim(Psetfield_computed (Typeopt.maybe_pointer expr, Assignment),
    [Lvar obj; Lvar id; transl_exp ~scopes expr], Loc_unknown)

let transl_val tbl create name =
  mkappl (oo_prim (if create then "new_variable" else "get_variable"),
          [Lvar tbl; transl_label name])

let transl_vals tbl create strict vals rem =
  List.fold_right
    (fun (name, id) rem ->
      Llet(strict, Pgenval, id, transl_val tbl create name, rem))
    vals rem

let meths_super tbl meths inh_meths =
  List.fold_right
    (fun (nm, id) rem ->
       try
         (nm, id,
          mkappl(oo_prim "get_method", [Lvar tbl; Lvar (Meths.find nm meths)]))
         :: rem
       with Not_found -> rem)
    inh_meths []

(*
[build_class_init] has two parameters ([cstr] and [super]) that are set when
translating the expression of a class that will be inherited in an outer class.

They could be replaced with the following type:

```
type inheritance_status =
  | Normal (** Not under an [inherit] construct *)
  | Inheriting of {
      must_narrow : bool;
      (** [false] if we already went through a call to [narrow] *)
      method_getters : (Ident.t * lambda) list;
      (** Ancestor methods are accessed through identifiers.
          These identifiers are bound at class initialisation time,
          by fetching the actual closures from the table just
          after setting up the inherited class. *)
      instance_vars : (string * Ident.t) list;
      (** Inherited instance variables need to have their index bound
          in the scope of the child class *)
    }
```

[cstr] is the negation of [must_narrow], and [super] is the pair
[(instance_vars, method_getters)].
*)

let bind_super tbl (vals, meths) cl_init =
  transl_vals tbl false StrictOpt vals
    (List.fold_right (fun (_nm, id, def) rem ->
         Llet(StrictOpt, Pgenval, id, def, rem))
       meths cl_init)

let create_object cl obj init =
  let obj' = Ident.create_local "self" in
  let (inh_init, obj_init, has_init) = init obj' in
  if obj_init = lambda_unit then
    (inh_init,
     mkappl (oo_prim (if has_init then "create_object_and_run_initializers"
                      else "create_object_opt"),
             [obj; Lvar cl]))
  else begin
   (inh_init,
    Llet(Strict, Pgenval, obj',
            mkappl (oo_prim "create_object_opt", [obj; Lvar cl]),
         Lsequence(obj_init,
                   if not has_init then Lvar obj' else
                   mkappl (oo_prim "run_initializers_opt",
                           [obj; Lvar obj'; Lvar cl]))))
  end

let name_pattern default p =
  match p.pat_desc with
  | Tpat_var (id, _, _) -> id
  | Tpat_alias(_, id, _, _, _) -> id
  | _ -> Ident.create_local default

(*
   [build_object_init] returns an expression that creates and initialises new
   objects. If the class takes parameters, it is a function that, given values
   for the parameters, performs the initialisations and (if needed) object
   creation.
   The [obj] expression will be bound to either the integer 0, in which case
   [obj_init] must allocate the object and return it, or to an already allocated
   object, in which case [obj_init] will initialize the relevant parts of it
   through side-effects. In the case of an immediate object it is always 0.
   Parameters:
   - [scopes] corresponds to the location scopes (as in the rest of the
     translation code)
   - [cl_table] is the variable to which the table for the current class is
     bound
   - [obj] is the parameter of the [obj_init] function we want to create.
     As explained above at runtime it might point to either an already allocated
     object, when inheriting, or a dummy zero value, when calling [new].
   - [params] stores the anonymous instance variables associated with all
     variables that occur inside the class definition but outside the
     [object ... end] structure: class parameters and class let bindings.
     The definition is always the identifier corresponding to the original
     variable.
   - [inh_init] accumulates data about the class identifiers encountered, and is
     returned at the end to be reused in [build_class_init].
   - [cl] is the class we're compiling *)

let rec build_object_init ~scopes cl_table obj params inh_init obj_init cl =
  match cl.cl_desc with
    Tcl_ident (path, _, _) ->
      (* The object initialiser for the class in [path], specialised
         to the class being defined *)
      let obj_init = Ident.create_local "obj_init" in
      let envs, inh_init = inh_init in
      let env =
        match envs with None -> []
        | Some envs ->
            [Lprim(Pfield (List.length inh_init + 1, Pointer, Mutable),
                   [Lvar envs],
                   Loc_unknown)]
      in
      let loc = of_location ~scopes cl.cl_loc in
      let path_lam = transl_class_path loc cl.cl_env path in
      (* Note: we don't need to bind [params] here, as they are
         only used in structures. Outside structures (in class lets or
         applications) we use the regular identifiers. *)
      ((envs, (path, path_lam, obj_init) :: inh_init),
       mkappl(Lvar obj_init, env @ [obj]))
  | Tcl_structure str ->
      (* Initialising a concrete class structure *)
      create_object cl_table obj (fun obj ->
        (* [obj] will be bound to the allocated object,
           unlike the original [obj] which might be zero if called directly
           from an object creation expression. *)
        let (inh_init, obj_init, has_init) =
          List.fold_right
            (fun field (inh_init, obj_init, has_init) ->
               match field.cf_desc with
                 Tcf_inherit (_, cl, _, _, _) ->
                   let (inh_init, obj_init') =
                     (* Reset [params]. The current ones will be bound
                        outside the structure. *)
                     build_object_init ~scopes cl_table (Lvar obj) [] inh_init
                       (fun _ -> lambda_unit) cl
                   in
                   (* Since [obj] is bound to a concrete object,
                      only the side-effects of [obj_init'] are relevant. *)
                   (inh_init, lsequence obj_init' obj_init, true)
               | Tcf_val (_, _, id, Tcfk_concrete (_, exp), _) ->
                   (inh_init,
                    lsequence (set_inst_var ~scopes obj id exp) obj_init,
                    has_init)
               | Tcf_method _ | Tcf_val _ | Tcf_constraint _ | Tcf_attribute _->
                   (inh_init, obj_init, has_init)
               | Tcf_initializer _ ->
                   (inh_init, obj_init, true)
            )
            str.cstr_fields
            (inh_init, obj_init obj, false)
        in
        (* Set the instance variables associated to the class parameters and
           let bindings to their expected value. *)
        (inh_init,
         List.fold_right
           (fun (id, expr) rem ->
              lsequence (Lifused (id, set_inst_var ~scopes obj id expr)) rem)
           params obj_init,
         has_init))
  | Tcl_fun (_, pat, vals, cl, partial) ->
      let (inh_init, obj_init) =
        (* [vals] maps all pattern variables to idents for use inside methods *)
        build_object_init ~scopes cl_table obj (vals @ params)
          inh_init obj_init cl
      in
      (inh_init,
       let build params rem =
         let param = name_pattern "param" pat in
         Lambda.lfunction
                   ~kind:Curried ~params:((param, Pgenval)::params)
                   ~return:Pgenval
                   ~attr:default_function_attribute
                   ~loc:(of_location ~scopes pat.pat_loc)
                   ~body:(Matching.for_function ~scopes pat.pat_loc
                             None (Lvar param) [pat, rem] partial)
       in
       begin match obj_init with
         Lfunction {kind = Curried; params; body = rem} -> build params rem
       | rem                                            -> build [] rem
       end)
  | Tcl_apply (cl, oexprs) ->
      let (inh_init, obj_init) =
        build_object_init ~scopes cl_table obj params inh_init obj_init cl
      in
      (inh_init, transl_apply ~scopes obj_init oexprs Loc_unknown)
  | Tcl_let (rec_flag, defs, vals, cl) ->
      (* See comment on the [Tcl_fun] case for the meaning of [vals] *)
      let (inh_init, obj_init) =
        build_object_init ~scopes cl_table obj (vals @ params)
          inh_init obj_init cl
      in
      (inh_init, Translcore.transl_let ~scopes rec_flag defs obj_init)
  | Tcl_open (_, cl)
    (* Class local opens are restricted to paths only, so no code is generated
     *)
  | Tcl_constraint (cl, _, _, _, _) ->
      build_object_init ~scopes cl_table obj params inh_init obj_init cl

(* The manual specifies that toplevel lets *must* be evaluated outside of the
   class. This piece of code makes sure we skip them. *)
let rec build_object_init_0
          ~scopes cl_table params cl copy_env subst_env top ids =
  match cl.cl_desc with
    Tcl_let (_rec_flag, _defs, vals, cl) ->
      build_object_init_0
        ~scopes cl_table (vals@params) cl copy_env subst_env top ids
  | Tcl_open (_descr, cl) ->
      build_object_init_0
        ~scopes cl_table params cl copy_env subst_env top ids
  | _ ->
      let self = Ident.create_local "self" in
      let env = Ident.create_local "env" in
      let obj = if ids = [] then lambda_unit else Lvar self in
      let envs = if top then None else Some env in
      let ((_,inh_init), obj_init) =
        build_object_init ~scopes cl_table obj params (envs,[]) copy_env cl in
      let obj_init =
        if ids = [] then obj_init else lfunction [self, Pgenval] obj_init in
      (inh_init, lfunction [env, Pgenval] (subst_env env inh_init obj_init))


let bind_method tbl lab id cl_init =
  Llet(Strict, Pgenval, id, mkappl (oo_prim "get_method_label",
                           [Lvar tbl; transl_label lab]),
       cl_init)

let bind_methods tbl meths vals cl_init =
  let methl = Meths.fold (fun lab id tl -> (lab,id) :: tl) meths [] in
  let len = List.length methl and nvals = List.length vals in
  if len < 2 && nvals = 0 then Meths.fold (bind_method tbl) meths cl_init else
  if len = 0 && nvals < 2 then transl_vals tbl true Strict vals cl_init else
  let ids = Ident.create_local "ids" in
  let i = ref (len + nvals) in
  let getter, names =
    if nvals = 0 then "get_method_labels", [] else
    "new_methods_variables", [transl_meth_list (List.map fst vals)]
  in
  Llet(Strict, Pgenval, ids,
       mkappl (oo_prim getter,
               [Lvar tbl; transl_meth_list (List.map fst methl)] @ names),
       List.fold_right
         (fun (_lab,id) lam -> decr i; Llet(StrictOpt, Pgenval, id,
                                           lfield ids !i, lam))
         (methl @ vals) cl_init)

let output_methods tbl methods lam =
  match methods with
    [] -> lam
  | [lab; code] ->
      lsequence (mkappl(oo_prim "set_method", [Lvar tbl; lab; code])) lam
  | _ ->
      lsequence (mkappl(oo_prim "set_methods",
                        [Lvar tbl; Lprim(Pmakeblock(0,Immutable,None),
                                         methods, Loc_unknown)]))
        lam

let rec ignore_cstrs cl =
  match cl.cl_desc with
    Tcl_constraint (cl, _, _, _, _) -> ignore_cstrs cl
  | Tcl_apply (cl, _) -> ignore_cstrs cl
  | _ -> cl

let rec index a = function
    [] -> raise Not_found
  | b :: l ->
      if b = a then 0 else 1 + index a l

let bind_id_as_val (id, _) = ("", id)

(** Build the class initialisation code.
    Parameters:
    - [scopes] corresponds to the location scopes (as in the rest of the
      translation code)
    - [cla] is the variable to which the table for the current class is bound
    - [cstr] is [true] when called from outside, but [false] when called
      from an [inherit] field. Narrowing is necessary during inheritance to
      prevent clashes between methods/variables in the child class and private
      methods/variables in the parent.
    - [super] stores, if we're building an inherited class, the variables and
      methods exposed to the child. The variables need to have their associated
      index exposed, and methods have to be bound in case the child refers to
      them through the ancestor variables.
    - [inh_init] is the sequence of inheritance paths computed during
      [build_object_init].
    - [cl_init] is the expression we're building.
    - [msubst] replaces methods with builtin methods when possible.
    - [top] is [false] if the current class is under [Translobj.oo_wrap].
    - [cl] is the class we're compiling *)
let rec build_class_init ~scopes cla cstr super inh_init cl_init msubst top cl =
  match cl.cl_desc with
  | Tcl_ident _ ->
      begin match inh_init with
      | (_, path_lam, obj_init)::inh_init ->
          (inh_init,
           Llet (Strict, Pgenval, obj_init,
              (* Load the [class_init] field of the class,
                 and apply it to our current table and the class' environment.
                 This gets us the object initialiser. *)
                 mkappl(Lprim(Pfield (1, Pointer, Mutable),
                              [path_lam], Loc_unknown), Lvar cla ::
                        if top then [Lprim(Pfield (2, Pointer, Mutable),
                                     [path_lam], Loc_unknown)]
                        else []),
              (* The methods and variables for this class are fully registered
                 in the table. If we are in an inheritance context, we can now
                 bind everything. *)
                 bind_super cla super cl_init))
      | _ ->
          assert false
      end
  | Tcl_structure str ->
      let cl_init = bind_super cla super cl_init in
      let (inh_init, cl_init, methods, values) =
        List.fold_right
          (fun field (inh_init, cl_init, methods, values) ->
            match field.cf_desc with
              Tcf_inherit (_, cl, _, vals, meths) ->
                let cl_init = output_methods cla methods cl_init in
                let inh_init, cl_init =
                 (* Build the initialisation code for the inherited class,
                    plus its wrappers.
                    Make sure the wrappers bind the inherited methods
                    and variables. *)
                  build_class_init ~scopes cla false
                    (vals, meths_super cla str.cstr_meths meths)
                    inh_init cl_init msubst top cl in
                (inh_init, cl_init, [], values)
            | Tcf_val (name, _, id, _, over) ->
                (* If this is an override, the variable is the same as
                   the one from the earlier definition, and must not be
                   bound again. *)
                let values =
                  if over then values else (name.txt, id) :: values
                in
                (inh_init, cl_init, methods, values)
            | Tcf_method (_, _, Tcfk_virtual _)
            | Tcf_constraint _
              ->
                (inh_init, cl_init, methods, values)
            | Tcf_method (name, _, Tcfk_concrete (_, exp)) ->
                let scopes = enter_method_definition ~scopes name.txt in
                let met_code =
                  msubst true (transl_scoped_exp ~scopes exp) in
                let met_code =
                  if !Clflags.native_code && List.length met_code = 1 then
                    (* Force correct naming of method for profiles *)
                    let met = Ident.create_local ("method_" ^ name.txt) in
                    [Llet(Strict, Pgenval, met, List.hd met_code, Lvar met)]
                  else met_code
                in
                (inh_init, cl_init,
                 Lvar(Meths.find name.txt str.cstr_meths) :: met_code @ methods,
                 values)
            | Tcf_initializer exp ->
                (inh_init,
                 Lsequence(mkappl (oo_prim "add_initializer",
                                   Lvar cla :: msubst false
                                                 (transl_exp ~scopes exp)),
                           cl_init),
                 methods, values)
            | Tcf_attribute _ ->
                (inh_init, cl_init, methods, values))
          str.cstr_fields
          (inh_init, cl_init, [], [])
      in
        (* In order of execution at runtime:
           - Bind the method and variable indices for the current class
             ([bind_methods])
           - Run the code for setting up the individual fields ([cl_init], plus
             [output_methods] for the remaining unset methods)
           - If we are in an inheritance context, bind the inherited variables
             and methods for use in the child ([bind_super] at the top of this
             branch) *)
      let cl_init = output_methods cla methods cl_init in
      (inh_init, bind_methods cla str.cstr_meths values cl_init)
  | Tcl_fun (_, _pat, vals, cl, _) ->
      let (inh_init, cl_init) =
        build_class_init ~scopes cla cstr super inh_init cl_init msubst top cl
      in
      (* Create anonymous instance variables and define them in the table *)
      let vals = List.map bind_id_as_val vals in
      (inh_init, transl_vals cla true StrictOpt vals cl_init)
  | Tcl_apply (cl, _exprs) ->
      build_class_init ~scopes cla cstr super inh_init cl_init msubst top cl
  | Tcl_let (_rec_flag, _defs, vals, cl) ->
      let (inh_init, cl_init) =
        build_class_init ~scopes cla cstr super inh_init cl_init msubst top cl
      in
      (* Create anonymous instance variables and define them in the table *)
      let vals = List.map bind_id_as_val vals in
      (inh_init, transl_vals cla true StrictOpt vals cl_init)
  | Tcl_constraint (cl, _, vals, meths, concr_meths) ->
      let virt_meths =
        List.filter (fun lab -> not (MethSet.mem lab concr_meths)) meths in
      let concr_meths = MethSet.elements concr_meths in
      let narrow_args =
        [Lvar cla;
         transl_meth_list vals;
         transl_meth_list virt_meths;
         transl_meth_list concr_meths] in
      let cl = ignore_cstrs cl in
      begin match cl.cl_desc, inh_init with
      | Tcl_ident (path, _, _), (path', path_lam, obj_init)::inh_init ->
          assert (Path.same path path');
          let inh = Ident.create_local "inh"
          and ofs = List.length vals + 1
          and valids, methids = super in
          let cl_init =
            List.fold_left
              (fun init (nm, id, _) ->
                Llet(StrictOpt, Pgenval, id,
                     lfield inh (index nm concr_meths + ofs),
                     init))
              cl_init methids in
          let cl_init =
            List.fold_left
              (fun init (nm, id) ->
                Llet(StrictOpt, Pgenval, id,
                     lfield inh (index nm vals + 1), init))
              cl_init valids in
          (inh_init,
           Llet (Strict, Pgenval, inh,
                 mkappl(oo_prim "inherits", narrow_args @
                        [path_lam;
                         Lconst(const_int (if top then 1 else 0))]),
                 Llet(StrictOpt, Pgenval, obj_init, lfield inh 0, cl_init)))
      | _ ->
          let core cl_init =
            build_class_init
              ~scopes cla true super inh_init cl_init msubst top cl
          in
          (* Skip narrowing if we're not directly under [inherit] *)
          if cstr then core cl_init else
          let (inh_init, cl_init) =
            core (Lsequence (mkappl (oo_prim "widen", [Lvar cla]), cl_init))
          in
          (inh_init,
           Lsequence(mkappl (oo_prim "narrow", narrow_args),
                     cl_init))
      end
  | Tcl_open (_, cl) ->
      build_class_init ~scopes cla cstr super inh_init cl_init msubst top cl

let rec build_class_lets ~scopes cl =
  match cl.cl_desc with
    Tcl_let (rec_flag, defs, _vals, cl') ->
      let env, wrap = build_class_lets ~scopes cl' in
      (env, fun lam_and_kind ->
          let lam, rkind = wrap lam_and_kind in
          Translcore.transl_let ~scopes rec_flag defs lam, rkind)
  | Tcl_open (open_descr, cl) ->
      (* Failsafe to ensure we get a compilation error if arbitrary
         module expressions become allowed *)
      let _ : Path.t * Longident.t loc = open_descr.open_expr in
      build_class_lets ~scopes cl
  | _ ->
      (cl.cl_env, fun lam_and_kind -> lam_and_kind)

let rec get_class_meths cl =
  match cl.cl_desc with
    Tcl_structure cl ->
      Meths.fold (fun _ -> Ident.Set.add) cl.cstr_meths Ident.Set.empty
  | Tcl_ident _ -> Ident.Set.empty
  | Tcl_fun (_, _, _, cl, _)
  | Tcl_let (_, _, _, cl)
  | Tcl_apply (cl, _)
  | Tcl_open (_, cl)
  | Tcl_constraint (cl, _, _, _, _) -> get_class_meths cl

(*
   XXX Il devrait etre peu couteux d'ecrire des classes :
   |   Writing classes should be cheap
     class c x y = d e f
*)
let rec transl_class_rebind ~scopes obj_init cl vf =
  match cl.cl_desc with
    Tcl_ident (path, _, _) ->
      if vf = Concrete then begin
        try if (Env.find_class path cl.cl_env).cty_new = None then raise Exit
        with Not_found -> raise Exit
      end;
      let cl_loc = of_location ~scopes cl.cl_loc in
      let path_lam = transl_class_path cl_loc cl.cl_env path in
      (path, path_lam, obj_init)
  | Tcl_fun (_, pat, _, cl, partial) ->
      let path, path_lam, obj_init =
        transl_class_rebind ~scopes obj_init cl vf in
      let build params rem =
        let param = name_pattern "param" pat in
        Lambda.lfunction
                  ~kind:Curried ~params:((param, Pgenval)::params)
                  ~return:Pgenval
                  ~attr:default_function_attribute
                  ~loc:(of_location ~scopes pat.pat_loc)
                  ~body:(Matching.for_function ~scopes pat.pat_loc
                            None (Lvar param) [pat, rem] partial)
      in
      (path, path_lam,
       match obj_init with
         Lfunction {kind = Curried; params; body} -> build params body
       | rem                                      -> build [] rem)
  | Tcl_apply (cl, oexprs) ->
      let path, path_lam, obj_init =
        transl_class_rebind ~scopes obj_init cl vf in
      (path, path_lam, transl_apply ~scopes obj_init oexprs Loc_unknown)
  | Tcl_let (rec_flag, defs, _vals, cl) ->
      let path, path_lam, obj_init =
        transl_class_rebind ~scopes obj_init cl vf in
      (path, path_lam, Translcore.transl_let ~scopes rec_flag defs obj_init)
  | Tcl_structure _ -> raise Exit
  | Tcl_constraint (cl', _, _, _, _) ->
      let path, path_lam, obj_init =
        transl_class_rebind ~scopes obj_init cl' vf in
      let rec check_constraint = function
          Cty_constr(path', _, _) when Path.same path path' -> ()
        | Cty_arrow (_, _, cty) -> check_constraint cty
        | _ -> raise Exit
      in
      check_constraint cl.cl_type;
      (path, path_lam, obj_init)
  | Tcl_open (_, cl) ->
      transl_class_rebind ~scopes obj_init cl vf

let rec transl_class_rebind_0 ~scopes (self:Ident.t) obj_init cl vf =
  match cl.cl_desc with
    Tcl_let (rec_flag, defs, _vals, cl) ->
      let path, path_lam, obj_init =
        transl_class_rebind_0 ~scopes self obj_init cl vf
      in
      (path, path_lam, Translcore.transl_let ~scopes rec_flag defs obj_init)
  | _ ->
      let path, path_lam, obj_init =
        transl_class_rebind ~scopes obj_init cl vf in
      (path, path_lam, lfunction [self, Pgenval] obj_init)

let transl_class_rebind ~scopes cl vf =
  try
    let obj_init = Ident.create_local "obj_init"
    and self = Ident.create_local "self" in
    let obj_init0 =
      lapply {
        ap_loc=Loc_unknown;
        ap_func=Lvar obj_init;
        ap_args=[Lvar self];
        ap_tailcall=Default_tailcall;
        ap_inlined=Default_inline;
        ap_specialised=Default_specialise;
      }
    in
    let _, path_lam, obj_init' =
      transl_class_rebind_0 ~scopes self obj_init0 cl vf in
    let id = (obj_init' = lfunction [self, Pgenval] obj_init0) in
    if id then path_lam else

    let cla = Ident.create_local "class"
    and new_init = Ident.create_local "new_init"
    and env_init = Ident.create_local "env_init"
    and table = Ident.create_local "table"
    and envs = Ident.create_local "envs" in
    Llet(
    Strict, Pgenval, new_init, lfunction [obj_init, Pgenval] obj_init',
    Llet(
    Alias, Pgenval, cla, path_lam,
    Lprim(Pmakeblock(0, Immutable, None),
          [mkappl(Lvar new_init, [lfield cla 0]);
           lfunction [table, Pgenval]
             (Llet(Strict, Pgenval, env_init,
                   mkappl(lfield cla 1, [Lvar table]),
                   lfunction [envs, Pgenval]
                     (mkappl(Lvar new_init,
                             [mkappl(Lvar env_init, [Lvar envs])]))));
           lfield cla 2],
          Loc_unknown)))
  with Exit ->
    lambda_unit

(* Rewrite a closure using builtins. Improves native code size. *)

let const_path local = function
    Lvar id -> not (List.mem id local)
  | Lconst _ -> true
  | Lfunction {kind = Curried; body} ->
      let fv = free_variables body in
      List.for_all (fun x -> not (Ident.Set.mem x fv)) local
  | _ -> false

let rec builtin_meths self env env2 body =
  let const_path = const_path (env::self) in
  let conv = function
    (* Lvar s when List.mem s self ->  "_self", [] *)
    | p when const_path p -> "const", [p]
    | Lprim(Parrayrefu _, [Lvar s; Lvar n], _) when List.mem s self ->
        "var", [Lvar n]
    | Lprim(Pfield(n, _, _), [Lvar e], _) when Ident.same e env ->
        "env", [Lvar env2; Lconst(const_int n)]
    | Lsend(Self, met, Lvar s, [], _) when List.mem s self ->
        "meth", [met]
    | _ -> raise Not_found
  in
  match body with
  | Llet(_str, _k, s', Lvar s, body) when List.mem s self ->
      builtin_meths (s'::self) env env2 body
  | Lapply{ap_func = f; ap_args = [arg]} when const_path f ->
      let s, args = conv arg in ("app_"^s, f :: args)
  | Lapply{ap_func = f; ap_args = [arg; p]} when const_path f && const_path p ->
      let s, args = conv arg in
      ("app_"^s^"_const", f :: args @ [p])
  | Lapply{ap_func = f; ap_args = [p; arg]} when const_path f && const_path p ->
      let s, args = conv arg in
      ("app_const_"^s, f :: p :: args)
  | Lsend(Self, Lvar n, Lvar s, [arg], _) when List.mem s self ->
      let s, args = conv arg in
      ("meth_app_"^s, Lvar n :: args)
  | Lsend(Self, met, Lvar s, [], _) when List.mem s self ->
      ("get_meth", [met])
  | Lsend(Public, met, arg, [], _) ->
      let s, args = conv arg in
      ("send_"^s, met :: args)
  | Lsend(Cached, met, arg, [_;_], _) ->
      let s, args = conv arg in
      ("send_"^s, met :: args)
  | Lfunction {kind = Curried; params = [x, _]; body} ->
      let rec enter self = function
        | Lprim(Parraysetu _, [Lvar s; Lvar n; Lvar x'], _)
          when Ident.same x x' && List.mem s self ->
            ("set_var", [Lvar n])
        | Llet(_str, _k, s', Lvar s, body) when List.mem s self ->
            enter (s'::self) body
        | _ -> raise Not_found
      in enter self body
  | Lfunction _ -> raise Not_found
  | _ ->
      let s, args = conv body in ("get_"^s, args)

module M = struct
  open CamlinternalOO
  let builtin_meths self env env2 body =
    let builtin, args = builtin_meths self env env2 body in
    (* if not arr then [mkappl(oo_prim builtin, args)] else *)
    let tag = match builtin with
      "get_const" -> GetConst
    | "get_var"   -> GetVar
    | "get_env"   -> GetEnv
    | "get_meth"  -> GetMeth
    | "set_var"   -> SetVar
    | "app_const" -> AppConst
    | "app_var"   -> AppVar
    | "app_env"   -> AppEnv
    | "app_meth"  -> AppMeth
    | "app_const_const" -> AppConstConst
    | "app_const_var"   -> AppConstVar
    | "app_const_env"   -> AppConstEnv
    | "app_const_meth"  -> AppConstMeth
    | "app_var_const"   -> AppVarConst
    | "app_env_const"   -> AppEnvConst
    | "app_meth_const"  -> AppMethConst
    | "meth_app_const"  -> MethAppConst
    | "meth_app_var"    -> MethAppVar
    | "meth_app_env"    -> MethAppEnv
    | "meth_app_meth"   -> MethAppMeth
    | "send_const" -> SendConst
    | "send_var"   -> SendVar
    | "send_env"   -> SendEnv
    | "send_meth"  -> SendMeth
    | _ -> assert false
    in Lconst(const_int (Obj.magic tag)) :: args
end
open M


(*
   Class translation.
   Three subcases:
    * reapplication of a known class -> transl_class_rebind
    * class without local dependencies -> direct translation
    * with local dependencies -> generate a stubs tree,
      with a node for every local classes inherited
   A class is a 3-tuple:
    (obj_init, class_init, env)
    obj_init: creation function (unit -> params -> obj)
    class_init: inheritance function (table -> env -> obj_init)
      (one by source code)
    env: local environment

   The local environment is used for cached classes. When a
   class definition occurs under a call to Translobj.oo_wrap
   (typically inside a functor), the class creation code is
   split between a static part (depending only on toplevel names)
   and a dynamic part, the environment. The static part is cached
   in a toplevel structure, so that only the first class creation
   computes it and the subsequent classes can reuse it.
   Because of that, the (static) [class_init] function takes both
   the class table to be filled and the environment as parameters,
   and when called is given the [env] field of the class.
   For the [obj_init] part, an [env_init] function (of type [env -> obj_init])
   is stored in the cache, and called on the environment to generate
   the [obj_init] at class creation time.
*)

(*
let prerr_ids msg ids =
  let names = List.map Ident.unique_toplevel_name ids in
  prerr_endline (String.concat " " (msg :: names))
*)

let free_methods l =
  let fv = ref Ident.Set.empty in
  let rec free l =
    Lambda.iter_head_constructor free l;
    match l with
    | Lsend(Self, Lvar meth, _, _, _) ->
        fv := Ident.Set.add meth !fv
    | Lsend _ -> ()
    | Lfunction{params} ->
        List.iter (fun (param, _) -> fv := Ident.Set.remove param !fv) params
    | Llet(_, _k, id, _arg, _body)
    | Lmutlet(_k, id, _arg, _body) ->
        fv := Ident.Set.remove id !fv
    | Lletrec(decl, _body) ->
        List.iter (fun { id } -> fv := Ident.Set.remove id !fv) decl
    | Lstaticcatch(_e1, (_,vars), _e2) ->
        List.iter (fun (id, _) -> fv := Ident.Set.remove id !fv) vars
    | Ltrywith(_e1, exn, _e2) ->
        fv := Ident.Set.remove exn !fv
    | Lfor(v, _e1, _e2, _dir, _e3) ->
        fv := Ident.Set.remove v !fv
    | Lassign _
    | Lvar _ | Lmutvar _ | Lconst _ | Lapply _
    | Lprim _ | Lswitch _ | Lstringswitch _ | Lstaticraise _
    | Lifthenelse _ | Lsequence _ | Lwhile _
    | Levent _ | Lifused _ -> ()
  in free l; !fv

let transl_class ~scopes ids cl_id pub_meths cl vflag =
  let open Value_rec_types in
  (* First check if it is not only a rebind *)
  let rebind = transl_class_rebind ~scopes cl vflag in
  if rebind <> lambda_unit then rebind, Dynamic else

  (* Prepare for heavy environment handling *)
  let scopes = enter_class_definition ~scopes cl_id in
  let tables = Ident.create_local (Ident.name cl_id ^ "_tables") in
  let (top_env, req) = oo_add_class tables in
  let top = not req in
  (* The manual specifies that toplevel lets *must* be evaluated outside of the
     class *)
  let cl_env, llets = build_class_lets ~scopes cl in
  let new_ids = if top then [] else Env.diff top_env cl_env in
  let env2 = Ident.create_local "env" in
  let meth_ids = get_class_meths cl in
  let subst env lam i0 new_ids' =
    let fv = free_variables lam in
    (* prerr_ids "cl_id =" [cl_id]; prerr_ids "fv =" (Ident.Set.elements fv); *)
    let fv = List.fold_right Ident.Set.remove !new_ids' fv in
    (* We need to handle method ids specially, as they do not appear
       in the typing environment (PR#3576, PR#4560) *)
    (* very hacky: we add and remove free method ids on the fly,
       depending on the visit order... *)
    method_ids :=
      Ident.Set.diff (Ident.Set.union (free_methods lam) !method_ids) meth_ids;
    (* prerr_ids "meth_ids =" (Ident.Set.elements meth_ids);
       prerr_ids "method_ids =" (Ident.Set.elements !method_ids); *)
    let new_ids = List.fold_right Ident.Set.add new_ids !method_ids in
    let fv = Ident.Set.inter fv new_ids in
    new_ids' := !new_ids' @ Ident.Set.elements fv;
    (* prerr_ids "new_ids' =" !new_ids'; *)
    let i = ref (i0-1) in
    List.fold_left
      (fun subst id ->
        incr i; Ident.Map.add id (lfield env !i)  subst)
      Ident.Map.empty !new_ids'
  in
  let new_ids_meths = ref [] in
  let no_env_update _ _ env = env in
  let msubst arr = function
      Lfunction {kind = Curried; params = (self, Pgenval) :: args; body} ->
        let env = Ident.create_local "env" in
        let body' =
          if new_ids = [] then body else
          Lambda.subst no_env_update (subst env body 0 new_ids_meths) body in
        begin try
          (* Doesn't seem to improve size for bytecode *)
          (* if not !Clflags.native_code then raise Not_found; *)
          if not arr || !Clflags.debug then raise Not_found;
          builtin_meths [self] env env2 (lfunction args body')
        with Not_found ->
          [lfunction ((self, Pgenval) :: args)
             (if not (Ident.Set.mem env (free_variables body')) then body' else
              Llet(Alias, Pgenval, env,
                   Lprim(Pfield_computed,
                         [Lvar self; Lvar env2],
                         Loc_unknown),
                   body'))]
        end
      | _ -> assert false
  in
  let new_ids_init = ref [] in
  let env1 = Ident.create_local "env" and env1' = Ident.create_local "env'" in
  let copy_env self =
    if top then lambda_unit else
    Lifused(env2, Lprim(Psetfield_computed (Pointer, Assignment),
                        [Lvar self; Lvar env2; Lvar env1'],
                        Loc_unknown))
  and subst_env envs l lam =
    if top then lam else
    (* must be called only once! *)
    let lam = Lambda.subst no_env_update (subst env1 lam 1 new_ids_init) lam in
    Llet(Alias, Pgenval, env1, (if l = [] then Lvar envs else lfield envs 0),
    Llet(Alias, Pgenval, env1',
         (if !new_ids_init = [] then Lvar env1 else lfield env1 0),
         lam))
  in

  (* Now we start compiling the class *)
  let cla = Ident.create_local "class" in
  let (inh_init, obj_init) =
    build_object_init_0 ~scopes cla [] cl copy_env subst_env top ids in
  let inh_init' = List.rev inh_init in
  let (inh_init', cl_init) =
    build_class_init ~scopes cla true ([],[]) inh_init' obj_init msubst top cl
  in
  assert (inh_init' = []);
  let table = Ident.create_local "table"
  and class_init = Ident.create_local (Ident.name cl_id ^ "_init")
  and env_init = Ident.create_local "env_init"
  and obj_init = Ident.create_local "obj_init" in
  (* Sort methods by hash *)
  let pub_meths =
    List.sort
      (fun s s' -> compare (Btype.hash_variant s) (Btype.hash_variant s'))
      pub_meths in
  (* Check for hash conflicts *)
  let tags = List.map Btype.hash_variant pub_meths in
  let rev_map = List.combine tags pub_meths in
  List.iter2
    (fun tag name ->
      let name' = List.assoc tag rev_map in
      if name' <> name then raise(Error(cl.cl_loc, Tags(name, name'))))
    tags pub_meths;
  let ltable table lam =
    Llet(Strict, Pgenval, table,
         mkappl (oo_prim "create_table", [transl_meth_list pub_meths]), lam)
  and ldirect obj_init =
    Llet(Strict, Pgenval, obj_init, cl_init,
         Lsequence(mkappl (oo_prim "init_class", [Lvar cla]),
                   mkappl (Lvar obj_init, [lambda_unit])))
  in
  (* Simplest case: an object defined at toplevel (ids=[]) *)
  if top && ids = [] then llets (ltable cla (ldirect obj_init), Dynamic) else

  let concrete = (vflag = Concrete)
  and lclass mk_lam_and_kind =
    let cl_init, _ =
      llets (Lambda.lfunction
               ~kind:Curried
               ~attr:default_function_attribute
               ~loc:Loc_unknown
               ~return:Pgenval
               ~params:[cla, Pgenval]
               ~body:cl_init,
            Dynamic (* Placeholder, real kind is computed in [lbody] below *))
    in
    let lam, rkind = mk_lam_and_kind (free_variables cl_init) in
    Llet(Strict, Pgenval, class_init, cl_init, lam), rkind
  and lbody fv =
    if List.for_all (fun id -> not (Ident.Set.mem id fv)) ids then
      (* Not recursive: can use make_class directly *)
      mkappl (oo_prim "make_class",[transl_meth_list pub_meths;
                                    Lvar class_init]),
      Dynamic
    else
      (* Recursive: need to have an actual allocation for let rec compilation
         to work, so hardcode make_class *)
      ltable table (
      Llet(
      Strict, Pgenval, env_init, mkappl (Lvar class_init, [Lvar table]),
      Lsequence(
      mkappl (oo_prim "init_class", [Lvar table]),
      Lprim(Pmakeblock(0, Immutable, None),
            [mkappl (Lvar env_init, [lambda_unit]);
             Lvar class_init; lambda_unit],
            Loc_unknown)))),
      Static
  and lbody_virt lenvs =
    (* Virtual classes only need to provide the [class_init] and [env]
       fields. [obj_init] is filled with a dummy [lambda_unit] value. *)
    Lprim(Pmakeblock(0, Immutable, None),
          [lambda_unit; Lambda.lfunction
                          ~kind:Curried
                          ~attr:default_function_attribute
                          ~loc:Loc_unknown
                          ~return:Pgenval
                          ~params:[cla, Pgenval] ~body:cl_init;
           lenvs],
         Loc_unknown),
    Static
  in
  (* Still easy: a class defined at toplevel *)
  if top && concrete then lclass lbody else
  if top then llets (lbody_virt lambda_unit) else

  (* Now for the hard stuff: prepare for table caching *)
  let envs = Ident.create_local "envs"
  and cached = Ident.create_local "cached" in
  let lenvs =
    if !new_ids_meths = [] && !new_ids_init = [] && inh_init = []
    then lambda_unit
    else Lvar envs in
  let lenv =
    let menv =
      if !new_ids_meths = [] then lambda_unit else
      Lprim(Pmakeblock(0, Immutable, None),
            List.map (fun id -> Lvar id) !new_ids_meths,
            Loc_unknown) in
    if !new_ids_init = [] then menv else
    Lprim(Pmakeblock(0, Immutable, None),
          menv :: List.map (fun id -> Lvar id) !new_ids_init,
          Loc_unknown)
  and linh_envs =
    List.map
      (fun (_, path_lam, _) ->
        Lprim(Pfield (2, Pointer, Mutable), [path_lam], Loc_unknown))
      (List.rev inh_init)
  in
  let make_envs (lam, rkind) =
    Llet(StrictOpt, Pgenval, envs,
         (if linh_envs = [] then lenv else
         Lprim(Pmakeblock(0, Immutable, None),
               lenv :: linh_envs, Loc_unknown)),
         lam),
    rkind
  and def_ids cla lam =
    Llet(StrictOpt, Pgenval, env2,
         mkappl (oo_prim "new_variable", [Lvar cla; transl_label ""]),
         lam)
  in
  let inh_paths =
    List.filter
      (fun (path, _, _) -> List.mem (Path.head path) new_ids) inh_init
  in
  let inh_keys =
    List.map
      (fun (_, path_lam, _) ->
        Lprim(Pfield (1, Pointer, Mutable), [path_lam], Loc_unknown))
      inh_paths
  in
  let lclass lam =
    Llet(Strict, Pgenval, class_init,
         Lambda.lfunction
                   ~kind:Curried ~params:[cla, Pgenval]
                   ~return:Pgenval
                   ~attr:default_function_attribute
                   ~loc:Loc_unknown
                   ~body:(def_ids cla cl_init), lam)
  and lset cached i lam =
    Lprim(Psetfield(i, Pointer, Assignment),
          [Lvar cached; lam], Loc_unknown)
  in
  let ldirect () =
    ltable cla
      (Llet(Strict, Pgenval, env_init, def_ids cla cl_init,
            Lsequence(mkappl (oo_prim "init_class", [Lvar cla]),
                      lset cached 0 (Lvar env_init))))
  and lclass_virt () =
    lset cached 0
      (Lambda.lfunction
         ~kind:Curried
         ~attr:default_function_attribute
         ~loc:Loc_unknown
         ~return:Pgenval
         ~params:[cla, Pgenval]
         ~body:(def_ids cla cl_init))
  in
  let lupdate_cache =
    if ids = [] then ldirect () else
      if not concrete then lclass_virt () else
        lclass (
            mkappl (oo_prim "make_class_store",
                    [transl_meth_list pub_meths;
                     Lvar class_init; Lvar cached])) in
  let lcheck_cache =
    if !Clflags.native_code && !Clflags.afl_instrument then
      (* When afl-fuzz instrumentation is enabled, ignore the cache
         so that the program's behaviour does not change between runs *)
      lupdate_cache
    else
      Lifthenelse(lfield cached 0, lambda_unit, lupdate_cache) in
  let lcache (lam, rkind) =
    let lam = Lsequence (lcheck_cache, lam) in
    let lam =
      if inh_keys = []
      then Llet(Alias, Pgenval, cached, Lvar tables, lam)
      else
        Llet(Strict, Pgenval, cached,
             mkappl (oo_prim "lookup_tables",
                     [Lvar tables; Lprim(Pmakeblock(0, Immutable, None),
                                         inh_keys, Loc_unknown)]),
             lam)
    in
    lam, rkind
  in
  llets (
  lcache (
  make_envs (
  if ids = []
  then mkappl (lfield cached 0, [lenvs]), Dynamic
  else
    Lprim(Pmakeblock(0, Immutable, None),
        (if concrete then
          [mkappl (lfield cached 0, [lenvs]);
           lfield cached 1;
           lenvs]
        else [lambda_unit; lfield cached 0; lenvs]),
        Loc_unknown
       ),
    Static)))

(* Wrapper for class compilation *)
(*
    let cl_id = ci.ci_id_class in
(* TODO: cl_id is used somewhere else as typesharp ? *)
  let _arity = List.length ci.ci_params in
  let pub_meths = m in
  let cl = ci.ci_expr in
  let vflag = vf in
*)

let transl_class ~scopes ids id pub_meths cl vf =
  oo_wrap_gen cl.cl_env false (transl_class ~scopes ids id pub_meths cl) vf

let () =
  transl_object := (fun ~scopes id meths cl ->
    let lam, _rkind = transl_class ~scopes [] id meths cl Concrete in
    lam)

(* Error report *)

open Format_doc
module Style = Misc.Style

let report_error_doc ppf = function
  | Tags (lab1, lab2) ->
      fprintf ppf "Method labels %a and %a are incompatible.@ %s"
        Style.inline_code lab1
        Style.inline_code lab2
        "Change one of them."

let () =
  Location.register_error_of_exn
    (function
      | Error (loc, err) ->
        Some (Location.error_of_printer ~loc report_error_doc err)
      | _ ->
        None
    )

let report_error = Format_doc.compat report_error_doc