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-0dff7051ff02master
parent
fd515e3a16
commit
2eecf2d4c0
7
.depend
7
.depend
|
@ -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 \
|
||||
|
|
4
Changes
4
Changes
|
@ -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)
|
||||
|
|
3
Makefile
3
Makefile
|
@ -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)|' \
|
||||
|
|
|
@ -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`;
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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"
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 *)
|
||||
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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`;
|
||||
|
|
|
@ -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 }
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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 }
|
||||
|
|
|
@ -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 }
|
||||
|
|
|
@ -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. */
|
||||
|
||||
|
|
|
@ -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 */
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -18,3 +18,4 @@ open Format
|
|||
|
||||
val structured_constant: formatter -> structured_constant -> unit
|
||||
val lambda: formatter -> lambda -> unit
|
||||
val primitive: formatter -> primitive -> unit
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 *)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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;
|
||||
|
|
Loading…
Reference in New Issue