Reworked range entries.

The fist changes changes the offset for range entries to used labels
instead of integer constants, leaving the computation to the
assembler.

The second part of the change the address changes the way ranges
entries of scopes are printed. They need to be relative to the start
address of the code in the section they are included.

Bug 26234

3 files changed, 71 insertions, 39 deletions

diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml
index a45fff0c..5634d58c 100644
--- a/debug/DwarfPrinter.ml
+++ b/debug/DwarfPrinter.ml
@@ -244,6 +244,8 @@ module DwarfPrinter(Target: DWARF_TARGET):
     (* Mapping from abbreviation string to abbreviaton id *)
     let abbrev_mapping: (string,int) Hashtbl.t = Hashtbl.create 7
 
+    let range_labels : (int, int) Hashtbl.t = Hashtbl.create 7
+
     (* Look up the id of the abbreviation and add it if it is missing *)
     let get_abbrev entity has_sibling =
       let abbrev_string = abbrev_string_of_entity entity has_sibling in
@@ -439,8 +441,11 @@ module DwarfPrinter(Target: DWARF_TARGET):
       | Pc_pair (l,h) ->
           print_addr oc "DW_AT_low_pc" l;
           print_addr oc "DW_AT_high_pc" h
-      | Offset i -> fprintf oc "	.4byte		%a+0x%d%a\n"
-            label !debug_ranges_addr i print_comment "DW_AT_ranges"
+      | Offset i ->
+        let lbl = new_label () in
+        Hashtbl.add range_labels i lbl;
+        fprintf oc "	.4byte		%a+(%a-%a)%a\n"
+          label !debug_ranges_addr label lbl label !debug_ranges_addr print_comment "DW_AT_ranges"
       | _ -> ()
 
     let print_compilation_unit oc tag =
@@ -641,14 +646,23 @@ module DwarfPrinter(Target: DWARF_TARGET):
       end
 
     let print_ranges oc r =
+      let print_range_entry = function
+        | AddressRange l ->
+          List.iter (fun (b,e) ->
+              fprintf oc "	%s		%a\n" address label b;
+              fprintf oc "	%s		%a\n" address label e) l;
+        | OffsetRange (start, l) ->
+          List.iter (fun (b,e) ->
+              fprintf oc "	%s		%a-%a\n" address label b label start;
+              fprintf oc "	%s		%a-%a\n" address label e label start) l
+      in
       section oc Section_debug_ranges;
       print_label oc !debug_ranges_addr;
-      List.iter (fun l ->
-        List.iter (fun (b,e) ->
-          fprintf oc "	%s		%a\n" address label b;
-          fprintf oc "	%s		%a\n" address label e) l;
-        fprintf oc "	%s	0\n" address;
-        fprintf oc "	%s	0\n" address) r
+      List.iter (fun (lbl,l) ->
+          print_label oc (Hashtbl.find range_labels lbl);
+          print_range_entry l;
+          fprintf oc "	%s	0\n" address;
+          fprintf oc "	%s	0\n" address)  r
 
     let print_gnu_entries oc cp (lpc,loc) s r =
       compute_abbrev cp;
@@ -679,6 +693,7 @@ module DwarfPrinter(Target: DWARF_TARGET):
     (* Print the debug info and abbrev section *)
     let print_debug oc debug =
       Hashtbl.clear abbrev_mapping;
+      Hashtbl.clear range_labels;
       Hashtbl.clear loc_labels;
       match debug with
       | Diab entries -> print_diab_entries oc entries
diff --git a/debug/DwarfTypes.mli b/debug/DwarfTypes.mli
index 23aba448..5a2bce3b 100644
--- a/debug/DwarfTypes.mli
+++ b/debug/DwarfTypes.mli
@@ -272,9 +272,11 @@ type location_entry =
    }
 type dw_locations = constant option * location_entry list
 
-type range_entry = (address * address) list
+type range_entry =
+  | AddressRange  of (address * address) list
+  | OffsetRange of reference * (address * address) list
 
-type dw_ranges = range_entry list
+type dw_ranges = (int * range_entry) list
 
 type dw_string = (int * string) list
 
diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml
index 13ed6262..de07add1 100644
--- a/debug/Dwarfgen.ml
+++ b/debug/Dwarfgen.ml
@@ -72,7 +72,9 @@ let up_locs acc loc =
   {acc with locs = loc@acc.locs;}
 
 let up_ranges acc r =
-  {acc with ranges = r;}
+  let off, old_r = acc.ranges in
+  let new_r = (off +1 ), (off, r):: old_r in
+  (Offset off), {acc with ranges = new_r;}
 
 let empty_accu =
   {
@@ -90,6 +92,8 @@ module Dwarfgenaux (Target: TARGET) =
 
     let subrange_type : int option ref = ref None
 
+    let current_section_start : int option ref = ref None
+
     let encoding_of_ikind = function
       | IBool -> DW_ATE_boolean
       | IChar ->
@@ -424,7 +428,7 @@ module Dwarfgenaux (Target: TARGET) =
       let acc = up_locs (up_typs acc p.formal_parameter_type) loc_list in
       new_entry (next_id ()) (DW_TAG_formal_parameter p),acc
 
-    let scope_range f_id id (o,dwr) =
+    let scope_range f_id id acc =
       try
         let r = get_scope_ranges id in
         let lbl l h = match l,h with
@@ -435,19 +439,22 @@ module Dwarfgenaux (Target: TARGET) =
         | _ -> raise Not_found in
         begin
           match r with
-          | [] -> Empty,(o,dwr)
+          | [] -> Empty,acc
           | [a] ->
               let l,h = lbl a.start_addr a.end_addr in
-              Pc_pair (l,h),(o,dwr)
+              Pc_pair (l,h), acc
           | a::rest ->
               if !Clflags.option_gdwarf > 2 then
                 let r = List.map (fun e -> lbl e.start_addr e.end_addr) r in
-                (Offset o), (o + 2 + 4 * (List.length r),r::dwr)
-              else
+                let r = match !current_section_start with
+                  | None -> AddressRange r
+                  | Some s -> OffsetRange (s, r) in
+                up_ranges acc r
+             else
                 let l,h = lbl (List.hd (List.rev rest)).start_addr a.end_addr in
-                Pc_pair (l,h),(o,dwr)
+                Pc_pair (l,h), acc
         end
-      with Not_found -> Empty,(o,dwr)
+      with Not_found -> Empty, acc
 
     let rec local_variable_to_entry f_id acc v id =
       match v.lvar_atom with
@@ -466,11 +473,10 @@ module Dwarfgenaux (Target: TARGET) =
           Some (new_entry id (DW_TAG_variable var)),acc
 
     and scope_to_entry f_id acc sc id =
-      let r,dwr = scope_range f_id id acc.ranges in
+      let r, acc = scope_range f_id id acc in
       let scope = {
         lexical_block_range = r;
       } in
-      let acc = up_ranges acc dwr in
       let vars,acc = mmap_opt (local_to_entry  f_id) acc sc.scope_variables in
       let entry = new_entry id (DW_TAG_lexical_block scope) in
       add_children entry vars,acc
@@ -490,7 +496,7 @@ module Dwarfgenaux (Target: TARGET) =
           | Scope sc -> mmap_opt (local_to_entry f_id) acc sc.scope_variables
           | _ -> assert false)
 
-    let function_to_entry acc id f =
+    let function_to_entry sec_name acc id f =
       let r = match f.fun_low_pc, f.fun_high_pc with
       | Some l,Some h -> Pc_pair (l,h)
       | _ -> Empty in
@@ -503,8 +509,13 @@ module Dwarfgenaux (Target: TARGET) =
         subprogram_range = r;
       } in
       let f_id = get_opt_val f.fun_atom in
+      let start_sec =
+        try
+          Some (section_start (sec_name f_id))
+        with Not_found -> None in
+      current_section_start := start_sec;
       let acc = match f.fun_return_type with Some s -> up_typs acc s | None -> acc in
-      let f_entry =  new_entry id (DW_TAG_subprogram f_tag) in
+      let f_entry = new_entry id (DW_TAG_subprogram f_tag) in
       let children,acc =
         if !Clflags.option_gdepth > 1 then
           let params,acc = mmap (function_parameter_to_entry f_id) acc f.fun_parameter in
@@ -514,10 +525,11 @@ module Dwarfgenaux (Target: TARGET) =
           [],acc in
       add_children f_entry (children),acc
 
-    let definition_to_entry acc id t =
+    let definition_to_entry sec_name acc id t =
       match t with
-      | GlobalVariable g -> global_variable_to_entry acc id g
-      | Function f -> function_to_entry acc id f
+      | GlobalVariable g -> Some (global_variable_to_entry acc id g)
+      | Function f ->
+          Some (function_to_entry sec_name acc id f)
 
   end
 
@@ -535,14 +547,15 @@ let prod_name =
   Printf.sprintf "AbsInt Angewandte Informatik GmbH:CompCert Version %s:(%s,%s,%s,%s)"
     version_string Configuration.arch Configuration.system Configuration.abi Configuration.model
 
-let diab_gen_compilation_section s defs acc =
+let diab_gen_compilation_section sec_name s defs acc =
   let module Gen = Dwarfgenaux(struct
     let file_loc = diab_file_loc s
     let string_entry s =  Simple_string s
   end) in
   let defs,accu = List.fold_left (fun (acc,bcc) (id,t) ->
-    let t,bcc = Gen.definition_to_entry bcc id t in
-    t::acc,bcc) ([],empty_accu) defs in
+      match Gen.definition_to_entry sec_name bcc id t with
+      | Some (t,bcc) -> t::acc,bcc
+      | None -> acc,bcc) ([],empty_accu) defs in
   let low_pc = section_start s
   and line_start,debug_start = diab_additional_section s
   and high_pc = section_end s in
@@ -569,7 +582,7 @@ let gen_diab_debug_info sec_name var_section : debug_entries =
     | Function f -> sec_name (get_opt_val f.fun_atom) in
     let old = try StringMap.find s acc with Not_found -> [] in
     StringMap.add s ((id,t)::old) acc) StringMap.empty in
-  let entries = StringMap.fold diab_gen_compilation_section defs [] in
+  let entries = StringMap.fold (diab_gen_compilation_section sec_name) defs [] in
   Diab entries
 
 let gnu_file_loc (f,l) =
@@ -592,30 +605,32 @@ let gnu_string_entry s =
 
 let gen_gnu_debug_info sec_name var_section : debug_entries =
   Hashtbl.clear string_table;
-  let r,dwr,low_pc =
+  let r,accu,low_pc =
     try if !Clflags.option_gdwarf > 2 then
         let pcs  = fold_section_start (fun s low acc ->
           (low,section_end s)::acc) [] in
         match pcs with
-        | [] ->  Empty,(0,[]),None
-        | [(l,h)] ->   Pc_pair (l,h),(0,[]),Some l
-        | _ -> Offset 0,(2 + 4 * (List.length pcs),[pcs]),None
+        | [] ->  Empty, empty_accu, None
+        | [(l,h)] ->   Pc_pair (l,h), empty_accu, Some l
+        | _ ->
+          let off, acc = up_ranges empty_accu (AddressRange pcs) in
+          off, acc, None
     else
         let l = section_start ".text"
         and h = section_end ".text" in
-        Pc_pair(l,h),(0,[]),Some l
-    with Not_found ->  Empty,(0,[]),None in
-  let accu = up_ranges empty_accu dwr in
+        Pc_pair(l,h), empty_accu,Some l
+    with Not_found ->  Empty ,empty_accu, None in
   let module Gen = Dwarfgenaux (struct
     let file_loc = gnu_file_loc
     let string_entry = gnu_string_entry
   end) in
-  let defs,accu,sec = fold_definitions (fun  id t (acc,bcc,sec) ->
+  let defs,accu,sec = fold_definitions (fun id t (acc,bcc,sec) ->
     let s = match t with
     | GlobalVariable _ -> var_section
     | Function f -> sec_name (get_opt_val f.fun_atom) in
-    let t,bcc = Gen.definition_to_entry bcc id t in
-    t::acc,bcc,StringSet.add s sec) ([],accu,StringSet.empty) in
+    match Gen.definition_to_entry sec_name bcc id t with
+    | Some (t,bcc) -> t::acc,bcc,StringSet.add s sec
+    | None -> acc, bcc, sec) ([],accu,StringSet.empty) in
   let types = Gen.gen_types accu.typs in
   let cp = {
     compile_unit_name = gnu_string_entry !file_name;