DWARF inlined frames support

Author: mshinwell

backend/arm64/emit.mlp

@@ -1268,6 +1268,125 @@ let data l =
   `	.align  3\n`;
   List.iter emit_item l
 
+let emit_line str = emit_string (str ^ "\n")
+
+let file_emitter ~file_num ~file_name =
+  emit_line (Printf.sprintf ".file %d %S" file_num file_name)
+
+let build_asm_directives () : (module Asm_targets.Asm_directives_intf.S) = (
+  module Asm_targets.Asm_directives.Make(struct
+    let emit_line = emit_line
+
+    let get_file_num file_name =
+      Emitaux.get_file_num ~file_emitter file_name
+
+    let debugging_comments_in_asm_files =
+      !Flambda_backend_flags.dasm_comments
+
+    module D = struct
+      type constant =
+        | Int64 of Int64.t
+        | Label of string
+        | Add of constant * constant
+        | Sub of constant * constant
+
+      let rec string_of_constant const =
+        match const with
+        | Int64 n -> Int64.to_string n
+        | Label s -> s
+        | Add (c1, c2) ->
+          Printf.sprintf "(%s + %s)"
+            (string_of_constant c1) (string_of_constant c2)
+        | Sub (c1, c2) ->
+          Printf.sprintf "(%s - %s)"
+            (string_of_constant c1) (string_of_constant c2)
+
+      let const_int64 num = Int64 num
+      let const_label str = Label str
+      let const_add c1 c2 = Add (c1, c2)
+      let const_sub c1 c2 = Sub (c1, c2)
+
+      type data_type =
+        | NONE
+        | DWORD
+        | QWORD
+        | VEC128
+
+      let file = file_emitter
+
+      let loc ~file_num ~line ~col ?discriminator () =
+        ignore discriminator;
+        emit_line (Printf.sprintf ".loc %d %d %d" file_num line col)
+
+      let comment str =
+        emit_line (Printf.sprintf "; %s" str)
+
+      let label ?data_type str =
+        let _ = data_type in
+        emit_line (Printf.sprintf "%s:" str)
+
+      let section ?delayed:_ name flags args =
+        match name, flags, args with
+        | [".data" ], _, _ -> emit_line "\t.data"
+        | [".text" ], _, _ -> emit_line "\t.text"
+        | name, flags, args ->
+          emit_string (Printf.sprintf "\t.section %s"
+            (String.concat "," name));
+          begin match flags with
+          | None -> ()
+          | Some flags -> emit_string (Printf.sprintf ",%S" flags)
+          end;
+          begin match args with
+          | [] -> ()
+          | _ ->
+            emit_string (Printf.sprintf ",%s" (String.concat "," args))
+          end;
+          emit_string "\n"
+
+      let text () = emit_line "\t.text"
+
+      let new_line () = emit_line ""
+
+      let global sym = emit_line (Printf.sprintf "\t.globl %s" sym)
+
+      let protected _sym = ()  (* CR mshinwell: fixme *)
+
+      let type_ sym typ_ = emit_line (Printf.sprintf "\t.type %s,%s" sym typ_)
+
+      let byte const =
+        emit_line
+          (Printf.sprintf "\t.byte %s" (string_of_constant const))
+
+      let word const =
+        emit_line
+          (Printf.sprintf "\t.short %s" (string_of_constant const))
+
+      let long const =
+        emit_line
+          (Printf.sprintf "\t.long %s" (string_of_constant const))
+
+      let qword const =
+        emit_line
+          (Printf.sprintf "\t.quad %s" (string_of_constant const))
+
+      let bytes str =
+        emit_line (Printf.sprintf "\t.ascii %S" str)
+
+      let uleb128 const =
+        emit_line
+          (Printf.sprintf "\t.uleb128 %s" (string_of_constant const))
+
+      let sleb128 const =
+        emit_line
+          (Printf.sprintf "\t.sleb128 %s" (string_of_constant const))
+
+      let direct_assignment var const =
+        emit_line
+          (Printf.sprintf "\t.set %s,%s" var (string_of_constant const))
+    end
+  end)
+)
+
 (* Beginning / end of an assembly file *)
 
 let begin_assembly _unix =
@@ -1290,9 +1409,12 @@ let begin_assembly _unix =
     `	nop\n`;
     `	.align	3\n`
   end;
-  ()
+  let lbl_end = Cmm_helpers.make_symbol "code_end" in
+  Emitaux.Dwarf_helpers.begin_dwarf ~build_asm_directives
+    ~code_begin:lbl_begin ~code_end:lbl_end
+    ~file_emitter
 
-let end_assembly _dwarf =
+let end_assembly () =
   let lbl_end = Cmm_helpers.make_symbol "code_end" in
   emit_named_text_section lbl_end;
   `	.globl	{emit_symbol lbl_end}\n`;
@@ -1325,6 +1447,8 @@ let end_assembly _dwarf =
       efa_string = (fun s -> emit_string_directive "	.asciz	" s) };
   emit_symbol_type emit_symbol lbl "object";
   emit_symbol_size lbl;
+  if not !Flambda_backend_flags.internal_assembler then
+    Emitaux.Dwarf_helpers.emit_dwarf ();
   begin match Config.system with
   | "linux" ->
       (* Mark stack as non-executable *)

backend/arm64/proc.ml

@@ -405,17 +405,46 @@ let frame_required ~fun_contains_calls ~fun_num_stack_slots =
 let prologue_required ~fun_contains_calls ~fun_num_stack_slots =
   frame_required ~fun_contains_calls ~fun_num_stack_slots
 
-let frame_size ~stack_offset:_ ~fun_contains_calls:_ ~fun_num_stack_slots:_ =
-  Misc.fatal_error "Full DWARF support for arm64 not yet implemented"
+let compute_initial_stack_offset ~fun_contains_calls ~fun_num_stack_slots =
+    8 * fun_num_stack_slots.(0) +
+    8 * fun_num_stack_slots.(1) +
+    (if fun_contains_calls then 8 else 0)
+
+let frame_size ~stack_offset ~fun_contains_calls ~fun_num_stack_slots =
+  let sz =
+    stack_offset +
+    compute_initial_stack_offset ~fun_contains_calls ~fun_num_stack_slots
+  in Misc.align sz 16
 
 type slot_offset =
   | Bytes_relative_to_stack_pointer of int
   | Bytes_relative_to_domainstate_pointer of int
 [@@ocaml.warning "-37"]
 
-let slot_offset _loc ~stack_class:_ ~stack_offset:_ ~fun_contains_calls:_
-      ~fun_num_stack_slots:_ =
-  Misc.fatal_error "Full DWARF support for arm64 not yet implemented"
+let slot_offset (loc : Reg.stack_location) ~stack_class ~stack_offset
+      ~fun_contains_calls ~fun_num_stack_slots =
+  match loc with
+    Incoming n ->
+      assert (n >= 0);
+      let frame_size =
+        frame_size ~stack_offset ~fun_contains_calls
+          ~fun_num_stack_slots
+      in
+      Bytes_relative_to_stack_pointer (frame_size + n)
+  | Local n ->
+      let offset =
+        stack_offset +
+        (if stack_class = 0
+        then n * 8
+        else fun_num_stack_slots.(0) * 8 + n * 8)
+      in
+      Bytes_relative_to_stack_pointer offset
+  | Outgoing n ->
+      assert (n >= 0);
+      Bytes_relative_to_stack_pointer n
+  | Domainstate n ->
+      Bytes_relative_to_domainstate_pointer (
+        n + Domainstate.(idx_of_field Domain_extra_params) * 8)
 
 (* Calling the assembler *)
 

backend/debug/compute_ranges.ml

@@ -120,6 +120,17 @@ module Make (S : Compute_ranges_intf.S_functor) = struct
 
     let fold t ~init ~f = List.fold_left f init t.subranges
 
+    type get_singleton =
+      | No_ranges
+      | One_subrange of Subrange.t
+      | More_than_one_subrange
+
+    let get_singleton t =
+      match t.subranges with
+      | [] -> No_ranges
+      | [subrange] -> One_subrange subrange
+      | _ :: _ :: _ -> More_than_one_subrange
+
     let no_subranges t = match t.subranges with [] -> true | _ -> false
 
     let rewrite_labels_and_remove_empty_subranges t ~env =
@@ -272,6 +283,8 @@ module Make (S : Compute_ranges_intf.S_functor) = struct
          keeping things fast---but we still populate ranges for all parent
          blocks, thus avoiding any post-processing, by using [K.all_parents]
          here. *)
+      (* XXX this seems to be broken (e.g. removing parents when it shouldn't
+         be) *)
       KS.fold
         (fun key result ->
           List.fold_left

backend/debug/compute_ranges_intf.ml

@@ -216,6 +216,8 @@ module type S = sig
     (** The label at the start of the range. *)
     val start_pos : t -> Linear.label
 
+    (* CR mshinwell: use Targetint.t *)
+
     (** How many bytes from the label at [start_pos] the range actually
         commences. If this value is zero, then the first byte of the range has
         the address of the label given by [start_pos]. *)
@@ -251,6 +253,13 @@ module type S = sig
 
     (** Fold over all subranges within the given range. *)
     val fold : t -> init:'a -> f:('a -> Subrange.t -> 'a) -> 'a
+
+    type get_singleton = private
+      | No_ranges
+      | One_subrange of Subrange.t
+      | More_than_one_subrange
+
+    val get_singleton : t -> get_singleton
   end
 
   (** The type holding information on computed ranges. *)

backend/debug/dwarf/dwarf_flags/dwarf_flags.ml

@@ -72,7 +72,7 @@ let use_g () =
   then use_g1 ()
   else current_debug_settings := bytecode_g
 
-let restrict_to_upstream_dwarf = ref true
+let restrict_to_upstream_dwarf = ref false
 
 (* Currently the maximum number of stack slots, see asmgen.ml *)
 let dwarf_max_function_complexity = ref 50

backend/debug/dwarf/dwarf_ocaml/dwarf.ml

@@ -61,6 +61,9 @@ let create ~sourcefile ~unit_name ~asm_directives ~get_file_id ~code_begin
     DS.create ~compilation_unit_header_label ~compilation_unit_proto_die
       ~value_type_proto_die ~start_of_code_symbol debug_loc_table
       debug_ranges_table address_table location_list_table
+      ~get_file_num:get_file_id
+    (* CR mshinwell: does get_file_id successfully emit .file directives for
+       files we haven't seen before? *)
   in
   { state;
     asm_directives;
@@ -83,10 +86,15 @@ let dwarf_for_fundecl t fundecl ~fun_end_label =
         (fun fundecl -> Available_ranges_vars.create fundecl)
         ~accumulate:true fundecl
     in
+    let inlined_frame_ranges, fundecl =
+      Profile.record "debug_inlined_frame_ranges"
+        (fun fundecl -> Inlined_frame_ranges.create fundecl)
+        ~accumulate:true fundecl
+    in
     Dwarf_concrete_instances.for_fundecl ~get_file_id:t.get_file_id t.state
       fundecl
       ~fun_end_label:(Asm_label.create_int Text fun_end_label)
-      available_ranges_vars;
+      available_ranges_vars inlined_frame_ranges;
     { fun_end_label; fundecl }
 
 let emit t ~basic_block_sections ~binary_backend_available =