Implemented the usage of DW_AT_ranges for non-contiguous address ranges.

The gcc produces DW_AT_ranges for non-contiguous address ranges, like
compilation units containing functions which are placed in different
ELF-sections or lexical scopes that are split up. With this commit
CompCert also uses this DWARF v3 feature for gnu backend based targets.
In order to ensure backward compability a flag is added which avoids
this and produces debug info in DWARF v2 format.
Bug 17392.

1 files changed, 96 insertions, 50 deletions

diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml
index 980c8a34..56a318fe 100644
--- a/debug/Dwarfgen.ml
+++ b/debug/Dwarfgen.ml
@@ -56,6 +56,29 @@ module type TARGET =
       val string_entry: string -> string_const
     end
 
+type dwarf_accu =
+    {
+     typs:  IntSet.t;
+     locs:   location_entry list;
+     ranges: int * dw_ranges
+   }
+
+let (=<<) acc t =
+  {acc with typs = IntSet.add t acc.typs;}
+
+let (<=<) acc loc =
+  {acc with locs = loc@acc.locs;}
+
+let (>>=) acc r =
+  {acc with ranges = r;}
+
+let empty_accu =
+  {
+   typs = IntSet.empty;
+   locs = [];
+   ranges = 0,[]
+ }
+
 module Dwarfgenaux (Target: TARGET) =
   struct
 
@@ -304,7 +327,8 @@ module Dwarfgenaux (Target: TARGET) =
         variable_type = v.gvar_type;
         variable_location = loc;
       } in
-      new_entry id (DW_TAG_variable var),IntSet.add v.gvar_type acc
+      let acc = acc =<< v.gvar_type in
+      new_entry id (DW_TAG_variable var),acc
 
     let gen_splitlong op_hi op_lo =
       let op_piece = DW_OP_piece 4 in
@@ -359,7 +383,7 @@ module Dwarfgenaux (Target: TARGET) =
         end
       with Not_found -> None,[]
 
-    let function_parameter_to_entry f_id (acc,bcc) p =
+    let function_parameter_to_entry f_id acc p =
       let loc,loc_list = location_entry f_id (get_opt_val p.parameter_atom) in
       let p = {
         formal_parameter_artificial = None;
@@ -368,11 +392,37 @@ module Dwarfgenaux (Target: TARGET) =
         formal_parameter_variable_parameter = None;
         formal_parameter_location = loc;
       } in
-      new_entry (next_id ()) (DW_TAG_formal_parameter p),(IntSet.add p.formal_parameter_type acc,loc_list@bcc)
+      let acc = (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) =
+      try
+        let r = Hashtbl.find scope_ranges id in
+        let lbl l h = match l,h with
+        | Some l,Some h->
+            let l = (Hashtbl.find label_translation (f_id,l))
+            and h = (Hashtbl.find label_translation (f_id,h)) in
+            l,h
+        | _ -> raise Not_found in
+        begin
+          match r with
+          | [] -> Empty,(o,dwr)
+          | [a] ->
+              let l,h = lbl a.start_addr a.end_addr in
+              Pc_pair (l,h),(o,dwr)
+          | 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 l,h = lbl (List.hd (List.rev rest)).start_addr a.end_addr in
+                Pc_pair (l,h),(o,dwr)
+        end
+      with Not_found -> Empty,(o,dwr)
 
-    let rec local_variable_to_entry f_id (acc,bcc) v id =
+    let rec local_variable_to_entry f_id acc v id =
       match v.lvar_atom with
-      | None -> None,(acc,bcc)
+      | None -> None,acc
       | Some loc ->
           let loc,loc_list = location_entry f_id loc in
           let var = {
@@ -383,36 +433,22 @@ module Dwarfgenaux (Target: TARGET) =
             variable_type = v.lvar_type;
             variable_location = loc;
           } in
-          Some (new_entry id (DW_TAG_variable var)),(IntSet.add v.lvar_type acc,loc_list@bcc)
+          let acc = (acc =<< v.lvar_type) <=< loc_list in
+          Some (new_entry id (DW_TAG_variable var)),acc
 
-    and scope_to_entry  f_id acc sc id =
-      let r = try
-        let r = Hashtbl.find scope_ranges id in
-        let lbl l h = match l,h with
-        | Some l,Some h->
-            let l = (Hashtbl.find label_translation (f_id,l))
-            and h = (Hashtbl.find label_translation (f_id,h)) in
-            Pc_pair(l,h)
-        | _ -> Empty in
-        begin
-          match r with
-          | [] -> Empty
-          | [a] -> lbl a.start_addr a.end_addr
-          | a::rest -> lbl (List.hd (List.rev rest)).start_addr  a.end_addr
-        end
-      with Not_found -> Empty in
+    and scope_to_entry f_id acc sc id =
+      let r,dwr = scope_range f_id id acc.ranges in
       let scope = {
         lexical_block_range = r;
       } 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
+      add_children entry vars,(acc >>= dwr)
 
     and local_to_entry f_id acc id =
       match Hashtbl.find local_variables id with
       | LocalVariable v -> local_variable_to_entry f_id acc v id
-      | Scope v -> let s,acc =
-          (scope_to_entry f_id acc v id) in
+      | Scope v -> let s,acc = (scope_to_entry f_id acc v id) in
         Some s,acc
 
     let fun_scope_to_entries f_id acc id =
@@ -421,10 +457,10 @@ module Dwarfgenaux (Target: TARGET) =
       | Some id ->
           let sc = Hashtbl.find local_variables id in
           (match sc with
-          | Scope sc ->mmap_opt (local_to_entry f_id) acc sc.scope_variables
+          | Scope sc -> mmap_opt (local_to_entry f_id) acc sc.scope_variables
           | _ -> assert false)
 
-    let function_to_entry (acc,bcc) id f =
+    let function_to_entry 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
@@ -437,17 +473,16 @@ module Dwarfgenaux (Target: TARGET) =
         subprogram_range = r;
       } in
       let f_id = get_opt_val f.fun_atom in
-      let acc = match f.fun_return_type with Some s -> IntSet.add s acc | None -> acc in
+      let acc = match f.fun_return_type with Some s -> acc =<< s | None -> acc in
       let f_entry =  new_entry id (DW_TAG_subprogram f_tag) in
-      let params,(acc,bcc) = mmap (function_parameter_to_entry f_id) (acc,bcc) f.fun_parameter in
-      let vars,(acc,bcc) = fun_scope_to_entries f_id (acc,bcc) f.fun_scope in
-      add_children f_entry (params@vars),(acc,bcc)
+      let params,acc = mmap (function_parameter_to_entry f_id) acc f.fun_parameter in
+      let vars,acc = fun_scope_to_entries f_id acc f.fun_scope in
+      add_children f_entry (params@vars),acc
 
-    let definition_to_entry (acc,bcc) id t =
+    let definition_to_entry acc id t =
       match t with
-      | GlobalVariable g -> let e,acc = global_variable_to_entry acc id g in
-        e,(acc,bcc)
-      | Function f -> function_to_entry (acc,bcc) id f
+      | GlobalVariable g -> global_variable_to_entry acc id g
+      | Function f -> function_to_entry acc id f
 
   end
 
@@ -468,10 +503,11 @@ let prod_name =
 let diab_gen_compilation_section 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,(ty,locs) = List.fold_left (fun (acc,bcc) (id,t) ->
-    let t,bcc = Gen.definition_to_entry  bcc id t in
-    t::acc,bcc) ([],(IntSet.empty,[])) defs in
+    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
   let low_pc = Hashtbl.find compilation_section_start s
   and line_start,debug_start,_ = Hashtbl.find diab_additional s
   and high_pc = Hashtbl.find compilation_section_end s in
@@ -482,13 +518,13 @@ let diab_gen_compilation_section s defs acc =
     compile_unit_prod_name = Simple_string prod_name
   } in
   let cp = new_entry (next_id ()) (DW_TAG_compile_unit cp) in
-  let cp = add_children cp ((Gen.gen_types ty) @ defs) in
+  let cp = add_children cp ((Gen.gen_types accu.typs) @ defs) in
   {
     section_name = s;
     start_label = debug_start;
     line_label = line_start;
     entry = cp;
-    locs = Some low_pc,locs;
+    locs = Some low_pc,accu.locs;
   }::acc
 
 let gen_diab_debug_info sec_name var_section : debug_entries =
@@ -517,23 +553,33 @@ let gnu_string_entry s =
       Hashtbl.add string_table s id;
       Offset_string id
 
+
 let gen_gnu_debug_info sec_name var_section : debug_entries =
-  let r,low_pc = try
-    let low_pc = Hashtbl.find compilation_section_start ".text"
-    and high_pc = Hashtbl.find compilation_section_end ".text" in
-    Pc_pair (low_pc,high_pc),Some low_pc
-  with Not_found -> Empty,None in
+  let r,dwr,low_pc =
+    try if !Clflags.option_gdwarf > 3 then
+        let pcs  = Hashtbl.fold (fun s low acc ->
+          (low,Hashtbl.find compilation_section_end s)::acc) compilation_section_start [] 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
+    else
+        let l = Hashtbl.find compilation_section_start ".text"
+        and h = Hashtbl.find compilation_section_end ".text" in
+        Pc_pair(l,h),(0,[]),Some l
+    with Not_found ->  Empty,(0,[]),None in
+  let accu = empty_accu >>= dwr in
   let module Gen = Dwarfgenaux (struct
     let file_loc = gnu_file_loc
     let string_entry = gnu_string_entry
   end) in
-  let defs,(ty,locs),sec = Hashtbl.fold (fun  id t (acc,bcc,sec) ->
+  let defs,accu,sec = Hashtbl.fold (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) definitions ([],(IntSet.empty,[]),StringSet.empty) in
-  let types = Gen.gen_types ty in
+    t::acc,bcc,StringSet.add s sec) definitions ([],accu,StringSet.empty) in
+  let types = Gen.gen_types accu.typs in
   let cp = {
     compile_unit_name = gnu_string_entry !file_name;
     compile_unit_range = r;
@@ -544,4 +590,4 @@ let gen_gnu_debug_info sec_name var_section : debug_entries =
   let cp = add_children cp (types@defs) in
   let loc_pc = if StringSet.cardinal sec > 1 then None else low_pc in
   let string_table = Hashtbl.fold (fun s i acc -> (i,s)::acc) string_table [] in
-  Gnu (cp,(loc_pc,locs),string_table)
+  Gnu (cp,(loc_pc,accu.locs),string_table,snd accu.ranges)