Exception backtraces for AMD64/Win64opt_backtrace

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/opt_backtrace@7811 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

1 files changed, 74 insertions, 34 deletions

diff --git a/asmcomp/amd64/emit_nt.mlp b/asmcomp/amd64/emit_nt.mlp
index 0b10963e9b..111cfa72c3 100644
--- a/asmcomp/amd64/emit_nt.mlp
+++ b/asmcomp/amd64/emit_nt.mlp
@@ -59,6 +59,8 @@ let slot_offset loc cl =
 let emit_symbol s =
   Emitaux.emit_symbol '$' s
 
+let emit_int32 n = emit_printf "0%lxh" n
+
 (* Record symbols used and defined - at the end generate extern for those 
    used but not defined *)
 
@@ -149,14 +151,7 @@ let emit_addressing addr r n =
 
 (* Record live pointers at call points *)
 
-type frame_descr =
-  { fd_lbl: int;                        (* Return address *)
-    fd_frame_size: int;                 (* Size of stack frame *)
-    fd_live_offset: int list }          (* Offsets/regs of live addresses *)
-
-let frame_descriptors = ref([] : frame_descr list)
-
-let record_frame_label live =
+let record_frame_label live dbg =
   let lbl = new_label() in
   let live_offset = ref [] in
   Reg.Set.iter
@@ -170,12 +165,14 @@ let record_frame_label live =
   frame_descriptors :=
     { fd_lbl = lbl;
       fd_frame_size = frame_size();
-      fd_live_offset = !live_offset } :: !frame_descriptors;
+      fd_live_offset = !live_offset;
+      fd_debuginfo = dbg } :: !frame_descriptors;
   lbl
 
-let record_frame live =
-  let lbl = record_frame_label live in `{emit_label lbl}:\n`
+let record_frame live dbg =
+  let lbl = record_frame_label live dbg in `{emit_label lbl}:\n`
 
+(*
 let emit_frame fd =
   `	QWORD	{emit_label fd.fd_lbl}\n`;
   `	WORD	{emit_int fd.fd_frame_size}\n`;
@@ -185,6 +182,7 @@ let emit_frame fd =
       `	WORD	{emit_int n}\n`)
     fd.fd_live_offset;
   emit_align 8
+*)
 
 (* Record calls to the GC -- we've moved them out of the way *)
 
@@ -199,6 +197,38 @@ let emit_call_gc gc =
   `{emit_label gc.gc_lbl}:	call	{emit_symbol "caml_call_gc"}\n`;
   `{emit_label gc.gc_frame}:	jmp	{emit_label gc.gc_return_lbl}\n`
 
+(* 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 *)
+
+let bound_error_sites = ref ([] : bound_error_call list)
+let bound_error_call = ref 0
+
+let bound_error_label dbg =
+  if !Clflags.debug then begin
+    let lbl_bound_error = new_label() in
+    let lbl_frame = record_frame_label Reg.Set.empty dbg in
+    bound_error_sites :=
+     { bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites;
+   lbl_bound_error
+ end else begin
+   if !bound_error_call = 0 then bound_error_call := new_label();
+   !bound_error_call
+ end
+
+let emit_call_bound_error bd =
+  `{emit_label bd.bd_lbl}:	call	{emit_symbol "caml_ml_array_bound_error"}\n`;
+  `{emit_label bd.bd_frame}:\n`
+
+let emit_call_bound_errors () =
+  List.iter emit_call_bound_error !bound_error_sites;
+  if !bound_error_call > 0 then
+    `{emit_label !bound_error_call}:	jmp	{emit_symbol "caml_ml_array_bound_error"}\n`
+
 (* Names for instructions *)
 
 let instr_for_intop = function
@@ -293,8 +323,6 @@ let output_epilogue () =
 let function_name = ref ""
 (* Entry point for tail recursive calls *)
 let tailrec_entry_point = ref 0
-(* Label of trap for out-of-range accesses *)
-let range_check_trap = ref 0
 
 let float_constants = ref ([] : (int * string) list)
 
@@ -339,11 +367,11 @@ let emit_instr fallthrough i =
           `	mov	{emit_reg i.res.(0)}, OFFSET {emit_symbol s}\n`
     | Lop(Icall_ind) ->
         `	call	{emit_reg i.arg.(0)}\n`;
-        record_frame i.live
+        record_frame i.live i.dbg
     | Lop(Icall_imm s) ->
         add_used_symbol s;
         `	call	{emit_symbol s}\n`;
-        record_frame i.live
+        record_frame i.live i.dbg
     | Lop(Itailcall_ind) ->
         output_epilogue();
         `	jmp	{emit_reg i.arg.(0)}\n`
@@ -360,7 +388,7 @@ let emit_instr fallthrough i =
         if alloc then begin
           `	lea	rax, {emit_symbol s}\n`;
           `	call	{emit_symbol "caml_c_call"}\n`;
-          record_frame i.live
+          record_frame i.live i.dbg
         end else begin
           `	call	{emit_symbol s}\n`
         end
@@ -414,7 +442,7 @@ let emit_instr fallthrough i =
           `{emit_label lbl_redo}:	sub	r15, {emit_int n}\n`;
           `	cmp	r15, {emit_symbol "caml_young_limit"}\n`;
           let lbl_call_gc = new_label() in
-          let lbl_frame = record_frame_label i.live in
+          let lbl_frame = record_frame_label i.live Debuginfo.none in
           `	jb	{emit_label lbl_call_gc}\n`;
           `	lea	{emit_reg i.res.(0)}, [r15+8]\n`;
           call_gc_sites :=
@@ -429,7 +457,7 @@ let emit_instr fallthrough i =
           | _  -> `	mov	rax, {emit_int n}\n`;
                   `	call	{emit_symbol "caml_allocN"}\n`
           end;
-          `{record_frame i.live}	lea	{emit_reg i.res.(0)}, [r15+8]\n`
+          `{record_frame i.live Debuginfo.none}	lea	{emit_reg i.res.(0)}, [r15+8]\n`
         end
     | Lop(Iintop(Icomp cmp)) ->
         `	cmp	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
@@ -442,13 +470,13 @@ let emit_instr fallthrough i =
         `	set{emit_string b}	al\n`;
         `	movzx	{emit_reg i.res.(0)}, al\n`
     | Lop(Iintop Icheckbound) ->
-        if !range_check_trap = 0 then range_check_trap := new_label();
+        let lbl = bound_error_label i.dbg in
         `	cmp	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
-        `	jbe	{emit_label !range_check_trap}\n`
+        `	jbe	{emit_label lbl}\n`
     | Lop(Iintop_imm(Icheckbound, n)) ->
-        if !range_check_trap = 0 then range_check_trap := new_label();
+        let lbl = bound_error_label i.dbg in
         `	cmp	{emit_reg i.arg.(0)}, {emit_int n}\n`;
-        `	jbe	{emit_label !range_check_trap}\n`
+        `	jbe	{emit_label lbl}\n`
     | Lop(Iintop(Idiv | Imod)) ->
         `	cqo\n`;
         `	idiv	{emit_reg i.arg.(1)}\n`
@@ -562,9 +590,9 @@ let emit_instr fallthrough i =
         let lbl = new_label() in
         if !pic_code then begin
           `	lea	r11, {emit_label lbl}\n`;
-          `	jmp	[r11+{emit_reg i.arg.(0)}*8]\n`
+          `	jmp	QWORD PTR [r11+{emit_reg i.arg.(0)}*8]\n`
         end else begin
-          `	jmp	[{emit_reg i.arg.(0)}*8 + {emit_label lbl}]\n`
+          `	jmp	QWORD PTR [{emit_reg i.arg.(0)}*8 + {emit_label lbl}]\n`
         end;
         `	.DATA\n`;
         emit_align 8;
@@ -584,9 +612,14 @@ let emit_instr fallthrough i =
         `	add	rsp, 8\n`;
         stack_offset := !stack_offset - 16
     | Lraise ->
-        `	mov	rsp, r14\n`;
-        `	pop	r14\n`;
-        `	ret\n`
+        if !Clflags.debug then begin
+          `	call	{emit_symbol "caml_raise_exn"}\n`;
+          record_frame Reg.Set.empty i.dbg
+        end else begin
+          `	mov	rsp, r14\n`;
+          `	pop	r14\n`;
+          `	ret\n`
+        end
 
 let rec emit_all fallthrough i =
   match i.desc with
@@ -626,7 +659,8 @@ let fundecl fundecl =
   stack_offset := 0;
   float_constants := [];
   call_gc_sites := [];
-  range_check_trap := 0;
+  bound_error_sites := [];
+  bound_error_call := 0;
   `	.CODE\n`;
   emit_align 16;
   add_def_symbol fundecl.fun_name;
@@ -639,9 +673,7 @@ let fundecl fundecl =
   `{emit_label !tailrec_entry_point}:\n`;
   emit_all true fundecl.fun_body;
   List.iter emit_call_gc !call_gc_sites;
-  if !range_check_trap > 0 then
-    `{emit_label !range_check_trap}:	call	{emit_symbol "caml_ml_array_bound_error"}\n`;
-    (* Never returns, but useful to have retaddr on stack for debugging *)
+  emit_call_bound_errors ();
   if !float_constants <> [] then begin
     `	.DATA\n`;
     List.iter emit_float_constant !float_constants
@@ -699,6 +731,7 @@ let begin_assembly() =
   `	EXTRN caml_alloc1: NEAR\n`;
   `	EXTRN caml_alloc2: NEAR\n`;
   `	EXTRN caml_alloc3: NEAR\n`;
+  `	EXTRN caml_raise_exn: NEAR\n`;
   `	EXTRN caml_ml_array_bound_error: NEAR\n`;
   let lbl_begin = Compilenv.make_symbol (Some "data_begin") in
   add_def_symbol lbl_begin;
@@ -727,9 +760,16 @@ let end_assembly() =
   add_def_symbol lbl;
   `	PUBLIC	{emit_symbol lbl}\n`;
   `{emit_symbol lbl} LABEL QWORD\n`;
-  `	QWORD	{emit_int (List.length !frame_descriptors)}\n`;
-  List.iter emit_frame !frame_descriptors;
-  frame_descriptors := [];
+  emit_frames
+    { efa_label = (fun l -> `	QWORD	{emit_label l}\n`);
+      efa_16 = (fun n -> `	WORD	{emit_int n}\n`);
+      efa_32 = (fun n -> `	DWORD	{emit_int32 n}\n`);
+      efa_word = (fun n -> `	QWORD	{emit_int n}\n`);
+      efa_align = emit_align;
+      efa_label_rel = (fun lbl ofs ->
+                           `	DWORD	{emit_label lbl} - THIS BYTE + {emit_int32 ofs}\n`);
+      efa_def_label = (fun l -> `{emit_label l}	LABEL	QWORD\n`);
+      efa_string = (fun s -> emit_bytes_directive  "	BYTE	" (s ^ "\000")) };
   `\n;External functions\n\n`;
   StringSet.iter
     (fun s ->