PR#5487: addition of CFI directives and a few filename/linenumber info to generated amd64 and i386 assembly files.

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@12179 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Xavier Leroy 2012-02-21 17:41:02 +00:00
parent fd515e3a16
commit 2eecf2d4c0
40 changed files with 347 additions and 85 deletions

View File

@ -505,6 +505,7 @@ asmcomp/linearize.cmi: asmcomp/reg.cmi asmcomp/mach.cmi asmcomp/debuginfo.cmi
asmcomp/liveness.cmi: asmcomp/mach.cmi
asmcomp/mach.cmi: asmcomp/reg.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \
asmcomp/arch.cmo
asmcomp/printclambda.cmi: asmcomp/clambda.cmi
asmcomp/printcmm.cmi: asmcomp/cmm.cmi
asmcomp/printlinear.cmi: asmcomp/linearize.cmi
asmcomp/printmach.cmi: asmcomp/reg.cmi asmcomp/mach.cmi
@ -655,6 +656,12 @@ asmcomp/mach.cmo: asmcomp/reg.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \
asmcomp/arch.cmo asmcomp/mach.cmi
asmcomp/mach.cmx: asmcomp/reg.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx \
asmcomp/arch.cmx asmcomp/mach.cmi
asmcomp/printclambda.cmo: bytecomp/printlambda.cmi bytecomp/lambda.cmi \
typing/ident.cmi asmcomp/debuginfo.cmi asmcomp/clambda.cmi \
parsing/asttypes.cmi asmcomp/printclambda.cmi
asmcomp/printclambda.cmx: bytecomp/printlambda.cmx bytecomp/lambda.cmx \
typing/ident.cmx asmcomp/debuginfo.cmx asmcomp/clambda.cmx \
parsing/asttypes.cmi asmcomp/printclambda.cmi
asmcomp/printcmm.cmo: typing/ident.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \
asmcomp/printcmm.cmi
asmcomp/printcmm.cmx: typing/ident.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx \

View File

@ -30,6 +30,10 @@ Native-code compiler:
savings of 28%.
. Added support for position-independent code, natdynlink, profiling and
exception backtraces.
- In -g mode, generation of CFI information and a few filename/line
number debugging annotations, enabling in particular precise stack
backtraces with the gdb debugger. Currently supported for x86 32-bits
and 64-bits only. (PR#5487)
Standard library:
- Added float functions "hypot" and "copysign" (PR#3806, PR#4752, PR#5246)

View File

@ -74,7 +74,7 @@ BYTECOMP=bytecomp/meta.cmo bytecomp/instruct.cmo bytecomp/bytegen.cmo \
ASMCOMP=asmcomp/arch.cmo asmcomp/debuginfo.cmo \
asmcomp/cmm.cmo asmcomp/printcmm.cmo \
asmcomp/reg.cmo asmcomp/mach.cmo asmcomp/proc.cmo \
asmcomp/clambda.cmo asmcomp/compilenv.cmo \
asmcomp/clambda.cmo asmcomp/printclambda.cmo asmcomp/compilenv.cmo \
asmcomp/closure.cmo asmcomp/cmmgen.cmo \
asmcomp/printmach.cmo asmcomp/selectgen.cmo asmcomp/selection.cmo \
asmcomp/comballoc.cmo asmcomp/liveness.cmo \
@ -397,6 +397,7 @@ utils/config.ml: utils/config.mlp config/Makefile
-e 's|%%EXT_DLL%%|.so|' \
-e 's|%%SYSTHREAD_SUPPORT%%|$(SYSTHREAD_SUPPORT)|' \
-e 's|%%ASM%%|$(ASM)|' \
-e 's|%%ASM_CFI_SUPPORTED%%|$(ASM_CFI_SUPPORTED)|' \
-e 's|%%MKDLL%%|$(MKDLL)|' \
-e 's|%%MKEXE%%|$(MKEXE)|' \
-e 's|%%MKMAINDLL%%|$(MKMAINDLL)|' \

View File

@ -317,11 +317,17 @@ let emit_float_test cmp neg arg lbl =
(* Deallocate the stack frame before a return or tail call *)
let output_epilogue () =
let output_epilogue f =
if frame_required() then begin
let n = frame_size() - 8 in
` addq ${emit_int n}, %rsp\n`
` addq ${emit_int n}, %rsp\n`;
cfi_adjust_cfa_offset (-n);
f ();
(* reset CFA back cause function body may continue *)
cfi_adjust_cfa_offset n
end
else
f ()
(* Output the assembly code for an instruction *)
@ -332,7 +338,9 @@ let tailrec_entry_point = ref 0
let float_constants = ref ([] : (int * string) list)
(* Emit an instruction *)
let emit_instr fallthrough i =
emit_debug_info i.dbg;
match i.desc with
Lend -> ()
| Lop(Imove | Ispill | Ireload) ->
@ -373,14 +381,16 @@ let emit_instr fallthrough i =
` {emit_call s}\n`;
record_frame i.live i.dbg
| Lop(Itailcall_ind) ->
output_epilogue();
output_epilogue begin fun () ->
` jmp *{emit_reg i.arg.(0)}\n`
end
| Lop(Itailcall_imm s) ->
if s = !function_name then
` jmp {emit_label !tailrec_entry_point}\n`
else begin
output_epilogue();
output_epilogue begin fun () ->
` {emit_jump s}\n`
end
end
| Lop(Iextcall(s, alloc)) ->
if alloc then begin
@ -394,6 +404,7 @@ let emit_instr fallthrough i =
if n < 0
then ` addq ${emit_int(-n)}, %rsp\n`
else ` subq ${emit_int(n)}, %rsp\n`;
cfi_adjust_cfa_offset n;
stack_offset := !stack_offset + n
| Lop(Iload(chunk, addr)) ->
let dest = i.res.(0) in
@ -536,8 +547,9 @@ let emit_instr fallthrough i =
| Lreloadretaddr ->
()
| Lreturn ->
output_epilogue();
output_epilogue begin fun () ->
` ret\n`
end
| Llabel lbl ->
`{emit_Llabel fallthrough lbl}:\n`
| Lbranch lbl ->
@ -616,12 +628,16 @@ let emit_instr fallthrough i =
| Lsetuptrap lbl ->
` call {emit_label lbl}\n`
| Lpushtrap ->
cfi_adjust_cfa_offset 8;
` pushq %r14\n`;
cfi_adjust_cfa_offset 8;
` movq %rsp, %r14\n`;
stack_offset := !stack_offset + 16
| Lpoptrap ->
` popq %r14\n`;
cfi_adjust_cfa_offset (-8);
` addq $8, %rsp\n`;
cfi_adjust_cfa_offset (-8);
stack_offset := !stack_offset - 16
| Lraise ->
if !Clflags.debug then begin
@ -685,15 +701,19 @@ let fundecl fundecl =
else
` .globl {emit_symbol fundecl.fun_name}\n`;
`{emit_symbol fundecl.fun_name}:\n`;
emit_debug_info fundecl.fun_dbg;
cfi_startproc ();
if !Clflags.gprofile then emit_profile();
if frame_required() then begin
let n = frame_size() - 8 in
` subq ${emit_int n}, %rsp\n`
` subq ${emit_int n}, %rsp\n`;
cfi_adjust_cfa_offset n;
end;
`{emit_label !tailrec_entry_point}:\n`;
emit_all true fundecl.fun_body;
List.iter emit_call_gc !call_gc_sites;
emit_call_bound_errors ();
cfi_endproc ();
begin match Config.system with
"linux" | "gnu" ->
` .type {emit_symbol fundecl.fun_name},@function\n`;

View File

@ -25,8 +25,7 @@ type ulambda =
| Uconst of structured_constant * string option
| Udirect_apply of function_label * ulambda list * Debuginfo.t
| Ugeneric_apply of ulambda * ulambda list * Debuginfo.t
| Uclosure of (function_label * int * Ident.t list * ulambda) list
* ulambda list
| Uclosure of ufunction list * ulambda list
| Uoffset of ulambda * int
| Ulet of Ident.t * ulambda * ulambda
| Uletrec of (Ident.t * ulambda) list * ulambda
@ -42,6 +41,14 @@ type ulambda =
| Uassign of Ident.t * ulambda
| Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t
and ufunction = {
label : function_label;
arity : int;
params : Ident.t list;
body : ulambda;
dbg : Debuginfo.t
}
and ulambda_switch =
{ us_index_consts: int array;
us_actions_consts : ulambda array;

View File

@ -25,8 +25,7 @@ type ulambda =
| Uconst of structured_constant * string option
| Udirect_apply of function_label * ulambda list * Debuginfo.t
| Ugeneric_apply of ulambda * ulambda list * Debuginfo.t
| Uclosure of (function_label * int * Ident.t list * ulambda) list
* ulambda list
| Uclosure of ufunction list * ulambda list
| Uoffset of ulambda * int
| Ulet of Ident.t * ulambda * ulambda
| Uletrec of (Ident.t * ulambda) list * ulambda
@ -42,6 +41,14 @@ type ulambda =
| Uassign of Ident.t * ulambda
| Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t
and ufunction = {
label : function_label;
arity : int;
params : Ident.t list;
body : ulambda;
dbg : Debuginfo.t;
}
and ulambda_switch =
{ us_index_consts: int array;
us_actions_consts: ulambda array;

View File

@ -748,6 +748,9 @@ and close_functions fenv cenv fun_defs =
let useless_env = ref initially_closed in
(* Translate each function definition *)
let clos_fundef (id, params, body, fundesc) env_pos =
let dbg = match body with
| Levent (_,({lev_kind=Lev_function} as ev)) -> Debuginfo.from_call ev
| _ -> Debuginfo.none in
let env_param = Ident.create "env" in
let cenv_fv =
build_closure_env env_param (fv_pos - env_pos) fv in
@ -759,7 +762,11 @@ and close_functions fenv cenv fun_defs =
let (ubody, approx) = close fenv_rec cenv_body body in
if !useless_env && occurs_var env_param ubody then useless_env := false;
let fun_params = if !useless_env then params else params @ [env_param] in
((fundesc.fun_label, fundesc.fun_arity, fun_params, ubody),
({ label = fundesc.fun_label;
arity = fundesc.fun_arity;
params = fun_params;
body = ubody;
dbg },
(id, env_pos, Value_closure(fundesc, approx))) in
(* Translate all function definitions. *)
let clos_info_list =
@ -789,11 +796,12 @@ and close_functions fenv cenv fun_defs =
and close_one_function fenv cenv id funct =
match close_functions fenv cenv [id, funct] with
((Uclosure([_, _, params, body], _) as clos),
((Uclosure([f], _) as clos),
[_, _, (Value_closure(fundesc, _) as approx)]) ->
(* See if the function can be inlined *)
if lambda_smaller body (!Clflags.inline_threshold + List.length params)
then fundesc.fun_inline <- Some(params, body);
if lambda_smaller f.body
(!Clflags.inline_threshold + List.length f.params)
then fundesc.fun_inline <- Some(f.params, f.body);
(clos, approx)
| _ -> fatal_error "Closure.close_one_function"

View File

@ -108,7 +108,8 @@ type fundecl =
{ fun_name: string;
fun_args: (Ident.t * machtype) list;
fun_body: expression;
fun_fast: bool }
fun_fast: bool;
fun_dbg : Debuginfo.t; }
type data_item =
Cdefine_symbol of string

View File

@ -94,7 +94,8 @@ type fundecl =
{ fun_name: string;
fun_args: (Ident.t * machtype) list;
fun_body: expression;
fun_fast: bool }
fun_fast: bool;
fun_dbg : Debuginfo.t; }
type data_item =
Cdefine_symbol of string

View File

@ -382,8 +382,7 @@ let make_checkbound dbg = function
let fundecls_size fundecls =
let sz = ref (-1) in
List.iter
(fun (label, arity, params, body) ->
sz := !sz + 1 + (if arity = 1 then 2 else 3))
(fun f -> sz := !sz + 1 + (if f.arity = 1 then 2 else 3))
fundecls;
!sz
@ -461,7 +460,7 @@ let transl_constant = function
(* Translate constant closures *)
let constant_closures =
ref ([] : (string * (string * int * Ident.t list * ulambda) list) list)
ref ([] : (string * ufunction list) list)
(* Boxed integers *)
@ -808,7 +807,7 @@ let subst_boxed_number unbox_fn boxed_id unboxed_id exp =
(* Translate an expression *)
let functions = (Queue.create() : (string * Ident.t list * ulambda) Queue.t)
let functions = (Queue.create() : ufunction Queue.t)
let rec transl = function
Uvar id ->
@ -820,10 +819,7 @@ let rec transl = function
| Uclosure(fundecls, []) ->
let lbl = Compilenv.new_const_symbol() in
constant_closures := (lbl, fundecls) :: !constant_closures;
List.iter
(fun (label, arity, params, body) ->
Queue.add (label, params, body) functions)
fundecls;
List.iter (fun f -> Queue.add f functions) fundecls;
Cconst_symbol lbl
| Uclosure(fundecls, clos_vars) ->
let block_size =
@ -831,22 +827,22 @@ let rec transl = function
let rec transl_fundecls pos = function
[] ->
List.map transl clos_vars
| (label, arity, params, body) :: rem ->
Queue.add (label, params, body) functions;
| f :: rem ->
Queue.add f functions;
let header =
if pos = 0
then alloc_closure_header block_size
else alloc_infix_header pos in
if arity = 1 then
if f.arity = 1 then
header ::
Cconst_symbol label ::
Cconst_symbol f.label ::
int_const 1 ::
transl_fundecls (pos + 3) rem
else
header ::
Cconst_symbol(curry_function arity) ::
int_const arity ::
Cconst_symbol label ::
Cconst_symbol(curry_function f.arity) ::
int_const f.arity ::
Cconst_symbol f.label ::
transl_fundecls (pos + 4) rem in
Cop(Calloc, transl_fundecls 0 fundecls)
| Uoffset(arg, offset) ->
@ -1556,11 +1552,12 @@ and transl_letrec bindings cont =
(* Translate a function definition *)
let transl_function lbl params body =
Cfunction {fun_name = lbl;
fun_args = List.map (fun id -> (id, typ_addr)) params;
fun_body = transl body;
fun_fast = !Clflags.optimize_for_speed}
let transl_function f =
Cfunction {fun_name = f.label;
fun_args = List.map (fun id -> (id, typ_addr)) f.params;
fun_body = transl f.body;
fun_fast = !Clflags.optimize_for_speed;
fun_dbg = f.dbg; }
(* Translate all function definitions *)
@ -1572,12 +1569,13 @@ module StringSet =
let rec transl_all_functions already_translated cont =
try
let (lbl, params, body) = Queue.take functions in
if StringSet.mem lbl already_translated then
let f = Queue.take functions in
if StringSet.mem f.label already_translated then
transl_all_functions already_translated cont
else begin
transl_all_functions (StringSet.add lbl already_translated)
(transl_function lbl params body :: cont)
transl_all_functions
(StringSet.add f.label already_translated)
(transl_function f :: cont)
end
with Queue.Empty ->
cont
@ -1709,31 +1707,31 @@ and emit_boxed_int64_constant n cont =
let emit_constant_closure symb fundecls cont =
match fundecls with
[] -> assert false
| (label, arity, params, body) :: remainder ->
| f1 :: remainder ->
let rec emit_others pos = function
[] -> cont
| (label, arity, params, body) :: rem ->
if arity = 1 then
| f2 :: rem ->
if f2.arity = 1 then
Cint(infix_header pos) ::
Csymbol_address label ::
Csymbol_address f2.label ::
Cint 3n ::
emit_others (pos + 3) rem
else
Cint(infix_header pos) ::
Csymbol_address(curry_function arity) ::
Cint(Nativeint.of_int (arity lsl 1 + 1)) ::
Csymbol_address label ::
Csymbol_address(curry_function f2.arity) ::
Cint(Nativeint.of_int (f2.arity lsl 1 + 1)) ::
Csymbol_address f2.label ::
emit_others (pos + 4) rem in
Cint(closure_header (fundecls_size fundecls)) ::
Cdefine_symbol symb ::
if arity = 1 then
Csymbol_address label ::
if f1.arity = 1 then
Csymbol_address f1.label ::
Cint 3n ::
emit_others 3 remainder
else
Csymbol_address(curry_function arity) ::
Cint(Nativeint.of_int (arity lsl 1 + 1)) ::
Csymbol_address label ::
Csymbol_address(curry_function f1.arity) ::
Cint(Nativeint.of_int (f1.arity lsl 1 + 1)) ::
Csymbol_address f1.label ::
emit_others 4 remainder
(* Emit all structured constants *)
@ -1764,7 +1762,8 @@ let compunit size ulam =
let init_code = transl ulam in
let c1 = [Cfunction {fun_name = Compilenv.make_symbol (Some "entry");
fun_args = [];
fun_body = init_code; fun_fast = false}] in
fun_body = init_code; fun_fast = false;
fun_dbg = Debuginfo.none }] in
let c2 = transl_all_functions StringSet.empty c1 in
let c3 = emit_all_constants c2 in
Cdata [Cint(block_header 0 size);
@ -1893,7 +1892,8 @@ let send_function arity =
{fun_name = "caml_send" ^ string_of_int arity;
fun_args = fun_args;
fun_body = body;
fun_fast = true}
fun_fast = true;
fun_dbg = Debuginfo.none }
let apply_function arity =
let (args, clos, body) = apply_function_body arity in
@ -1902,7 +1902,8 @@ let apply_function arity =
{fun_name = "caml_apply" ^ string_of_int arity;
fun_args = List.map (fun id -> (id, typ_addr)) all_args;
fun_body = body;
fun_fast = true}
fun_fast = true;
fun_dbg = Debuginfo.none }
(* Generate tuplifying functions:
(defun caml_tuplifyN (arg clos)
@ -1921,7 +1922,8 @@ let tuplify_function arity =
fun_body =
Cop(Capply(typ_addr, Debuginfo.none),
get_field (Cvar clos) 2 :: access_components 0 @ [Cvar clos]);
fun_fast = true}
fun_fast = true;
fun_dbg = Debuginfo.none }
(* Generate currying functions:
(defun caml_curryN (arg clos)
@ -1972,7 +1974,8 @@ let final_curry_function arity =
"_" ^ string_of_int (arity-1);
fun_args = [last_arg, typ_addr; last_clos, typ_addr];
fun_body = curry_fun [] last_clos (arity-1);
fun_fast = true}
fun_fast = true;
fun_dbg = Debuginfo.none }
let rec intermediate_curry_functions arity num =
if num = arity - 1 then
@ -1997,7 +2000,8 @@ let rec intermediate_curry_functions arity num =
[alloc_closure_header 4;
Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1));
int_const 1; Cvar arg; Cvar clos]);
fun_fast = true}
fun_fast = true;
fun_dbg = Debuginfo.none }
::
(if arity - num > 2 then
let rec iter i =
@ -2023,7 +2027,8 @@ let rec intermediate_curry_functions arity num =
fun_args = direct_args @ [clos, typ_addr];
fun_body = iter (num+1)
(List.map (fun (arg,_) -> Cvar arg) direct_args) clos;
fun_fast = true}
fun_fast = true;
fun_dbg = Debuginfo.none }
in
cf :: intermediate_curry_functions arity (num+1)
else
@ -2079,7 +2084,8 @@ let entry_point namelist =
Cfunction {fun_name = "caml_program";
fun_args = [];
fun_body = body;
fun_fast = false}
fun_fast = false;
fun_dbg = Debuginfo.none }
(* Generate the table of globals *)

View File

@ -31,6 +31,9 @@ let none = {
dinfo_char_end = 0
}
let is_none t =
t == none
let to_string d =
if d == none
then ""
@ -38,7 +41,7 @@ let to_string d =
d.dinfo_file d.dinfo_line d.dinfo_char_start d.dinfo_char_end
let from_location kind loc =
if loc.loc_ghost then none else
if loc == Location.none then none else
{ dinfo_kind = kind;
dinfo_file = loc.loc_start.pos_fname;
dinfo_line = loc.loc_start.pos_lnum;
@ -50,3 +53,4 @@ let from_location kind loc =
let from_call ev = from_location Dinfo_call ev.Lambda.lev_loc
let from_raise ev = from_location Dinfo_raise ev.Lambda.lev_loc

View File

@ -22,6 +22,8 @@ type t = {
val none: t
val is_none: t -> bool
val to_string: t -> string
val from_location: kind -> Location.t -> t

View File

@ -114,6 +114,36 @@ let emit_float32_directive directive f =
let x = Int32.bits_of_float (float_of_string f) in
emit_printf "\t%s\t0x%lx\n" directive x
(* Emit debug information *)
(* This assoc list is expected to be very short *)
let file_pos_nums =
(ref [] : (string * int) list ref)
(* Number of files *)
let file_pos_num_cnt = ref 1
(* We only diplay .file if the file has not been seen before. We
display .loc for every instruction. *)
let emit_debug_info dbg =
let line = dbg.Debuginfo.dinfo_line in
let file_name = dbg.Debuginfo.dinfo_file in
if !Clflags.debug && not (Debuginfo.is_none dbg) then (
let file_num =
try List.assoc file_name !file_pos_nums
with Not_found ->
let file_num = !file_pos_num_cnt in
incr file_pos_num_cnt;
emit_string " .file ";
emit_int file_num; emit_char ' ';
emit_string_literal file_name; emit_char '\n';
file_pos_nums := (file_name,file_num) :: !file_pos_nums;
file_num in
emit_string " .loc ";
emit_int file_num; emit_char ' ';
emit_int line; emit_char '\n'
)
(* Record live pointers at call points *)
type frame_descr =
@ -189,3 +219,23 @@ let is_generic_function name =
List.exists
(fun p -> isprefix p name)
["caml_apply"; "caml_curry"; "caml_send"; "caml_tuplify"]
(* CFI directives *)
let is_cfi_enabled () =
!Clflags.debug && Config.asm_cfi_supported
let cfi_startproc () =
if is_cfi_enabled () then
emit_string " .cfi_startproc\n"
let cfi_endproc () =
if is_cfi_enabled () then
emit_string " .cfi_endproc\n"
let cfi_adjust_cfa_offset n =
if is_cfi_enabled () then
begin
emit_string " .cfi_adjust_cfa_offset "; emit_int n; emit_string "\n";
end

View File

@ -29,6 +29,8 @@ val emit_float64_directive: string -> string -> unit
val emit_float64_split_directive: string -> string -> unit
val emit_float32_directive: string -> string -> unit
val emit_debug_info: Debuginfo.t -> unit
type frame_descr =
{ fd_lbl: int; (* Return address *)
fd_frame_size: int; (* Size of stack frame *)
@ -50,3 +52,7 @@ type emit_frame_actions =
val emit_frames: emit_frame_actions -> unit
val is_generic_function: string -> bool
val cfi_startproc : unit -> unit
val cfi_endproc : unit -> unit
val cfi_adjust_cfa_offset : int -> unit

View File

@ -312,9 +312,18 @@ let output_test_zero arg =
(* Deallocate the stack frame before a return or tail call *)
let output_epilogue () =
let output_epilogue f =
let n = frame_size() - 4 in
if n > 0 then ` addl ${emit_int n}, %esp\n`
if n > 0 then
begin
` addl ${emit_int n}, %esp\n`;
cfi_adjust_cfa_offset (-n);
f ();
(* reset CFA back cause function body may continue *)
cfi_adjust_cfa_offset n
end
else
f ()
(* Determine if the given register is the top of the floating-point stack *)
@ -418,6 +427,7 @@ let external_symbols_direct = ref StringSet.empty
let external_symbols_indirect = ref StringSet.empty
let emit_instr fallthrough i =
emit_debug_info i.dbg;
match i.desc with
Lend -> ()
| Lop(Imove | Ispill | Ireload) ->
@ -466,14 +476,16 @@ let emit_instr fallthrough i =
` call {emit_symbol s}\n`;
record_frame i.live i.dbg
| Lop(Itailcall_ind) ->
output_epilogue();
output_epilogue begin fun () ->
` jmp *{emit_reg i.arg.(0)}\n`
end
| Lop(Itailcall_imm s) ->
if s = !function_name then
` jmp {emit_label !tailrec_entry_point}\n`
else begin
output_epilogue();
output_epilogue begin fun () ->
` jmp {emit_symbol s}\n`
end
end
| Lop(Iextcall(s, alloc)) ->
if alloc then begin
@ -499,6 +511,7 @@ let emit_instr fallthrough i =
if n < 0
then ` addl ${emit_int(-n)}, %esp\n`
else ` subl ${emit_int(n)}, %esp\n`;
cfi_adjust_cfa_offset n;
stack_offset := !stack_offset + n
| Lop(Iload(chunk, addr)) ->
let dest = i.res.(0) in
@ -652,6 +665,7 @@ let emit_instr fallthrough i =
` fldl {emit_reg i.arg.(0)}\n`;
stack_offset := !stack_offset - 8;
` subl $8, %esp\n`;
cfi_adjust_cfa_offset 8;
` fnstcw 4(%esp)\n`;
` movw 4(%esp), %ax\n`;
` movb $12, %ah\n`;
@ -666,6 +680,7 @@ let emit_instr fallthrough i =
end;
` fldcw 4(%esp)\n`;
` addl $8, %esp\n`;
cfi_adjust_cfa_offset (-8);
stack_offset := !stack_offset + 8
| Lop(Ispecific(Ilea addr)) ->
` lea {emit_addressing addr i.arg 0}, {emit_reg i.res.(0)}\n`
@ -682,29 +697,36 @@ let emit_instr fallthrough i =
match r with
{loc = Reg _; typ = Float} ->
` subl $8, %esp\n`;
cfi_adjust_cfa_offset 8;
` fstpl 0(%esp)\n`;
stack_offset := !stack_offset + 8
| {loc = Stack sl; typ = Float} ->
let ofs = slot_offset sl 1 in
` pushl {emit_int(ofs + 4)}(%esp)\n`;
` pushl {emit_int(ofs + 4)}(%esp)\n`;
cfi_adjust_cfa_offset 8;
stack_offset := !stack_offset + 8
| _ ->
` pushl {emit_reg r}\n`;
cfi_adjust_cfa_offset 4;
stack_offset := !stack_offset + 4
done
| Lop(Ispecific(Ipush_int n)) ->
` pushl ${emit_nativeint n}\n`;
cfi_adjust_cfa_offset 4;
stack_offset := !stack_offset + 4
| Lop(Ispecific(Ipush_symbol s)) ->
` pushl ${emit_symbol s}\n`;
cfi_adjust_cfa_offset 4;
stack_offset := !stack_offset + 4
| Lop(Ispecific(Ipush_load addr)) ->
` pushl {emit_addressing addr i.arg 0}\n`;
cfi_adjust_cfa_offset 4;
stack_offset := !stack_offset + 4
| Lop(Ispecific(Ipush_load_float addr)) ->
` pushl {emit_addressing (offset_addressing addr 4) i.arg 0}\n`;
` pushl {emit_addressing addr i.arg 0}\n`;
cfi_adjust_cfa_offset 8;
stack_offset := !stack_offset + 8
| Lop(Ispecific(Ifloatarithmem(double, op, addr))) ->
if not (is_tos i.arg.(0)) then
@ -722,8 +744,9 @@ let emit_instr fallthrough i =
| Lreloadretaddr ->
()
| Lreturn ->
output_epilogue();
output_epilogue begin fun () ->
` ret\n`
end
| Llabel lbl ->
`{emit_Llabel fallthrough lbl}:\n`
| Lbranch lbl ->
@ -787,11 +810,13 @@ let emit_instr fallthrough i =
if trap_frame_size > 8 then
` subl ${emit_int (trap_frame_size - 8)}, %esp\n`;
` pushl {emit_symbol "caml_exception_pointer"}\n`;
cfi_adjust_cfa_offset trap_frame_size;
` movl %esp, {emit_symbol "caml_exception_pointer"}\n`;
stack_offset := !stack_offset + trap_frame_size
| Lpoptrap ->
` popl {emit_symbol "caml_exception_pointer"}\n`;
` addl ${emit_int (trap_frame_size - 4)}, %esp\n`;
cfi_adjust_cfa_offset (-trap_frame_size);
stack_offset := !stack_offset - trap_frame_size
| Lraise ->
if !Clflags.debug then begin
@ -900,14 +925,20 @@ let fundecl fundecl =
else
` .globl {emit_symbol fundecl.fun_name}\n`;
`{emit_symbol fundecl.fun_name}:\n`;
emit_debug_info fundecl.fun_dbg;
cfi_startproc ();
if !Clflags.gprofile then emit_profile();
let n = frame_size() - 4 in
if n > 0 then
begin
` subl ${emit_int n}, %esp\n`;
cfi_adjust_cfa_offset n;
end;
`{emit_label !tailrec_entry_point}:\n`;
emit_all true fundecl.fun_body;
List.iter emit_call_gc !call_gc_sites;
emit_call_bound_errors ();
cfi_endproc ();
begin match Config.system with
"linux_elf" | "bsd_elf" | "gnu" ->
` .type {emit_symbol fundecl.fun_name},@function\n`;

View File

@ -54,7 +54,8 @@ let has_fallthrough = function
type fundecl =
{ fun_name: string;
fun_body: instruction;
fun_fast: bool }
fun_fast: bool;
fun_dbg : Debuginfo.t }
(* Invert a test *)
@ -264,4 +265,5 @@ let rec linear i n =
let fundecl f =
{ fun_name = f.Mach.fun_name;
fun_body = linear f.Mach.fun_body end_instr;
fun_fast = f.Mach.fun_fast }
fun_fast = f.Mach.fun_fast;
fun_dbg = f.Mach.fun_dbg }

View File

@ -49,6 +49,7 @@ val invert_test: Mach.test -> Mach.test
type fundecl =
{ fun_name: string;
fun_body: instruction;
fun_fast: bool }
fun_fast: bool;
fun_dbg : Debuginfo.t }
val fundecl: Mach.fundecl -> fundecl

View File

@ -79,7 +79,8 @@ type fundecl =
{ fun_name: string;
fun_args: Reg.t array;
fun_body: instruction;
fun_fast: bool }
fun_fast: bool;
fun_dbg : Debuginfo.t }
let rec dummy_instr =
{ desc = Iend;

View File

@ -79,7 +79,8 @@ type fundecl =
{ fun_name: string;
fun_args: Reg.t array;
fun_body: instruction;
fun_fast: bool }
fun_fast: bool;
fun_dbg : Debuginfo.t }
val dummy_instr: instruction
val end_instr: unit -> instruction

View File

@ -176,8 +176,9 @@ let fundecl ppf f =
if !first then first := false else fprintf ppf "@ ";
fprintf ppf "%a: %a" Ident.print id machtype ty)
cases in
fprintf ppf "@[<1>(function %s@;<1 4>@[<1>(%a)@]@ @[%a@])@]@."
f.fun_name print_cases f.fun_args sequence f.fun_body
fprintf ppf "@[<1>(function%s %s@;<1 4>@[<1>(%a)@]@ @[%a@])@]@."
(Debuginfo.to_string f.fun_dbg) f.fun_name
print_cases f.fun_args sequence f.fun_body
let data_item ppf = function
| Cdefine_symbol s -> fprintf ppf "\"%s\":" s

View File

@ -74,4 +74,9 @@ let rec all_instr ppf i =
| _ -> fprintf ppf "%a@,%a" instr i all_instr i.next
let fundecl ppf f =
fprintf ppf "@[<v 2>%s:@,%a@]" f.fun_name all_instr f.fun_body
let dbg =
if Debuginfo.is_none f.fun_dbg then
""
else
" " ^ Debuginfo.to_string f.fun_dbg in
fprintf ppf "@[<v 2>%s:%s@,%a@]" f.fun_name dbg all_instr f.fun_body

View File

@ -182,16 +182,21 @@ let rec instr ppf i =
| Iraise ->
fprintf ppf "raise %a" reg i.arg.(0)
end;
if i.dbg != Debuginfo.none then
fprintf ppf " %s" (Debuginfo.to_string i.dbg);
if not (Debuginfo.is_none i.dbg) then
fprintf ppf "%s" (Debuginfo.to_string i.dbg);
begin match i.next.desc with
Iend -> ()
| _ -> fprintf ppf "@,%a" instr i.next
end
let fundecl ppf f =
fprintf ppf "@[<v 2>%s(%a)@,%a@]"
f.fun_name regs f.fun_args instr f.fun_body
let dbg =
if Debuginfo.is_none f.fun_dbg then
""
else
" " ^ Debuginfo.to_string f.fun_dbg in
fprintf ppf "@[<v 2>%s(%a)%s@,%a@]"
f.fun_name regs f.fun_args dbg instr f.fun_body
let phase msg ppf f =
fprintf ppf "*** %s@.%a@." msg fundecl f

View File

@ -134,7 +134,8 @@ method fundecl f =
redo_regalloc <- false;
let new_body = self#reload f.fun_body in
({fun_name = f.fun_name; fun_args = f.fun_args;
fun_body = new_body; fun_fast = f.fun_fast},
fun_body = new_body; fun_fast = f.fun_fast;
fun_dbg = f.fun_dbg},
redo_regalloc)
end

View File

@ -349,7 +349,8 @@ method schedule_fundecl f =
clear_code_dag();
{ fun_name = f.fun_name;
fun_body = new_body;
fun_fast = f.fun_fast }
fun_fast = f.fun_fast;
fun_dbg = f.fun_dbg }
end else
f

View File

@ -819,7 +819,8 @@ method emit_fundecl f =
{ fun_name = f.Cmm.fun_name;
fun_args = loc_arg;
fun_body = self#extract;
fun_fast = f.Cmm.fun_fast }
fun_fast = f.Cmm.fun_fast;
fun_dbg = f.Cmm.fun_dbg }
end

View File

@ -399,4 +399,5 @@ let fundecl f =
{ fun_name = f.fun_name;
fun_args = f.fun_args;
fun_body = new_body;
fun_fast = f.fun_fast }
fun_fast = f.fun_fast;
fun_dbg = f.fun_dbg }

View File

@ -207,4 +207,5 @@ let fundecl f =
{ fun_name = f.fun_name;
fun_args = new_args;
fun_body = new_body;
fun_fast = f.fun_fast }
fun_fast = f.fun_fast;
fun_dbg = f.fun_dbg }

View File

@ -18,6 +18,8 @@
/* PIC mode support based on contribution by Paul Stravers (see PR#4795) */
#include "../config/m.h"
#if defined(SYS_macosx)
#define LBL(x) L##x
@ -63,6 +65,16 @@
#endif
#ifdef ASM_CFI_SUPPORTED
#define CFI_STARTPROC .cfi_startproc
#define CFI_ENDPROC .cfi_endproc
#define CFI_ADJUST(n) .cfi_adjust_cfa_offset n
#else
#define CFI_STARTPROC
#define CFI_ENDPROC
#define CFI_ADJUST(n)
#endif
#if defined(__PIC__) && !defined(SYS_mingw64)
/* Position-independent operations on global variables. */
@ -226,6 +238,7 @@ G(caml_system__code_begin):
/* Allocation */
FUNCTION(G(caml_call_gc))
CFI_STARTPROC
RECORD_STACK_FRAME(0)
LBL(caml_call_gc):
#ifndef SYS_mingw64
@ -255,6 +268,7 @@ LBL(caml_call_gc):
STORE_VAR(%r14, caml_exception_pointer)
/* Save floating-point registers */
subq $(16*8), %rsp
CFI_ADJUST(232)
movsd %xmm0, 0*8(%rsp)
movsd %xmm1, 1*8(%rsp)
movsd %xmm2, 2*8(%rsp)
@ -309,8 +323,10 @@ LBL(caml_call_gc):
popq %rbp
popq %r12
popq %r13
CFI_ADJUST(-232)
/* Return to caller */
ret
CFI_ENDPROC
FUNCTION(G(caml_alloc1))
LBL(caml_alloc1):
@ -396,8 +412,10 @@ LBL(caml_c_call):
/* Start the OCaml program */
FUNCTION(G(caml_start_program))
CFI_STARTPROC
/* Save callee-save registers */
PUSH_CALLEE_SAVE_REGS
CFI_ADJUST(56)
/* Initial entry point is G(caml_program) */
leaq GCALL(caml_program)(%rip), %r12
/* Common code for caml_start_program and caml_callback* */
@ -407,6 +425,7 @@ LBL(caml_start_program):
PUSH_VAR(caml_gc_regs)
PUSH_VAR(caml_last_return_address)
PUSH_VAR(caml_bottom_of_stack)
CFI_ADJUST(32)
/* Setup alloc ptr and exception ptr */
LOAD_VAR(caml_young_ptr, %r15)
LOAD_VAR(caml_exception_pointer, %r14)
@ -414,6 +433,7 @@ LBL(caml_start_program):
lea LBL(108)(%rip), %r13
pushq %r13
pushq %r14
CFI_ADJUST(16)
movq %rsp, %r14
/* Call the OCaml code */
call *%r12
@ -421,6 +441,7 @@ LBL(107):
/* Pop the exception handler */
popq %r14
popq %r12 /* dummy register */
CFI_ADJUST(-16)
LBL(109):
/* Update alloc ptr and exception ptr */
STORE_VAR(%r15,caml_young_ptr)
@ -439,6 +460,7 @@ LBL(108):
/* Mark the bucket as an exception result and return it */
orq $2, %rax
jmp LBL(109)
CFI_ENDPROC
/* Registers holding arguments of C functions. */

View File

@ -16,6 +16,8 @@
/* Asm part of the runtime system, Intel 386 processor */
/* Must be preprocessed by cpp */
#include "../config/m.h"
/* Linux/BSD with ELF binaries and Solaris do not prefix identifiers with _.
Linux/BSD with a.out binaries and NextStep do. */
@ -42,6 +44,16 @@
#define FUNCTION_ALIGN 2
#endif
#ifdef ASM_CFI_SUPPORTED
#define CFI_STARTPROC .cfi_startproc
#define CFI_ENDPROC .cfi_endproc
#define CFI_ADJUST(n) .cfi_adjust_cfa_offset n
#else
#define CFI_STARTPROC
#define CFI_ENDPROC
#define CFI_ADJUST(n)
#endif
#if defined(PROFILING)
#if defined(SYS_linux_elf) || defined(SYS_gnu)
#define PROFILE_CAML \
@ -92,6 +104,7 @@ G(caml_system__code_begin):
.align FUNCTION_ALIGN
G(caml_call_gc):
CFI_STARTPROC
PROFILE_CAML
/* Record lowest stack address and return address */
movl 0(%esp), %eax
@ -114,6 +127,7 @@ LBL(105):
pushl %ecx
pushl %ebx
pushl %eax
CFI_ADJUST(28)
movl %esp, G(caml_gc_regs)
/* MacOSX note: 16-alignment of stack preserved at this point */
/* Call the garbage collector */
@ -126,8 +140,10 @@ LBL(105):
popl %esi
popl %edi
popl %ebp
CFI_ADJUST(-28)
/* Return to caller */
ret
CFI_ENDPROC
.align FUNCTION_ALIGN
G(caml_alloc1):
@ -236,12 +252,14 @@ G(caml_c_call):
.globl G(caml_start_program)
.align FUNCTION_ALIGN
G(caml_start_program):
CFI_STARTPROC
PROFILE_C
/* Save callee-save registers */
pushl %ebx
pushl %esi
pushl %edi
pushl %ebp
CFI_ADJUST(16)
/* Initial entry point is caml_program */
movl $ G(caml_program), %esi
/* Common code for caml_start_program and caml_callback* */
@ -255,6 +273,7 @@ LBL(106):
pushl $ LBL(108)
ALIGN_STACK(8)
pushl G(caml_exception_pointer)
CFI_ADJUST(20)
movl %esp, G(caml_exception_pointer)
/* Call the OCaml code */
call *%esi
@ -266,6 +285,7 @@ LBL(107):
#else
addl $4, %esp
#endif
CFI_ADJUST(-8)
LBL(109):
/* Pop the callback link, restoring the global variables */
popl G(caml_bottom_of_stack)
@ -283,6 +303,7 @@ LBL(108):
/* Mark the bucket as an exception result and return it */
orl $2, %eax
jmp LBL(109)
CFI_ENDPROC
/* Raise an exception from OCaml */

View File

@ -299,7 +299,10 @@ let rec lam ppf = function
| Lev_before -> "before"
| Lev_after _ -> "after"
| Lev_function -> "funct-body" in
fprintf ppf "@[<2>(%s %i-%i@ %a)@]" kind
fprintf ppf "@[<2>(%s %s(%i)%s:%i-%i@ %a)@]" kind
ev.lev_loc.Location.loc_start.Lexing.pos_fname
ev.lev_loc.Location.loc_start.Lexing.pos_lnum
(if ev.lev_loc.Location.loc_ghost then "<ghost>" else "")
ev.lev_loc.Location.loc_start.Lexing.pos_cnum
ev.lev_loc.Location.loc_end.Lexing.pos_cnum
lam expr

View File

@ -18,3 +18,4 @@ open Format
val structured_constant: formatter -> structured_constant -> unit
val lambda: formatter -> lambda -> unit
val primitive: formatter -> primitive -> unit

17
configure vendored
View File

@ -1542,6 +1542,17 @@ else
echo "LIBBFD_LINK=" >> Makefile
fi
# Check whether assembler supports CFI directives
asm_cfi_supported=false
export aspp
if sh ./tryassemble cfi.S; then
echo "#define ASM_CFI_SUPPORTED" >> m.h
asm_cfi_supported=true
fi
# Final twiddling of compiler options to work around known bugs
nativeccprofopts="$nativecccompopts"
@ -1613,6 +1624,7 @@ echo "MKDLL=$mksharedlib" >> Makefile
echo "MKMAINDLL=$mkmaindll" >> Makefile
echo "RUNTIMED=${debugruntime}" >>Makefile
echo "CAMLP4=${withcamlp4}" >>Makefile
echo "ASM_CFI_SUPPORTED=$asm_cfi_supported" >> Makefile
rm -f tst hasgot.c
rm -f ../m.h ../s.h ../Makefile
@ -1657,6 +1669,11 @@ else
echo " options for linking....... $nativecclinkopts $cclibs"
echo " assembler ................ $as"
echo " preprocessed assembler ... $aspp"
if test "$asm_cfi_supported" = "true"; then
echo " assembler supports CFI ... yes"
else
echo " assembler supports CFI ... no"
fi
echo " native dynlink ........... $natdynlink"
if test "$profiling" = "prof"; then
echo " profiling with gprof ..... supported"

View File

@ -328,6 +328,10 @@ let mk_dlambda f =
"-dlambda", Arg.Unit f, " (undocumented)"
;;
let mk_dclambda f =
"-dclambda", Arg.Unit f, " (undocumented)"
;;
let mk_dinstr f =
"-dinstr", Arg.Unit f, " (undocumented)"
;;
@ -528,6 +532,7 @@ module type Optcomp_options = sig
val _dparsetree : unit -> unit
val _drawlambda : unit -> unit
val _dlambda : unit -> unit
val _dclambda : unit -> unit
val _dcmm : unit -> unit
val _dsel : unit -> unit
val _dcombine : unit -> unit
@ -573,6 +578,7 @@ module type Opttop_options = sig
val _dparsetree : unit -> unit
val _drawlambda : unit -> unit
val _dlambda : unit -> unit
val _dclambda : unit -> unit
val _dcmm : unit -> unit
val _dsel : unit -> unit
val _dcombine : unit -> unit
@ -748,11 +754,13 @@ struct
mk_dparsetree F._dparsetree;
mk_drawlambda F._drawlambda;
mk_dlambda F._dlambda;
mk_dclambda F._dclambda;
mk_dcmm F._dcmm;
mk_dsel F._dsel;
mk_dcombine F._dcombine;
mk_dlive F._dlive;
mk_dspill F._dspill;
mk_dsplit F._dsplit;
mk_dinterf F._dinterf;
mk_dprefer F._dprefer;
mk_dalloc F._dalloc;
@ -793,11 +801,13 @@ module Make_opttop_options (F : Opttop_options) = struct
mk_dparsetree F._dparsetree;
mk_drawlambda F._drawlambda;
mk_dclambda F._dclambda;
mk_dcmm F._dcmm;
mk_dsel F._dsel;
mk_dcombine F._dcombine;
mk_dlive F._dlive;
mk_dspill F._dspill;
mk_dsplit F._dsplit;
mk_dinterf F._dinterf;
mk_dprefer F._dprefer;
mk_dalloc F._dalloc;

View File

@ -153,6 +153,7 @@ module type Optcomp_options = sig
val _dparsetree : unit -> unit
val _drawlambda : unit -> unit
val _dlambda : unit -> unit
val _dclambda : unit -> unit
val _dcmm : unit -> unit
val _dsel : unit -> unit
val _dcombine : unit -> unit
@ -198,6 +199,7 @@ module type Opttop_options = sig
val _dparsetree : unit -> unit
val _drawlambda : unit -> unit
val _dlambda : unit -> unit
val _dclambda : unit -> unit
val _dcmm : unit -> unit
val _dsel : unit -> unit
val _dcombine : unit -> unit

View File

@ -152,6 +152,7 @@ module Options = Main_args.Make_optcomp_options (struct
let _dparsetree = set dump_parsetree
let _drawlambda = set dump_rawlambda
let _dlambda = set dump_lambda
let _dclambda = set dump_clambda
let _dcmm = set dump_cmm
let _dsel = set dump_selection
let _dcombine = set dump_combine

View File

@ -58,6 +58,7 @@ and error_size = ref 500 (* -error-size *)
let dump_parsetree = ref false (* -dparsetree *)
and dump_rawlambda = ref false (* -drawlambda *)
and dump_lambda = ref false (* -dlambda *)
and dump_clambda = ref false (* -dclambda *)
and dump_instr = ref false (* -dinstr *)
let keep_asm_file = ref false (* -S *)

View File

@ -55,6 +55,7 @@ val error_size : int ref
val dump_parsetree : bool ref
val dump_rawlambda : bool ref
val dump_lambda : bool ref
val dump_clambda : bool ref
val dump_instr : bool ref
val keep_asm_file : bool ref
val optimize_for_speed : bool ref

View File

@ -89,6 +89,7 @@ let model = C.model
let system = C.system
let asm = C.asm
let asm_cfi_supported = C.asm_cfi_supported
let ext_obj = C.ext_obj
let ext_asm = C.ext_asm
@ -122,6 +123,7 @@ let print_config oc =
p "model" model;
p "system" system;
p "asm" asm;
p_bool "asm_cfi_supported" asm_cfi_supported;
p "ext_obj" ext_obj;
p "ext_asm" ext_asm;
p "ext_lib" ext_lib;

View File

@ -99,6 +99,9 @@ val asm: string
(* The assembler (and flags) to use for assembling
ocamlopt-generated code. *)
val asm_cfi_supported: bool
(* Whether assembler understands CFI directives *)
val ext_obj: string
(* Extension for object files, e.g. [.o] under Unix. *)
val ext_asm: string

View File

@ -78,6 +78,7 @@ let model = "%%MODEL%%"
let system = "%%SYSTEM%%"
let asm = "%%ASM%%"
let asm_cfi_supported = %%ASM_CFI_SUPPORTED%%
let ext_obj = "%%EXT_OBJ%%"
let ext_asm = "%%EXT_ASM%%"
@ -111,6 +112,7 @@ let print_config oc =
p "model" model;
p "system" system;
p "asm" asm;
p_bool "asm_cfi_supported" asm_cfi_supported;
p "ext_obj" ext_obj;
p "ext_asm" ext_asm;
p "ext_lib" ext_lib;