750 lines
27 KiB
OCaml
750 lines
27 KiB
OCaml
(***********************************************************************)
|
|
(* *)
|
|
(* 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
|
|
|
|
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_base (Const_string l))
|
|
|
|
let rec transl_meth_list lst =
|
|
if lst = [] then Lconst (Const_pointer 0) else
|
|
share (Const_block
|
|
(0, List.map (fun lab -> Const_base (Const_string 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 sure vals rem =
|
|
if create && sure && List.length vals > 1 then
|
|
let (_,id0) = List.hd vals in
|
|
let call =
|
|
Lapply(oo_prim "new_variables",
|
|
[Lvar tbl; transl_meth_list (List.map fst vals)]) in
|
|
let i = ref (List.length vals) in
|
|
Llet(Strict, id0, call,
|
|
List.fold_right
|
|
(fun (name,id) rem ->
|
|
decr i; Llet(Alias, id, Lprim(Poffsetint !i, [Lvar id0]), rem))
|
|
(List.tl vals) rem)
|
|
else
|
|
List.fold_right
|
|
(fun (name, id) rem ->
|
|
Llet(StrictOpt, id, transl_val tbl create name, rem))
|
|
vals rem
|
|
|
|
let transl_super tbl meths inh_methods rem =
|
|
List.fold_right
|
|
(fun (nm, id) rem ->
|
|
begin try
|
|
Llet(StrictOpt, id, Lapply (oo_prim "get_method",
|
|
[Lvar tbl; Lvar (Meths.find nm meths)]),
|
|
rem)
|
|
with Not_found ->
|
|
rem
|
|
end)
|
|
inh_methods rem
|
|
|
|
let create_object cl obj init =
|
|
let obj' = Ident.create "self" in
|
|
let (inh_init, obj_init) = init obj' in
|
|
if obj_init = lambda_unit then
|
|
(inh_init,
|
|
Lapply (oo_prim "create_object_and_run_initializers", [obj; Lvar cl]))
|
|
else begin
|
|
(inh_init,
|
|
Llet(Strict, obj',
|
|
Lapply (oo_prim "create_object_opt", [obj; Lvar cl]),
|
|
Lsequence(obj_init,
|
|
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) =
|
|
List.fold_right
|
|
(fun field (inh_init, obj_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)
|
|
| Cf_val (_, id, exp) ->
|
|
(inh_init, lsequence (set_inst_var obj id exp) obj_init)
|
|
| Cf_meth _ | Cf_init _ ->
|
|
(inh_init, obj_init)
|
|
| 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)))
|
|
str.cl_field
|
|
(inh_init, obj_init obj)
|
|
in
|
|
(inh_init,
|
|
List.fold_right
|
|
(fun (id, expr) rem ->
|
|
lsequence (Lifused (id, set_inst_var obj id expr)) rem)
|
|
params obj_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 public_methods lab id cl_init =
|
|
if List.mem lab public_methods then
|
|
Llet(Alias, id, Lvar (meth lab), cl_init)
|
|
else
|
|
Llet(StrictOpt, id, Lapply (oo_prim "get_method_label",
|
|
[Lvar tbl; transl_label lab]),
|
|
cl_init)
|
|
|
|
let bind_methods tbl public_methods meths cl_init =
|
|
Meths.fold (bind_method tbl public_methods) meths cl_init
|
|
|
|
let output_methods tbl vals methods lam =
|
|
let 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
|
|
in
|
|
transl_vals tbl true true vals 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 build_class_init cla pub_meths cstr 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 []),
|
|
cl_init))
|
|
| _ ->
|
|
assert false
|
|
end
|
|
| Tclass_structure str ->
|
|
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 values methods cl_init in
|
|
let inh_init, cl_init =
|
|
build_class_init cla pub_meths false inh_init
|
|
(transl_vals cla false false vals
|
|
(transl_super cla str.cl_meths meths cl_init))
|
|
msubst top cl in
|
|
(inh_init, cl_init, [], [])
|
|
| Cf_val (name, id, exp) ->
|
|
(inh_init, cl_init, methods, (name, id)::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)
|
|
(*
|
|
Lsequence(Lapply (oo_prim ("set_method" ^ builtin),
|
|
Lvar cla ::
|
|
Lvar (Meths.find name str.cl_meths) ::
|
|
met_code),
|
|
cl_init))
|
|
*)
|
|
| 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 values methods cl_init in
|
|
(inh_init, bind_methods cla pub_meths str.cl_meths cl_init)
|
|
| Tclass_fun (pat, vals, cl, _) ->
|
|
let (inh_init, cl_init) =
|
|
build_class_init cla pub_meths cstr inh_init cl_init msubst top cl
|
|
in
|
|
let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in
|
|
(inh_init, transl_vals cla true false vals cl_init)
|
|
| Tclass_apply (cl, exprs) ->
|
|
build_class_init cla pub_meths cstr inh_init cl_init msubst top cl
|
|
| Tclass_let (rec_flag, defs, vals, cl) ->
|
|
let (inh_init, cl_init) =
|
|
build_class_init cla pub_meths cstr inh_init cl_init msubst top cl
|
|
in
|
|
let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in
|
|
(inh_init, transl_vals cla true false 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 narrow_args =
|
|
[Lvar cla;
|
|
transl_meth_list vals;
|
|
transl_meth_list virt_meths;
|
|
transl_meth_list (Concr.elements 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
|
|
(inh_init,
|
|
Llet (Strict, obj_init,
|
|
Lapply(oo_prim "inherits", narrow_args @
|
|
[lpath; Lconst(Const_pointer(if top then 1 else 0))]),
|
|
cl_init))
|
|
| _ ->
|
|
let core cl_init =
|
|
build_class_init cla pub_meths true 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)
|
|
|
|
(*
|
|
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 =
|
|
match cl.cl_desc with
|
|
Tclass_ident path ->
|
|
(path, obj_init)
|
|
| Tclass_fun (pat, _, cl, partial) ->
|
|
let path, obj_init = transl_class_rebind obj_init cl 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 in
|
|
(path, transl_apply obj_init oexprs)
|
|
| Tclass_let (rec_flag, defs, vals, cl) ->
|
|
let path, obj_init = transl_class_rebind obj_init cl 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' 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 =
|
|
match cl.cl_desc with
|
|
Tclass_let (rec_flag, defs, vals, cl) ->
|
|
let path, obj_init = transl_class_rebind_0 self obj_init cl in
|
|
(path, Translcore.transl_let rec_flag defs obj_init)
|
|
| _ ->
|
|
let path, obj_init = transl_class_rebind obj_init cl in
|
|
(path, lfunction [self] obj_init)
|
|
|
|
let transl_class_rebind ids cl =
|
|
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 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 arg = Ident.create "arg"
|
|
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(Lvar n, Lvar s, []) when List.mem s self ->
|
|
"meth", [Lvar n]
|
|
| _ -> raise Not_found
|
|
in
|
|
match body with
|
|
| Llet(Alias, s', Lvar s, body) when List.mem s self ->
|
|
builtin_meths 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(Lvar n, Lvar s, [arg]) when List.mem s self ->
|
|
let s, args = conv arg in
|
|
("meth_app_"^s, Lvar n :: 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(Alias, 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 arr 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
|
|
| _ -> 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 transl_class ids cl_id arity pub_meths cl =
|
|
(* First check if it is not only a rebind *)
|
|
let rebind = transl_class_rebind ids cl 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 subst env lam i0 new_ids' =
|
|
let fv = free_variables lam in
|
|
let fv = List.fold_right IdentSet.remove !new_ids' fv in
|
|
let fv =
|
|
IdentSet.filter (fun id -> List.mem id new_ids) fv in
|
|
new_ids' := !new_ids' @ IdentSet.elements fv;
|
|
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; *)
|
|
builtin_meths arr [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', cl_init) =
|
|
build_class_init cla pub_meths true (List.rev inh_init)
|
|
obj_init msubst top cl
|
|
in
|
|
assert (inh_init' = []);
|
|
let table = Ident.create "table"
|
|
and class_init = Ident.create "class_init"
|
|
and env_init = Ident.create "env_init"
|
|
and obj_init = Ident.create "obj_init" in
|
|
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 =
|
|
ids = [] ||
|
|
Typeclass.virtual_methods (Ctype.signature_of_class_type cl.cl_type) = []
|
|
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 env_index = Ident.create "env_index"
|
|
and envs = Ident.create "envs" 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 obj_init2 = Ident.create "obj_init"
|
|
and cached = Ident.create "cached" 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]
|
|
)))))
|
|
|
|
(* Dummy for recursive modules *)
|
|
|
|
let dummy_class undef_fn =
|
|
Lprim(Pmakeblock(0, Mutable), [undef_fn; undef_fn; undef_fn; lambda_unit])
|
|
|
|
(* Wrapper for class compilation *)
|
|
|
|
let transl_class ids cl_id arity pub_meths cl =
|
|
oo_wrap cl.cl_env false (transl_class ids cl_id arity pub_meths) cl
|
|
|
|
let () =
|
|
transl_object := (fun id meths cl -> transl_class [] id 0 meths cl)
|
|
|
|
(* Error report *)
|
|
|
|
open Format
|
|
|
|
let report_error ppf = function
|
|
| Illegal_class_expr ->
|
|
fprintf ppf "This kind of class expression is not allowed"
|