diff options
| -rw-r--r-- | debug/DwarfPrinter.ml | 31 | ||||
| -rw-r--r-- | debug/DwarfTypes.mli | 6 | ||||
| -rw-r--r-- | debug/Dwarfgen.ml | 73 |
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; |