New representation of closures, native-code compilation
In code that builds closures, instead of the old arity field, produce a closure information field encoding arity + position of environment.master
parent
a1f21661a4
commit
7f5a137972
|
@ -72,11 +72,22 @@ let caml_nativeint_ops = "caml_nativeint_ops"
|
|||
let caml_int32_ops = "caml_int32_ops"
|
||||
let caml_int64_ops = "caml_int64_ops"
|
||||
|
||||
let pos_arity_in_closinfo = 8 * size_addr - 8
|
||||
(* arity = the top 8 bits of the closinfo word *)
|
||||
|
||||
let closure_info ~arity ~startenv =
|
||||
assert (-128 <= arity && arity <= 127);
|
||||
assert (0 <= startenv && startenv < 1 lsl (pos_arity_in_closinfo - 1));
|
||||
Nativeint.(add (shift_left (of_int arity) pos_arity_in_closinfo)
|
||||
(add (shift_left (of_int startenv) 1)
|
||||
1n))
|
||||
|
||||
let alloc_float_header dbg = Cblockheader (float_header, dbg)
|
||||
let alloc_floatarray_header len dbg = Cblockheader (floatarray_header len, dbg)
|
||||
let alloc_closure_header sz dbg = Cblockheader (white_closure_header sz, dbg)
|
||||
let alloc_infix_header ofs dbg = Cblockheader (infix_header ofs, dbg)
|
||||
let alloc_closure_info ~arity ~startenv dbg =
|
||||
Cblockheader (closure_info ~arity ~startenv, dbg)
|
||||
let alloc_boxedint32_header dbg = Cblockheader (boxedint32_header, dbg)
|
||||
let alloc_boxedint64_header dbg = Cblockheader (boxedint64_header, dbg)
|
||||
let alloc_boxedintnat_header dbg = Cblockheader (boxedintnat_header, dbg)
|
||||
|
@ -1799,8 +1810,10 @@ let apply_function_body arity =
|
|||
(args, clos,
|
||||
if arity = 1 then app_fun clos 0 else
|
||||
Cifthenelse(
|
||||
Cop(Ccmpi Ceq, [get_field_gen Asttypes.Mutable (Cvar clos) 1 (dbg ());
|
||||
int_const (dbg ()) arity], dbg ()),
|
||||
Cop(Ccmpi Ceq, [Cop(Casr,
|
||||
[get_field_gen Asttypes.Mutable (Cvar clos) 1 (dbg());
|
||||
Cconst_int(pos_arity_in_closinfo, dbg())], dbg());
|
||||
Cconst_int(arity, dbg())], dbg()),
|
||||
dbg (),
|
||||
Cop(Capply typ_val,
|
||||
get_field_gen Asttypes.Mutable (Cvar clos) 2 (dbg ())
|
||||
|
@ -1987,7 +2000,8 @@ let rec intermediate_curry_functions arity num =
|
|||
Cop(Calloc,
|
||||
[alloc_closure_header 5 (dbg ());
|
||||
Cconst_symbol(name1 ^ "_" ^ Int.to_string (num+1), dbg ());
|
||||
int_const (dbg ()) (arity - num - 1);
|
||||
alloc_closure_info ~arity:(arity - num - 1)
|
||||
~startenv:3 (dbg ());
|
||||
Cconst_symbol(name1 ^ "_" ^ Int.to_string (num+1) ^ "_app",
|
||||
dbg ());
|
||||
Cvar arg; Cvar clos],
|
||||
|
@ -1996,7 +2010,8 @@ let rec intermediate_curry_functions arity num =
|
|||
Cop(Calloc,
|
||||
[alloc_closure_header 4 (dbg ());
|
||||
Cconst_symbol(name1 ^ "_" ^ Int.to_string (num+1), dbg ());
|
||||
int_const (dbg ()) 1; Cvar arg; Cvar clos],
|
||||
alloc_closure_info ~arity:1 ~startenv:2 (dbg ());
|
||||
Cvar arg; Cvar clos],
|
||||
dbg ());
|
||||
fun_codegen_options = [];
|
||||
fun_dbg;
|
||||
|
@ -2713,6 +2728,7 @@ let emit_constant_closure ((_, global_symb) as symb) fundecls clos_vars cont =
|
|||
assert (clos_vars = []);
|
||||
cdefine_symbol symb @ clos_vars @ cont
|
||||
| f1 :: remainder ->
|
||||
let startenv = fundecls_size fundecls in
|
||||
let rec emit_others pos = function
|
||||
[] -> clos_vars @ cont
|
||||
| (f2 : Clambda.ufunction) :: rem ->
|
||||
|
@ -2720,13 +2736,13 @@ let emit_constant_closure ((_, global_symb) as symb) fundecls clos_vars cont =
|
|||
Cint(infix_header pos) ::
|
||||
(closure_symbol f2) @
|
||||
Csymbol_address f2.label ::
|
||||
cint_const f2.arity ::
|
||||
Cint(closure_info ~arity:f2.arity ~startenv:(startenv - pos)) ::
|
||||
emit_others (pos + 3) rem
|
||||
else
|
||||
Cint(infix_header pos) ::
|
||||
(closure_symbol f2) @
|
||||
Csymbol_address(curry_function_sym f2.arity) ::
|
||||
cint_const f2.arity ::
|
||||
Cint(closure_info ~arity:f2.arity ~startenv:(startenv - pos)) ::
|
||||
Csymbol_address f2.label ::
|
||||
emit_others (pos + 4) rem in
|
||||
Cint(black_closure_header (fundecls_size fundecls
|
||||
|
@ -2735,11 +2751,11 @@ let emit_constant_closure ((_, global_symb) as symb) fundecls clos_vars cont =
|
|||
(closure_symbol f1) @
|
||||
if f1.arity = 1 || f1.arity = 0 then
|
||||
Csymbol_address f1.label ::
|
||||
cint_const f1.arity ::
|
||||
Cint(closure_info ~arity:f1.arity ~startenv) ::
|
||||
emit_others 3 remainder
|
||||
else
|
||||
Csymbol_address(curry_function_sym f1.arity) ::
|
||||
cint_const f1.arity ::
|
||||
Cint(closure_info ~arity:f1.arity ~startenv) ::
|
||||
Csymbol_address f1.label ::
|
||||
emit_others 4 remainder
|
||||
|
||||
|
|
|
@ -64,11 +64,16 @@ val boxedint32_header : nativeint
|
|||
val boxedint64_header : nativeint
|
||||
val boxedintnat_header : nativeint
|
||||
|
||||
(** Closure info for a closure of given arity and distance to environment *)
|
||||
val closure_info : arity:int -> startenv:int -> nativeint
|
||||
|
||||
(** Wrappers *)
|
||||
val alloc_float_header : Debuginfo.t -> expression
|
||||
val alloc_floatarray_header : int -> Debuginfo.t -> expression
|
||||
val alloc_closure_header : int -> Debuginfo.t -> expression
|
||||
val alloc_infix_header : int -> Debuginfo.t -> expression
|
||||
val alloc_closure_info :
|
||||
arity:int -> startenv:int -> Debuginfo.t -> expression
|
||||
val alloc_boxedint32_header : Debuginfo.t -> expression
|
||||
val alloc_boxedint64_header : Debuginfo.t -> expression
|
||||
val alloc_boxedintnat_header : Debuginfo.t -> expression
|
||||
|
|
|
@ -373,6 +373,7 @@ let rec transl env e =
|
|||
in
|
||||
Cconst_symbol (sym, dbg)
|
||||
| Uclosure(fundecls, clos_vars) ->
|
||||
let startenv = fundecls_size fundecls in
|
||||
let rec transl_fundecls pos = function
|
||||
[] ->
|
||||
List.map (transl env) clos_vars
|
||||
|
@ -382,16 +383,19 @@ let rec transl env e =
|
|||
let without_header =
|
||||
if f.arity = 1 || f.arity = 0 then
|
||||
Cconst_symbol (f.label, dbg) ::
|
||||
int_const dbg f.arity ::
|
||||
alloc_closure_info ~arity:f.arity
|
||||
~startenv:(startenv - pos) dbg ::
|
||||
transl_fundecls (pos + 3) rem
|
||||
else
|
||||
Cconst_symbol (curry_function_sym f.arity, dbg) ::
|
||||
int_const dbg f.arity ::
|
||||
alloc_closure_info ~arity:f.arity
|
||||
~startenv:(startenv - pos) dbg ::
|
||||
Cconst_symbol (f.label, dbg) ::
|
||||
transl_fundecls (pos + 4) rem
|
||||
in
|
||||
if pos = 0 then without_header
|
||||
else (alloc_infix_header pos f.dbg) :: without_header
|
||||
if pos = 0
|
||||
then without_header
|
||||
else alloc_infix_header pos f.dbg :: without_header
|
||||
in
|
||||
let dbg =
|
||||
match fundecls with
|
||||
|
|
Loading…
Reference in New Issue