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

24 files changed, 247 insertions, 83 deletions

diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp
index 5e0d763ba2..7dd55c964f 100644
--- a/asmcomp/amd64/emit.mlp
+++ b/asmcomp/amd64/emit.mlp
@@ -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`;
diff --git a/asmcomp/clambda.ml b/asmcomp/clambda.ml
index 9bcb36fd16..9a01de819e 100644
--- a/asmcomp/clambda.ml
+++ b/asmcomp/clambda.ml
@@ -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;
diff --git a/asmcomp/clambda.mli b/asmcomp/clambda.mli
index 72ab85769f..808c1c6dae 100644
--- a/asmcomp/clambda.mli
+++ b/asmcomp/clambda.mli
@@ -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;
diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml
index e42f88ba3f..03ed0c1241 100644
--- a/asmcomp/closure.ml
+++ b/asmcomp/closure.ml
@@ -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"
 
diff --git a/asmcomp/cmm.ml b/asmcomp/cmm.ml
index 671ce5d789..7787a22042 100644
--- a/asmcomp/cmm.ml
+++ b/asmcomp/cmm.ml
@@ -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
diff --git a/asmcomp/cmm.mli b/asmcomp/cmm.mli
index 76c50859fe..5787bcb961 100644
--- a/asmcomp/cmm.mli
+++ b/asmcomp/cmm.mli
@@ -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
diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml
index 7a7bd211ad..e8e6a24ebe 100644
--- a/asmcomp/cmmgen.ml
+++ b/asmcomp/cmmgen.ml
@@ -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 *)
 
diff --git a/asmcomp/debuginfo.ml b/asmcomp/debuginfo.ml
index ad676d6745..ab0f5c047a 100644
--- a/asmcomp/debuginfo.ml
+++ b/asmcomp/debuginfo.ml
@@ -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
+
diff --git a/asmcomp/debuginfo.mli b/asmcomp/debuginfo.mli
index c6e36041cf..cf6179cd37 100644
--- a/asmcomp/debuginfo.mli
+++ b/asmcomp/debuginfo.mli
@@ -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
diff --git a/asmcomp/emitaux.ml b/asmcomp/emitaux.ml
index 92bda9e298..712b848f7e 100644
--- a/asmcomp/emitaux.ml
+++ b/asmcomp/emitaux.ml
@@ -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
+ 
diff --git a/asmcomp/emitaux.mli b/asmcomp/emitaux.mli
index c18d8e80c3..dd2f5b8c89 100644
--- a/asmcomp/emitaux.mli
+++ b/asmcomp/emitaux.mli
@@ -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
diff --git a/asmcomp/i386/emit.mlp b/asmcomp/i386/emit.mlp
index b94f3794da..d52b1db670 100644
--- a/asmcomp/i386/emit.mlp
+++ b/asmcomp/i386/emit.mlp
@@ -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`;
diff --git a/asmcomp/linearize.ml b/asmcomp/linearize.ml
index a5c758823a..8a5411876a 100644
--- a/asmcomp/linearize.ml
+++ b/asmcomp/linearize.ml
@@ -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 }
diff --git a/asmcomp/linearize.mli b/asmcomp/linearize.mli
index ca11006b5a..9fbe14ddb0 100644
--- a/asmcomp/linearize.mli
+++ b/asmcomp/linearize.mli
@@ -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
diff --git a/asmcomp/mach.ml b/asmcomp/mach.ml
index b628f76ca0..3d29bde11b 100644
--- a/asmcomp/mach.ml
+++ b/asmcomp/mach.ml
@@ -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;
diff --git a/asmcomp/mach.mli b/asmcomp/mach.mli
index dd58b8a024..05cc999b53 100644
--- a/asmcomp/mach.mli
+++ b/asmcomp/mach.mli
@@ -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
diff --git a/asmcomp/printcmm.ml b/asmcomp/printcmm.ml
index 996eaa21c1..ca1c0f11c3 100644
--- a/asmcomp/printcmm.ml
+++ b/asmcomp/printcmm.ml
@@ -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
diff --git a/asmcomp/printlinear.ml b/asmcomp/printlinear.ml
index 0e6f37b699..754a436120 100644
--- a/asmcomp/printlinear.ml
+++ b/asmcomp/printlinear.ml
@@ -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
diff --git a/asmcomp/printmach.ml b/asmcomp/printmach.ml
index 339deb7eed..93d0a02247 100644
--- a/asmcomp/printmach.ml
+++ b/asmcomp/printmach.ml
@@ -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
diff --git a/asmcomp/reloadgen.ml b/asmcomp/reloadgen.ml
index fc28acde4f..9da79587a2 100644
--- a/asmcomp/reloadgen.ml
+++ b/asmcomp/reloadgen.ml
@@ -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
diff --git a/asmcomp/schedgen.ml b/asmcomp/schedgen.ml
index a5dfcfdbf3..89c031d1b7 100644
--- a/asmcomp/schedgen.ml
+++ b/asmcomp/schedgen.ml
@@ -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
 
diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml
index d6eba0ff4f..e2ffd34ac8 100644
--- a/asmcomp/selectgen.ml
+++ b/asmcomp/selectgen.ml
@@ -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
 
diff --git a/asmcomp/spill.ml b/asmcomp/spill.ml
index 874f73579b..7b055959e8 100644
--- a/asmcomp/spill.ml
+++ b/asmcomp/spill.ml
@@ -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 }
diff --git a/asmcomp/split.ml b/asmcomp/split.ml
index 8c5e22703d..da5cdf1f5e 100644
--- a/asmcomp/split.ml
+++ b/asmcomp/split.ml
@@ -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 }