(***********************************************************************) (* *) (* Objective Caml *) (* *) (* 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 Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Misc open Asttypes open Types open Typedtree open Lambda open Translobj open Translcore (* XXX Rajouter des evenements... *) type error = Illegal_class_expr | Tags of label * label exception Error of Location.t * error let lfunction params body = if params = [] then body else match body with Lfunction (Curried, params', body') -> Lfunction (Curried, params @ params', body') | _ -> Lfunction (Curried, params, body) let lapply func args = match func with Lapply(func', args') -> Lapply(func', args' @ args) | _ -> Lapply(func, args) let lsequence l1 l2 = if l2 = lambda_unit then l1 else Lsequence(l1, l2) let lfield v i = Lprim(Pfield i, [Lvar v]) let transl_label l = share (Const_immstring l) let rec transl_meth_list lst = if lst = [] then Lconst (Const_pointer 0) else share (Const_block (0, List.map (fun lab -> Const_immstring lab) lst)) let set_inst_var obj id expr = let kind = if Typeopt.maybe_pointer expr then Paddrarray else Pintarray in Lprim(Parraysetu kind, [Lvar obj; Lvar id; transl_exp expr]) let copy_inst_var obj id expr templ offset = let kind = if Typeopt.maybe_pointer expr then Paddrarray else Pintarray in let id' = Ident.create (Ident.name id) in Llet(Strict, id', Lprim (Pidentity, [Lvar id]), Lprim(Parraysetu kind, [Lvar obj; Lvar id'; Lprim(Parrayrefu kind, [Lvar templ; Lprim(Paddint, [Lvar id'; Lvar offset])])])) let transl_val tbl create name = Lapply (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, 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, Lapply(oo_prim "get_method", [Lvar tbl; Lvar (Meths.find nm meths)])) :: rem with Not_found -> rem) inh_meths [] let bind_super tbl (vals, meths) cl_init = transl_vals tbl false StrictOpt vals (List.fold_right (fun (nm, id, def) rem -> Llet(StrictOpt, id, def, rem)) meths cl_init) let create_object cl obj init = let obj' = Ident.create "self" in let (inh_init, obj_init, has_init) = init obj' in if obj_init = lambda_unit then (inh_init, Lapply (oo_prim (if has_init then "create_object_and_run_initializers" else"create_object_opt"), [obj; Lvar cl])) else begin (inh_init, Llet(Strict, obj', Lapply (oo_prim "create_object_opt", [obj; Lvar cl]), Lsequence(obj_init, if not has_init then Lvar obj' else Lapply (oo_prim "run_initializers_opt", [obj; Lvar obj'; Lvar cl])))) end let rec build_object_init cl_table obj params inh_init obj_init cl = match cl.cl_desc with Tclass_ident path -> let obj_init = Ident.create "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), [Lvar envs])] in ((envs, (obj_init, path)::inh_init), Lapply(Lvar obj_init, env @ [obj])) | Tclass_structure str -> create_object cl_table obj (fun obj -> let (inh_init, obj_init, has_init) = List.fold_right (fun field (inh_init, obj_init, has_init) -> match field with Cf_inher (cl, _, _) -> let (inh_init, obj_init') = build_object_init cl_table (Lvar obj) [] inh_init (fun _ -> lambda_unit) cl in (inh_init, lsequence obj_init' obj_init, true) | Cf_val (_, id, Some exp, _) -> (inh_init, lsequence (set_inst_var obj id exp) obj_init, has_init) | Cf_meth _ | Cf_val _ -> (inh_init, obj_init, has_init) | Cf_init _ -> (inh_init, obj_init, true) | Cf_let (rec_flag, defs, vals) -> (inh_init, Translcore.transl_let rec_flag defs (List.fold_right (fun (id, expr) rem -> lsequence (Lifused(id, set_inst_var obj id expr)) rem) vals obj_init), has_init)) str.cl_field (inh_init, obj_init obj, false) in (inh_init, List.fold_right (fun (id, expr) rem -> lsequence (Lifused (id, set_inst_var obj id expr)) rem) params obj_init, has_init)) | Tclass_fun (pat, vals, cl, partial) -> let (inh_init, obj_init) = build_object_init cl_table obj (vals @ params) inh_init obj_init cl in (inh_init, let build params rem = let param = name_pattern "param" [pat, ()] in Lfunction (Curried, param::params, Matching.for_function pat.pat_loc None (Lvar param) [pat, rem] partial) in begin match obj_init with Lfunction (Curried, params, rem) -> build params rem | rem -> build [] rem end) | Tclass_apply (cl, oexprs) -> let (inh_init, obj_init) = build_object_init cl_table obj params inh_init obj_init cl in (inh_init, transl_apply obj_init oexprs) | Tclass_let (rec_flag, defs, vals, cl) -> let (inh_init, obj_init) = build_object_init cl_table obj (vals @ params) inh_init obj_init cl in (inh_init, Translcore.transl_let rec_flag defs obj_init) | Tclass_constraint (cl, vals, pub_meths, concr_meths) -> build_object_init cl_table obj params inh_init obj_init cl let rec build_object_init_0 cl_table params cl copy_env subst_env top ids = match cl.cl_desc with Tclass_let (rec_flag, defs, vals, cl) -> build_object_init_0 cl_table (vals@params) cl copy_env subst_env top ids | _ -> let self = Ident.create "self" in let env = Ident.create "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 cl_table obj params (envs,[]) (copy_env env) cl in let obj_init = if ids = [] then obj_init else lfunction [self] obj_init in (inh_init, lfunction [env] (subst_env env inh_init obj_init)) let bind_method tbl lab id cl_init = Llet(Strict, id, Lapply (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 "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, ids, Lapply (oo_prim getter, [Lvar tbl; transl_meth_list (List.map fst methl)] @ names), List.fold_right (fun (lab,id) lam -> decr i; Llet(StrictOpt, id, lfield ids !i, lam)) (methl @ vals) cl_init) let output_methods tbl methods lam = match methods with [] -> lam | [lab; code] -> lsequence (Lapply(oo_prim "set_method", [Lvar tbl; lab; code])) lam | _ -> lsequence (Lapply(oo_prim "set_methods", [Lvar tbl; Lprim(Pmakeblock(0,Immutable), methods)])) lam let rec ignore_cstrs cl = match cl.cl_desc with Tclass_constraint (cl, _, _, _) -> ignore_cstrs cl | Tclass_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) let rec build_class_init cla cstr super inh_init cl_init msubst top cl = match cl.cl_desc with Tclass_ident path -> begin match inh_init with (obj_init, path')::inh_init -> let lpath = transl_path path in (inh_init, Llet (Strict, obj_init, Lapply(Lprim(Pfield 1, [lpath]), Lvar cla :: if top then [Lprim(Pfield 3, [lpath])] else []), bind_super cla super cl_init)) | _ -> assert false end | Tclass_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 with Cf_inher (cl, vals, meths) -> let cl_init = output_methods cla methods cl_init in let inh_init, cl_init = build_class_init cla false (vals, meths_super cla str.cl_meths meths) inh_init cl_init msubst top cl in (inh_init, cl_init, [], values) | Cf_val (name, id, exp, over) -> let values = if over then values else (name, id) :: values in (inh_init, cl_init, methods, values) | Cf_meth (name, exp) -> let met_code = msubst true (transl_exp 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 ("method_" ^ name) in [Llet(Strict, met, List.hd met_code, Lvar met)] else met_code in (inh_init, cl_init, Lvar (Meths.find name str.cl_meths) :: met_code @ methods, values) | Cf_let (rec_flag, defs, vals) -> let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in (inh_init, cl_init, methods, vals @ values) | Cf_init exp -> (inh_init, Lsequence(Lapply (oo_prim "add_initializer", Lvar cla :: msubst false (transl_exp exp)), cl_init), methods, values)) str.cl_field (inh_init, cl_init, [], []) in let cl_init = output_methods cla methods cl_init in (inh_init, bind_methods cla str.cl_meths values cl_init) | Tclass_fun (pat, vals, cl, _) -> let (inh_init, cl_init) = build_class_init cla cstr super inh_init cl_init msubst top cl in let vals = List.map bind_id_as_val vals in (inh_init, transl_vals cla true StrictOpt vals cl_init) | Tclass_apply (cl, exprs) -> build_class_init cla cstr super inh_init cl_init msubst top cl | Tclass_let (rec_flag, defs, vals, cl) -> let (inh_init, cl_init) = build_class_init cla cstr super inh_init cl_init msubst top cl in let vals = List.map bind_id_as_val vals in (inh_init, transl_vals cla true StrictOpt vals cl_init) | Tclass_constraint (cl, vals, meths, concr_meths) -> let virt_meths = List.filter (fun lab -> not (Concr.mem lab concr_meths)) meths in let concr_meths = Concr.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 Tclass_ident path, (obj_init, path')::inh_init -> assert (Path.same path path'); let lpath = transl_path path in let inh = Ident.create "inh" and ofs = List.length vals + 1 and valids, methids = super in let cl_init = List.fold_left (fun init (nm, id, _) -> Llet(StrictOpt, 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, id, lfield inh (index nm vals + 1), init)) cl_init valids in (inh_init, Llet (Strict, inh, Lapply(oo_prim "inherits", narrow_args @ [lpath; Lconst(Const_pointer(if top then 1 else 0))]), Llet(StrictOpt, obj_init, lfield inh 0, cl_init))) | _ -> let core cl_init = build_class_init cla true super inh_init cl_init msubst top cl in if cstr then core cl_init else let (inh_init, cl_init) = core (Lsequence (Lapply (oo_prim "widen", [Lvar cla]), cl_init)) in (inh_init, Lsequence(Lapply (oo_prim "narrow", narrow_args), cl_init)) end let rec build_class_lets cl = match cl.cl_desc with Tclass_let (rec_flag, defs, vals, cl) -> let env, wrap = build_class_lets cl in (env, fun x -> Translcore.transl_let rec_flag defs (wrap x)) | _ -> (cl.cl_env, fun x -> x) let rec get_class_meths cl = match cl.cl_desc with Tclass_structure cl -> Meths.fold (fun _ -> IdentSet.add) cl.cl_meths IdentSet.empty | Tclass_ident _ -> IdentSet.empty | Tclass_fun (_, _, cl, _) | Tclass_let (_, _, _, cl) | Tclass_apply (cl, _) | Tclass_constraint (cl, _, _, _) -> get_class_meths cl (* XXX Il devrait etre peu couteux d'ecrire des classes : class c x y = d e f *) let rec transl_class_rebind obj_init cl vf = match cl.cl_desc with Tclass_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; (path, obj_init) | Tclass_fun (pat, _, cl, partial) -> let path, obj_init = transl_class_rebind obj_init cl vf in let build params rem = let param = name_pattern "param" [pat, ()] in Lfunction (Curried, param::params, Matching.for_function pat.pat_loc None (Lvar param) [pat, rem] partial) in (path, match obj_init with Lfunction (Curried, params, rem) -> build params rem | rem -> build [] rem) | Tclass_apply (cl, oexprs) -> let path, obj_init = transl_class_rebind obj_init cl vf in (path, transl_apply obj_init oexprs) | Tclass_let (rec_flag, defs, vals, cl) -> let path, obj_init = transl_class_rebind obj_init cl vf in (path, Translcore.transl_let rec_flag defs obj_init) | Tclass_structure _ -> raise Exit | Tclass_constraint (cl', _, _, _) -> let path, obj_init = transl_class_rebind obj_init cl' vf in let rec check_constraint = function Tcty_constr(path', _, _) when Path.same path path' -> () | Tcty_fun (_, _, cty) -> check_constraint cty | _ -> raise Exit in check_constraint cl.cl_type; (path, obj_init) let rec transl_class_rebind_0 self obj_init cl vf = match cl.cl_desc with Tclass_let (rec_flag, defs, vals, cl) -> let path, obj_init = transl_class_rebind_0 self obj_init cl vf in (path, Translcore.transl_let rec_flag defs obj_init) | _ -> let path, obj_init = transl_class_rebind obj_init cl vf in (path, lfunction [self] obj_init) let transl_class_rebind ids cl vf = try let obj_init = Ident.create "obj_init" and self = Ident.create "self" in let obj_init0 = lapply (Lvar obj_init) [Lvar self] in let path, obj_init' = transl_class_rebind_0 self obj_init0 cl vf in if not (Translcore.check_recursive_lambda ids obj_init') then raise(Error(cl.cl_loc, Illegal_class_expr)); let id = (obj_init' = lfunction [self] obj_init0) in if id then transl_path path else let cla = Ident.create "class" and new_init = Ident.create "new_init" and env_init = Ident.create "env_init" and table = Ident.create "table" and envs = Ident.create "envs" in Llet( Strict, new_init, lfunction [obj_init] obj_init', Llet( Alias, cla, transl_path path, Lprim(Pmakeblock(0, Immutable), [Lapply(Lvar new_init, [lfield cla 0]); lfunction [table] (Llet(Strict, env_init, Lapply(lfield cla 1, [Lvar table]), lfunction [envs] (Lapply(Lvar new_init, [Lapply(Lvar env_init, [Lvar envs])])))); lfield cla 2; lfield cla 3]))) with Exit -> lambda_unit (* Rewrite a closure using builtins. Improves native code size. *) let rec module_path = function Lvar id -> let s = Ident.name id in s <> "" && s.[0] >= 'A' && s.[0] <= 'Z' | Lprim(Pfield _, [p]) -> module_path p | Lprim(Pgetglobal _, []) -> true | _ -> false let const_path local = function Lvar id -> not (List.mem id local) | Lconst _ -> true | Lfunction (Curried, _, body) -> let fv = free_variables body in List.for_all (fun x -> not (IdentSet.mem x fv)) local | p -> module_path p 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_pointer n)] | Lsend(Self, met, Lvar s, []) when List.mem s self -> "meth", [met] | _ -> raise Not_found in match body with | Llet(_, s', Lvar s, body) when List.mem s self -> builtin_meths (s'::self) env env2 body | Lapply(f, [arg]) when const_path f -> let s, args = conv arg in ("app_"^s, f :: args) | Lapply(f, [arg; p]) when const_path f && const_path p -> let s, args = conv arg in ("app_"^s^"_const", f :: args @ [p]) | Lapply(f, [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 (Curried, [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(_, 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 [Lapply(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_pointer(Obj.magic tag)) :: args end open M (* Traduction d'une classe. Plusieurs cas: * reapplication d'une classe connue -> transl_class_rebind * classe sans dependances locales -> traduction directe * avec dependances locale -> creation d'un arbre de stubs, avec un noeud pour chaque classe locale heritee Une classe est un 4-uplet: (obj_init, class_init, env_init, env) obj_init: fonction de creation d'objet (unit -> obj) class_init: fonction d'heritage (table -> env_init) (une seule par code source) env_init: parametrage par l'environnement local (env -> params -> obj_init) (une par combinaison de class_init herites) env: environnement local Si ids=0 (objet immediat), alors on ne conserve que env_init. *) let prerr_ids msg ids = let names = List.map Ident.unique_toplevel_name ids in prerr_endline (String.concat " " (msg :: names)) let transl_class ids cl_id arity pub_meths cl vflag = (* First check if it is not only a rebind *) let rebind = transl_class_rebind ids cl vflag in if rebind <> lambda_unit then rebind else (* Prepare for heavy environment handling *) let tables = Ident.create (Ident.name cl_id ^ "_tables") in let (top_env, req) = oo_add_class tables in let top = not req in let cl_env, llets = build_class_lets cl in let new_ids = if top then [] else Env.diff top_env cl_env in let env2 = Ident.create "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 =" (IdentSet.elements fv); *) let fv = List.fold_right IdentSet.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 := IdentSet.diff (IdentSet.union (free_methods lam) !method_ids) meth_ids; (* prerr_ids "meth_ids =" (IdentSet.elements meth_ids); prerr_ids "method_ids =" (IdentSet.elements !method_ids); *) let new_ids = List.fold_right IdentSet.add new_ids !method_ids in let fv = IdentSet.inter fv new_ids in new_ids' := !new_ids' @ IdentSet.elements fv; (* prerr_ids "new_ids' =" !new_ids'; *) let i = ref (i0-1) in List.fold_left (fun subst id -> incr i; Ident.add id (lfield env !i) subst) Ident.empty !new_ids' in let new_ids_meths = ref [] in let msubst arr = function Lfunction (Curried, self :: args, body) -> let env = Ident.create "env" in let body' = if new_ids = [] then body else subst_lambda (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 :: args) (if not (IdentSet.mem env (free_variables body')) then body' else Llet(Alias, env, Lprim(Parrayrefu Paddrarray, [Lvar self; Lvar env2]), body'))] end | _ -> assert false in let new_ids_init = ref [] in let env1 = Ident.create "env" and env1' = Ident.create "env'" in let copy_env envs self = if top then lambda_unit else Lifused(env2, Lprim(Parraysetu Paddrarray, [Lvar self; Lvar env2; Lvar env1'])) and subst_env envs l lam = if top then lam else (* must be called only once! *) let lam = subst_lambda (subst env1 lam 1 new_ids_init) lam in Llet(Alias, env1, (if l = [] then Lvar envs else lfield envs 0), Llet(Alias, env1', (if !new_ids_init = [] then Lvar env1 else lfield env1 0), lam)) in (* Now we start compiling the class *) let cla = Ident.create "class" in let (inh_init, obj_init) = build_object_init_0 cla [] cl copy_env subst_env top ids in if not (Translcore.check_recursive_lambda ids obj_init) then raise(Error(cl.cl_loc, Illegal_class_expr)); let inh_init' = List.rev inh_init in let (inh_init', cl_init) = build_class_init cla true ([],[]) inh_init' obj_init msubst top cl in assert (inh_init' = []); let table = Ident.create "table" and class_init = Ident.create (Ident.name cl_id ^ "_init") and env_init = Ident.create "env_init" and obj_init = Ident.create "obj_init" in let pub_meths = List.sort (fun s s' -> compare (Btype.hash_variant s) (Btype.hash_variant s')) pub_meths in 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, table, Lapply (oo_prim "create_table", [transl_meth_list pub_meths]), lam) and ldirect obj_init = Llet(Strict, obj_init, cl_init, Lsequence(Lapply (oo_prim "init_class", [Lvar cla]), Lapply(Lvar obj_init, [lambda_unit]))) in (* Simplest case: an object defined at toplevel (ids=[]) *) if top && ids = [] then llets (ltable cla (ldirect obj_init)) else let concrete = (vflag = Concrete) and lclass lam = let cl_init = llets (Lfunction(Curried, [cla], cl_init)) in Llet(Strict, class_init, cl_init, lam (free_variables cl_init)) and lbody fv = if List.for_all (fun id -> not (IdentSet.mem id fv)) ids then Lapply (oo_prim "make_class",[transl_meth_list pub_meths; Lvar class_init]) else ltable table ( Llet( Strict, env_init, Lapply(Lvar class_init, [Lvar table]), Lsequence( Lapply (oo_prim "init_class", [Lvar table]), Lprim(Pmakeblock(0, Immutable), [Lapply(Lvar env_init, [lambda_unit]); Lvar class_init; Lvar env_init; lambda_unit])))) and lbody_virt lenvs = Lprim(Pmakeblock(0, Immutable), [lambda_unit; Lfunction(Curried,[cla], cl_init); lambda_unit; lenvs]) 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 cacheing *) let envs = Ident.create "envs" and cached = Ident.create "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), List.map (fun id -> Lvar id) !new_ids_meths) in if !new_ids_init = [] then menv else Lprim(Pmakeblock(0, Immutable), menv :: List.map (fun id -> Lvar id) !new_ids_init) and linh_envs = List.map (fun (_, p) -> Lprim(Pfield 3, [transl_path p])) (List.rev inh_init) in let make_envs lam = Llet(StrictOpt, envs, (if linh_envs = [] then lenv else Lprim(Pmakeblock(0, Immutable), lenv :: linh_envs)), lam) and def_ids cla lam = Llet(StrictOpt, env2, Lapply (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 (_,p) -> Lprim(Pfield 1, [transl_path p])) inh_paths in let lclass lam = Llet(Strict, class_init, Lfunction(Curried, [cla], def_ids cla cl_init), lam) and lcache lam = if inh_keys = [] then Llet(Alias, cached, Lvar tables, lam) else Llet(Strict, cached, Lapply(oo_prim "lookup_tables", [Lvar tables; Lprim(Pmakeblock(0, Immutable), inh_keys)]), lam) and lset cached i lam = Lprim(Psetfield(i, true), [Lvar cached; lam]) in let ldirect () = ltable cla (Llet(Strict, env_init, def_ids cla cl_init, Lsequence(Lapply (oo_prim "init_class", [Lvar cla]), lset cached 0 (Lvar env_init)))) and lclass_virt () = lset cached 0 (Lfunction(Curried, [cla], def_ids cla cl_init)) in llets ( lcache ( Lsequence( Lifthenelse(lfield cached 0, lambda_unit, if ids = [] then ldirect () else if not concrete then lclass_virt () else lclass ( Lapply (oo_prim "make_class_store", [transl_meth_list pub_meths; Lvar class_init; Lvar cached]))), make_envs ( if ids = [] then Lapply(lfield cached 0, [lenvs]) else Lprim(Pmakeblock(0, Immutable), if concrete then [Lapply(lfield cached 0, [lenvs]); lfield cached 1; lfield cached 0; lenvs] else [lambda_unit; lfield cached 0; lambda_unit; lenvs] ))))) (* Wrapper for class compilation *) let transl_class ids cl_id arity pub_meths cl vf = oo_wrap cl.cl_env false (transl_class ids cl_id arity pub_meths cl) vf let () = transl_object := (fun id meths cl -> transl_class [] id 0 meths cl Concrete) (* Error report *) open Format let report_error ppf = function | Illegal_class_expr -> fprintf ppf "This kind of class expression is not allowed" | Tags (lab1, lab2) -> fprintf ppf "Method labels `%s' and `%s' are incompatible.@ %s" lab1 lab2 "Change one of them."