Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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
Xavier Leroy 2020-06-05 17:46:58 +02:00
parent a1f21661a4
commit 7f5a137972
3 changed files with 37 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
asmcomp/cmm_helpers.ml
View File

@ -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

5
asmcomp/cmm_helpers.mli
View File

@ -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

12
asmcomp/cmmgen.ml
View File

@ -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