Skip to content

Commit

Permalink
Extract common part of per_function_env to Emitaux
Browse files Browse the repository at this point in the history
  • Loading branch information
@gretay-js
gretay-js committed Oct 30, 2019
1 parent 7177d0c commit 2e01c64
Show file tree
Hide file tree
Showing 11 changed files with 159 additions and 321 deletions.
8 changes: 8 additions & 0 deletions .depend
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2336,21 +2336,29 @@ asmcomp/emit.cmi : \
asmcomp/linear.cmi \
asmcomp/cmm.cmi
asmcomp/emitaux.cmo : \
asmcomp/emitenv_intf.cmo \
lambda/debuginfo.cmi \
utils/config.cmi \
asmcomp/cmm.cmi \
utils/clflags.cmi \
asmcomp/arch.cmo \
asmcomp/emitaux.cmi
asmcomp/emitaux.cmx : \
asmcomp/emitenv_intf.cmx \
lambda/debuginfo.cmx \
utils/config.cmx \
asmcomp/cmm.cmx \
utils/clflags.cmx \
asmcomp/arch.cmx \
asmcomp/emitaux.cmi
asmcomp/emitaux.cmi : \
asmcomp/linear.cmi \
asmcomp/emitenv_intf.cmo \
lambda/debuginfo.cmi
asmcomp/emitenv_intf.cmo : \
asmcomp/linear.cmi
asmcomp/emitenv_intf.cmx : \
asmcomp/linear.cmx
asmcomp/interf.cmo : \
asmcomp/reg.cmi \
asmcomp/proc.cmi \
Expand Down
1 change: 1 addition & 0 deletions Makefile
View file
Original file line number Diff line number Diff line change
Expand Up @@ -183,6 +183,7 @@ ASMCOMP=\
asmcomp/schedgen.cmo asmcomp/scheduling.cmo \
asmcomp/branch_relaxation_intf.cmo \
asmcomp/branch_relaxation.cmo \
asmcomp/emitenv_intf.cmo \
asmcomp/emitaux.cmo asmcomp/emit.cmo asmcomp/asmgen.cmo \
asmcomp/asmlink.cmo asmcomp/asmlibrarian.cmo asmcomp/asmpackager.cmo \
driver/opterrors.cmo driver/optcompile.cmo
Expand Down
54 changes: 13 additions & 41 deletions asmcomp/amd64/emit.mlp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -67,42 +67,14 @@ let emit_debug_info dbg =
let fp = Config.with_frame_pointers

(* Record calls to the GC -- we've moved them out of the way *)
type gc_call =
type gc_call_p =
{ gc_size: int; (* Allocation size, in bytes *)
gc_lbl: label; (* Entry label *)
gc_return_lbl: label; (* Where to branch after GC *)
gc_frame: label; (* Label of frame descriptor *)
gc_spacetime : (X86_ast.arg * int) option;
(* Spacetime node hole pointer and index *)
(* Spacetime node hole pointer and index *)
}

(* Record calls to caml_ml_array_bound_error.
In -g mode, or when using Spacetime profiling, we maintain one call to
caml_ml_array_bound_error per bound check site. Without -g, we can share
a single call. *)
type bound_error_call =
{ bd_lbl: label; (* Entry label *)
bd_frame: label; (* Label of frame descriptor *)
bd_spacetime : (X86_ast.arg * int) option;
(* As for [gc_call]. *)
}

(* Environment for emitting a function *)
type per_function_env = {
f : fundecl;
mutable stack_offset : int;
mutable call_gc_sites : gc_call list;
mutable bound_error_sites : bound_error_call list;
mutable bound_error_call : label option;
}

let mk_env f =
{
f;
stack_offset = 0;
call_gc_sites = [];
bound_error_sites = [];
bound_error_call = None;
type bound_error_call_p =
{ bd_spacetime : (X86_ast.arg * int) option; (* As for [gc_call]. *)
}

let frame_size env = (* includes return address *)
Expand Down Expand Up @@ -298,20 +270,20 @@ let spacetime_before_uninstrumented_call env ~node_ptr ~index =

let emit_call_gc env gc =
def_label gc.gc_lbl;
begin match gc.gc_spacetime with
begin match gc.gc_p.gc_spacetime with
| None -> assert (not Config.spacetime)
| Some (node_ptr, index) ->
assert Config.spacetime;
spacetime_before_uninstrumented_call env ~node_ptr ~index
end;
begin match gc.gc_size with
begin match gc.gc_p.gc_size with
| 16 -> emit_call "caml_call_gc1"
| 24 -> emit_call "caml_call_gc2"
| 32 -> emit_call "caml_call_gc3"
| n -> I.add (int n) r15;
emit_call "caml_call_gc"
end;
def_label gc.gc_frame;
def_label gc.gc_frame_lbl;
I.jmp (label gc.gc_return_lbl)

let bound_error_label env ?label dbg ~spacetime =
Expand All @@ -320,7 +292,7 @@ let bound_error_label env ?label dbg ~spacetime =
let lbl_frame = record_frame_label env ?label Reg.Set.empty false dbg in
env.bound_error_sites <-
{ bd_lbl = lbl_bound_error; bd_frame = lbl_frame;
bd_spacetime = spacetime; } :: env.bound_error_sites;
bd_p = { bd_spacetime = spacetime; } } :: env.bound_error_sites;
lbl_bound_error
end else begin
match env.bound_error_call with
Expand All @@ -333,7 +305,7 @@ let bound_error_label env ?label dbg ~spacetime =

let emit_call_bound_error env bd =
def_label bd.bd_lbl;
begin match bd.bd_spacetime with
begin match bd.bd_p.bd_spacetime with
| None -> ()
| Some (node_ptr, index) ->
spacetime_before_uninstrumented_call env ~node_ptr ~index
Expand Down Expand Up @@ -675,11 +647,11 @@ let emit_instr env fallthrough i =
else Some (arg i 0, spacetime_index)
in
env.call_gc_sites <-
{ gc_size = n;
{ gc_p = { gc_size = n; gc_spacetime; };
gc_lbl = lbl_call_gc;
gc_return_lbl = lbl_redo;
gc_frame = lbl_frame;
gc_spacetime; } :: env.call_gc_sites
gc_frame_lbl = lbl_frame;
} :: env.call_gc_sites
end else begin
if Config.spacetime then begin
spacetime_before_uninstrumented_call env ~node_ptr:(arg i 0)
Expand Down Expand Up @@ -921,7 +893,7 @@ let all_functions = ref []
(* Emission of a function declaration *)

let fundecl fundecl =
let env = mk_env fundecl in
let env = mk_env fundecl () in
all_functions := fundecl :: !all_functions;
emit_named_text_section fundecl.fun_name;
D.align 16;
Expand Down
84 changes: 21 additions & 63 deletions asmcomp/arm/emit.mlp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -52,36 +52,13 @@ let emit_reg = function
{loc = Reg r} -> emit_string (register_name r)
| _ -> fatal_error "Emit_arm.emit_reg"


(* Record calls to the GC -- we've moved them out of the way *)

type gc_call =
{ gc_lbl: label; (* Entry label *)
gc_return_lbl: label; (* Where to branch after GC *)
gc_frame: label } (* Label of frame descriptor *)

(* Record calls to caml_ml_array_bound_error.
In -g mode, we maintain one call to caml_ml_array_bound_error
per bound check site. Without -g, we can share a single call. *)

type bound_error_call =
{ bd_lbl: label; (* Entry label *)
bd_frame: label } (* Label of frame descriptor *)

(* Pending offset computations : {lbl; dst; src;} --> lbl: .word dst-(src+N) *)
type offset_computation =
{ lbl : label;
dst : label;
src : label;
}

(* Pending floating-point literals *)
type float_literal =
{
fl : int64;
lbl : label;
}

(* Pending relative references to the global offset table *)
type gotrel_literal =
{ lbl_got : label;
Expand All @@ -98,42 +75,20 @@ type symbol_literal =
type pending =
{
mutable offset_literals : offset_computation list;
mutable float_literals : float_literal list;
mutable gotrel_literals : gotrel_literal list;
mutable symbol_literals : symbol_literal list;
(* Total space (in words) occupied by pending literals *)
mutable size_literals : int;
}

(* Environment for emitting a function *)
type per_function_env = {
f : fundecl;
mutable stack_offset : int;
mutable call_gc_sites : gc_call list;
mutable bound_error_sites : bound_error_call list;
mutable bound_error_call : label option; (* unused *)
pending : pending; (* ARM specific *)
}

let mk_pending () =
{
offset_literals = [];
float_literals = [];
gotrel_literals = [];
symbol_literals = [];
size_literals = 0;
}

let mk_env f =
{
f;
stack_offset = 0;
call_gc_sites = [];
bound_error_sites = [];
bound_error_call = None;
pending = mk_pending ();
}

let frame_size env =
let sz =
env.stack_offset +
Expand Down Expand Up @@ -199,15 +154,17 @@ let record_frame env ?label live raise_ dbg =

let emit_call_gc gc =
`{emit_label gc.gc_lbl}: {emit_call "caml_call_gc"}\n`;
`{emit_label gc.gc_frame}: b {emit_label gc.gc_return_lbl}\n`
`{emit_label gc.gc_frame_lbl}: b {emit_label gc.gc_return_lbl}\n`

let bound_error_label env ?label dbg =
if !Clflags.debug || env.bound_error_sites = [] then begin
let lbl_bound_error = new_label() in
let lbl_frame = record_frame_label env ?label Reg.Set.empty false dbg in
env.bound_error_sites <-
{ bd_lbl = lbl_bound_error;
bd_frame = lbl_frame } :: env.bound_error_sites;
bd_frame = lbl_frame;
bd_p = ();
} :: env.bound_error_sites;
lbl_bound_error
end else begin
let bd = List.hd env.bound_error_sites in bd.bd_lbl
Expand Down Expand Up @@ -329,27 +286,26 @@ let output_epilogue env f =

(* Label a floating-point literal *)
let float_literal env fl =
let p = env.pending in
try
let x = List.find (fun x -> compare x.fl fl = 0) p.float_literals in
let x = List.find (fun x -> compare x.fl fl = 0) env.float_literals in
x.lbl
with Not_found ->
let lbl = new_label() in
p.size_literals <- p.size_literals + 2;
p.float_literals <- { fl; lbl } :: p.float_literals;
env.p.size_literals <- env.p.size_literals + 2;
env.float_literals <- { fl; lbl } :: env.float_literals;
lbl

(* Label a GOTREL literal *)
let gotrel_literal env lbl_pic =
let p = env.pending in
let p = env.p in
let lbl_got = new_label() in
p.size_literals <- p.size_literals + 1;
p.gotrel_literals <- { lbl_got; lbl_pic } :: p.gotrel_literals;
lbl_got

(* Label a symbol literal *)
let symbol_literal env sym =
let p = env.pending in
let p = env.p in
try
let sl = List.find (fun x -> compare x.sym sym = 0) p.symbol_literals in
sl.lbl
Expand All @@ -361,22 +317,22 @@ let symbol_literal env sym =

(* Add an offset computation *)
let offset_literal env dst src =
let p = env.pending in
let p = env.p in
let lbl = new_label() in
p.size_literals <- p.size_literals + 1;
p.offset_literals <- { lbl; dst; src; } :: p.offset_literals;
lbl

(* Emit all pending literals *)
let emit_literals env =
let p = env.pending in
if p.float_literals <> [] then begin
let p = env.p in
if env.float_literals <> [] then begin
` .align 3\n`;
List.iter
(fun {fl; lbl} ->
`{emit_label lbl}:`; emit_float64_split_directive ".long" fl)
p.float_literals;
p.float_literals <- []
env.float_literals;
env.float_literals <- []
end;
if p.symbol_literals <> [] then begin
let offset = if !thumb then 4 else 8 in
Expand Down Expand Up @@ -703,7 +659,9 @@ let emit_instr env i =
env.call_gc_sites <-
{ gc_lbl = lbl_call_gc;
gc_return_lbl = lbl_redo;
gc_frame = lbl_frame } :: env.call_gc_sites;
gc_frame_lbl = lbl_frame;
gc_p = ();
} :: env.call_gc_sites;
3 + ninstr
end else begin
let ninstr =
Expand Down Expand Up @@ -977,15 +935,15 @@ let rec emit_all env ninstr fallthrough i =
(* Make sure literals not yet emitted remain addressable,
or emit them in a new constant island. *)
(* fldd can address up to +/-1KB, ldr can address up to +/-4KB *)
let limit = (if !fpu >= VFPv2 && env.pending.float_literals <> []
let limit = (if !fpu >= VFPv2 && env.float_literals <> []
then 127
else 511) in
let limit = limit - env.pending.size_literals - max_instruction_size i in
let limit = limit - env.p.size_literals - max_instruction_size i in
let ninstr' =
if ninstr >= limit - 64 && not fallthrough then begin
emit_literals env;
0
end else if env.pending.size_literals != 0 && ninstr >= limit then begin
end else if env.p.size_literals != 0 && ninstr >= limit then begin
let lbl = new_label() in
` b {emit_label lbl}\n`;
emit_literals env;
Expand All @@ -1000,7 +958,7 @@ let rec emit_all env ninstr fallthrough i =
(* Emission of a function declaration *)

let fundecl fundecl =
let env = mk_env fundecl in
let env = mk_env fundecl (mk_pending()) in
emit_named_text_section fundecl.fun_name;
` .align 2\n`;
` .globl {emit_symbol fundecl.fun_name}\n`;
Expand Down

0 comments on commit 2e01c64

Please sign in to comment.