From 55eb2d92376f592258855cfa5c0cfbbf39e8e833 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Tue, 6 Oct 2015 11:08:58 +0200 Subject: Fast fix for functions in different sections in one compilation unit for gcc. --- debug/DwarfPrinter.ml | 15 ++++++++++++++- debug/DwarfTypes.mli | 2 +- debug/Dwarfgen.ml | 12 ++++++++---- 3 files changed, 23 insertions(+), 6 deletions(-) (limited to 'debug') diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index 980c49db..2a54fa6a 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -590,8 +590,21 @@ module DwarfPrinter(Target: DWARF_TARGET): fprintf oc " .4byte 0\n"; fprintf oc " .4byte 0\n" + let print_location_entry_abs oc l = + print_label oc (loc_to_label l.loc_id); + List.iter (fun (b,e,loc) -> + fprintf oc " .4byte %a\n" label b; + fprintf oc " .4byte %a\n" label e; + print_list_loc oc loc) l.loc; + fprintf oc " .4byte 0\n"; + fprintf oc " .4byte 0\n" + + let print_location_list oc (c_low,l) = - List.iter (print_location_entry oc c_low) l + let f = match c_low with + | Some s -> print_location_entry oc s + | None -> print_location_entry_abs oc in + List.iter f l let print_diab_entries oc entries = let abbrev_start = new_label () in diff --git a/debug/DwarfTypes.mli b/debug/DwarfTypes.mli index ed75b3d7..8f03eb8d 100644 --- a/debug/DwarfTypes.mli +++ b/debug/DwarfTypes.mli @@ -247,7 +247,7 @@ type location_entry = loc: (int * int * location_value) list; loc_id: reference; } -type dw_locations = int * location_entry list +type dw_locations = int option * location_entry list type diab_entries = (string * int * int * dw_entry * dw_locations) list diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml index 2258f948..eff80110 100644 --- a/debug/Dwarfgen.ml +++ b/debug/Dwarfgen.ml @@ -463,7 +463,7 @@ let gen_diab_debug_info sec_name var_section : debug_entries = } in let cp = new_entry (next_id ()) (DW_TAG_compile_unit cp) in let cp = add_children cp ((gen_types (diab_file_loc s) ty) @ defs) in - (s,debug_start,line_start,cp,(low_pc,locs))::acc) defs [] in + (s,debug_start,line_start,cp,(Some low_pc,locs))::acc) defs [] in Diab entries let gnu_file_loc (f,l) = @@ -472,9 +472,12 @@ let gnu_file_loc (f,l) = let gen_gnu_debug_info sec_name var_section : debug_entries = let low_pc = Hashtbl.find compilation_section_start ".text" and high_pc = Hashtbl.find compilation_section_end ".text" in - let defs,(ty,locs) = Hashtbl.fold (fun id t (acc,bcc) -> + let defs,(ty,locs),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 = definition_to_entry gnu_file_loc bcc id t in - t::acc,bcc) definitions ([],(IntSet.empty,[])) in + t::acc,bcc,StringSet.add s sec) definitions ([],(IntSet.empty,[]),StringSet.empty) in let types = gen_types gnu_file_loc ty in let cp = { compile_unit_name = !file_name; @@ -483,4 +486,5 @@ let gen_gnu_debug_info sec_name var_section : debug_entries = } in let cp = new_entry (next_id ()) (DW_TAG_compile_unit cp) in let cp = add_children cp (types@defs) in - Gnu (cp,(low_pc,locs)) + let loc_pc = if StringSet.cardinal sec > 1 then None else Some low_pc in + Gnu (cp,(loc_pc,locs)) -- cgit From f95b422aaf3f675e1e3b916ac04740a5acaddd02 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Thu, 8 Oct 2015 12:40:12 +0200 Subject: Reset all Hashtables. --- debug/DebugInformation.ml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) (limited to 'debug') diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index 874dfb77..d1747f8e 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -692,9 +692,13 @@ let init name = Hashtbl.reset stamp_to_local; Hashtbl.reset atom_to_local; Hashtbl.reset scope_to_local; + Hashtbl.reset atom_to_scope; Hashtbl.reset compilation_section_start; Hashtbl.reset compilation_section_end; + Hashtbl.reset diab_additional; Hashtbl.reset filenum; + Hashtbl.reset var_locations; + Hashtbl.reset scope_ranges; + Hashtbl.reset label_translation; all_files := StringSet.singleton name; - Hashtbl.reset diab_additional; printed_vars := StringSet.empty; -- cgit From 0ffd562ae1941e37471ac0c2b8f93bed1de26441 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Fri, 9 Oct 2015 11:06:24 +0200 Subject: Filled in the rest of the funciton needed for thte debug info under arm. The name_of_section function no returns the correct name for the debug sections, the prologue and epilogue directives are added and the labels for the live ranges are introduced in the Asmexpand pass. --- debug/DwarfPrinter.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'debug') diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index 2a54fa6a..1bd54470 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -627,7 +627,7 @@ module DwarfPrinter(Target: DWARF_TARGET): print_abbrev oc; section oc Section_debug_loc; print_location_list oc loc; - fprintf oc " .section .debug_line,\"\",@progbits\n"; + section oc (Section_debug_line ""); print_label oc line_start (* Print the debug info and abbrev section *) -- cgit From 012827a7cba40f434b9fc6ce1b46dc725473eae7 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Mon, 12 Oct 2015 14:33:15 +0200 Subject: Unified function for adding the atom identifier. Instead of defining two functions for adding the mapping from atom to debug id we use one function which then sets the corresponding values. Bug 17392. --- debug/Debug.ml | 9 +++------ debug/Debug.mli | 6 ++---- debug/DebugInformation.ml | 28 +++++++++++++++++----------- debug/DebugInit.ml | 8 ++------ 4 files changed, 24 insertions(+), 27 deletions(-) (limited to 'debug') diff --git a/debug/Debug.ml b/debug/Debug.ml index 161ee3ed..22f913c5 100644 --- a/debug/Debug.ml +++ b/debug/Debug.ml @@ -23,8 +23,7 @@ open DwarfTypes type implem = { mutable init: string -> unit; - mutable atom_function: ident -> atom -> unit; - mutable atom_global_variable: ident -> atom -> unit; + mutable atom_global: ident -> atom -> unit; mutable set_composite_size: ident -> struct_or_union -> int option -> unit; mutable set_member_offset: ident -> string -> int -> unit; mutable set_bitfield_offset: ident -> string -> int -> string -> int -> unit; @@ -58,8 +57,7 @@ type implem = let implem = { init = (fun _ -> ()); - atom_function = (fun _ _ -> ()); - atom_global_variable = (fun _ _ -> ()); + atom_global = (fun _ _ -> ()); set_composite_size = (fun _ _ _ -> ()); set_member_offset = (fun _ _ _ -> ()); set_bitfield_offset = (fun _ _ _ _ _ -> ()); @@ -91,8 +89,7 @@ let implem = } let init_compile_unit name = implem.init name -let atom_function id atom = implem.atom_function id atom -let atom_global_variable id atom = implem.atom_global_variable id atom +let atom_global id atom = implem.atom_global id atom let set_composite_size id sou size = implem.set_composite_size id sou size let set_member_offset id field off = implem.set_member_offset id field off let set_bitfield_offset id field off underlying size = implem.set_bitfield_offset id field off underlying size diff --git a/debug/Debug.mli b/debug/Debug.mli index 577b0ef8..94862844 100644 --- a/debug/Debug.mli +++ b/debug/Debug.mli @@ -21,8 +21,7 @@ open BinNums type implem = { mutable init: string -> unit; - mutable atom_function: ident -> atom -> unit; - mutable atom_global_variable: ident -> atom -> unit; + mutable atom_global: ident -> atom -> unit; mutable set_composite_size: ident -> struct_or_union -> int option -> unit; mutable set_member_offset: ident -> string -> int -> unit; mutable set_bitfield_offset: ident -> string -> int -> string -> int -> unit; @@ -56,8 +55,7 @@ type implem = val implem: implem val init_compile_unit: string -> unit -val atom_function: ident -> atom -> unit -val atom_global_variable: ident -> atom -> unit +val atom_global: ident -> atom -> unit val set_composite_size: ident -> struct_or_union -> int option -> unit val set_member_offset: ident -> string -> int -> unit val set_bitfield_offset: ident -> string -> int -> string -> int -> unit diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index d1747f8e..4c566744 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -302,9 +302,6 @@ let local_variables: (int, local_information) Hashtbl.t = Hashtbl.create 7 (* Mapping from stampt to the debug id of the local variable *) let stamp_to_local: (int,int) Hashtbl.t = Hashtbl.create 7 -(* Mapping form atom to the debug id of the local variable *) -let atom_to_local: (atom, int) Hashtbl.t = Hashtbl.create 7 - (* Map from scope id + function id to debug id *) let scope_to_local: (int * int,int) Hashtbl.t = Hashtbl.create 7 @@ -492,6 +489,21 @@ let atom_function id atom = Hashtbl.add atom_to_scope (atom,sid) tid) scope_to_local with Not_found -> () +let atom_global id atom = + try + let id' = (Hashtbl.find stamp_to_definition id.stamp) in + let g = Hashtbl.find definitions id' in + match g with + | Function f -> + replace_fun id' ({f with fun_atom = Some atom;}); + Hashtbl.add atom_to_definition atom id'; + Hashtbl.iter (fun (fid,sid) tid -> if fid = id.stamp then + Hashtbl.add atom_to_scope (atom,sid) tid) scope_to_local + | GlobalVariable var -> + replace_var id' ({var with gvar_atom = Some atom;}); + Hashtbl.add atom_to_definition atom id' + with Not_found -> () + let atom_parameter fid id atom = try let fid',f = find_fun_stamp fid.stamp in @@ -509,8 +521,7 @@ let add_fun_addr atom (high,low) = let atom_local_variable id atom = try let id,var = find_lvar_stamp id.stamp in - replace_lvar id ({var with lvar_atom = Some atom;}); - Hashtbl.add atom_to_local atom id + replace_lvar id ({var with lvar_atom = Some atom;}) with Not_found -> () let add_lvar_scope f_id var_id s_id = @@ -589,7 +600,6 @@ module IntSet = Set.Make(struct end) let open_scopes: IntSet.t ref = ref IntSet.empty -let open_vars: atom list ref = ref [] let open_scope atom s_id lbl = try @@ -620,7 +630,6 @@ let start_live_range (f,v) lbl loc = match old_r with | RangeLoc old_r -> let n_r = { range_start = Some lbl; range_end = None; var_loc = loc } in - open_vars := v::!open_vars; Hashtbl.replace var_locations (f,v) (RangeLoc (n_r::old_r)) | _ -> () (* Parameter that is passed as variable *) @@ -640,9 +649,7 @@ let stack_variable (f,v) (sp,loc) = let function_end atom loc = IntSet.iter (fun id -> close_scope atom id loc) !open_scopes; - open_scopes := IntSet.empty; - List.iter (fun id-> end_live_range (atom,id) loc) !open_vars; - open_vars:= [] + open_scopes := IntSet.empty let compilation_section_start: (string,int) Hashtbl.t = Hashtbl.create 7 let compilation_section_end: (string,int) Hashtbl.t = Hashtbl.create 7 @@ -690,7 +697,6 @@ let init name = Hashtbl.reset atom_to_definition; Hashtbl.reset local_variables; Hashtbl.reset stamp_to_local; - Hashtbl.reset atom_to_local; Hashtbl.reset scope_to_local; Hashtbl.reset atom_to_scope; Hashtbl.reset compilation_section_start; diff --git a/debug/DebugInit.ml b/debug/DebugInit.ml index 7ee56ff1..09714628 100644 --- a/debug/DebugInit.ml +++ b/debug/DebugInit.ml @@ -20,8 +20,7 @@ open Debug let init_debug () = implem.init <- DebugInformation.init; - implem.atom_function <- DebugInformation.atom_function; - implem.atom_global_variable <- DebugInformation.atom_global_variable; + implem.atom_global <- DebugInformation.atom_global; implem.set_composite_size <- DebugInformation.set_composite_size; implem.set_member_offset <- DebugInformation.set_member_offset; implem.set_bitfield_offset <- DebugInformation.set_bitfield_offset; @@ -43,7 +42,6 @@ let init_debug () = implem.start_live_range <- DebugInformation.start_live_range; implem.end_live_range <- DebugInformation.end_live_range; implem.stack_variable <- DebugInformation.stack_variable; - implem.function_end <- DebugInformation.function_end; implem.add_label <- DebugInformation.add_label; implem.atom_parameter <- DebugInformation.atom_parameter; implem.add_compilation_section_start <- DebugInformation.add_compilation_section_start; @@ -57,8 +55,7 @@ let init_debug () = let init_none () = implem.init <- (fun _ -> ()); - implem.atom_function <- (fun _ _ -> ()); - implem.atom_global_variable <- (fun _ _ -> ()); + implem.atom_global <- (fun _ _ -> ()); implem.set_composite_size <- (fun _ _ _ -> ()); implem.set_member_offset <- (fun _ _ _ -> ()); implem.set_bitfield_offset <- (fun _ _ _ _ _ -> ()); @@ -76,7 +73,6 @@ let init_none () = implem.start_live_range <- (fun _ _ _ -> ()); implem.end_live_range <- (fun _ _ -> ()); implem.stack_variable <- (fun _ _ -> ()); - implem.function_end <- (fun _ _ -> ()); implem.add_label <- (fun _ _ _ -> ()); implem.atom_parameter <- (fun _ _ _ -> ()); implem.add_compilation_section_start <- (fun _ _ -> ()); -- cgit From a68c024bd8421cda0d21802669cb01730d109378 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Mon, 12 Oct 2015 14:37:46 +0200 Subject: Do not insert atom to global variable mapping. The atom to global variable debug id mapping is never used so we do not need to insert global variables into it. Bug 17392. --- debug/DebugInformation.ml | 19 +------------------ 1 file changed, 1 insertion(+), 18 deletions(-) (limited to 'debug') diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index 4c566744..3e40fa41 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -473,22 +473,6 @@ let set_bitfield_offset str field offset underlying size = comp.ct_members in {comp with ct_members = members;}) -let atom_global_variable id atom = - try - let id,var = find_gvar_stamp id.stamp in - replace_var id ({var with gvar_atom = Some atom;}); - Hashtbl.add atom_to_definition atom id - with Not_found -> () - -let atom_function id atom = - try - let id',f = find_fun_stamp id.stamp in - replace_fun id' ({f with fun_atom = Some atom;}); - Hashtbl.add atom_to_definition atom id'; - Hashtbl.iter (fun (fid,sid) tid -> if fid = id.stamp then - Hashtbl.add atom_to_scope (atom,sid) tid) scope_to_local - with Not_found -> () - let atom_global id atom = try let id' = (Hashtbl.find stamp_to_definition id.stamp) in @@ -500,8 +484,7 @@ let atom_global id atom = Hashtbl.iter (fun (fid,sid) tid -> if fid = id.stamp then Hashtbl.add atom_to_scope (atom,sid) tid) scope_to_local | GlobalVariable var -> - replace_var id' ({var with gvar_atom = Some atom;}); - Hashtbl.add atom_to_definition atom id' + replace_var id' ({var with gvar_atom = Some atom;}) with Not_found -> () let atom_parameter fid id atom = -- cgit From 906873ee165cbaabf36ca51792eb5a498a12bd72 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Mon, 12 Oct 2015 16:58:23 +0200 Subject: Move strip functions to Cutil. Since the strip functions might be useful in other context and is more general then the debug information. Bug 17392. --- debug/DebugInformation.ml | 42 +----------------------------------------- 1 file changed, 1 insertion(+), 41 deletions(-) (limited to 'debug') diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index 3e40fa41..96355d66 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -60,47 +60,7 @@ let typ_to_string (ty: typ) = Buffer.contents buf (* Helper functions for the attributes *) -let strip_attributes typ = - let strip = List.filter (fun a -> a = AConst || a = AVolatile) in - match typ with - | TVoid at -> TVoid (strip at) - | TInt (k,at) -> TInt (k,strip at) - | TFloat (k,at) -> TFloat(k,strip at) - | TPtr (t,at) -> TPtr(t,strip at) - | TArray (t,s,at) -> TArray(t,s,strip at) - | TFun (t,arg,v,at) -> TFun(t,arg,v,strip at) - | TNamed (n,at) -> TNamed(n,strip at) - | TStruct (n,at) -> TStruct(n,strip at) - | TUnion (n,at) -> TUnion(n,strip at) - | TEnum (n,at) -> TEnum(n,strip at) - -let strip_last_attribute typ = - let rec hd_opt l = match l with - [] -> None,[] - | AConst::rest -> Some AConst,rest - | AVolatile::rest -> Some AVolatile,rest - | _::rest -> hd_opt rest in - match typ with - | TVoid at -> let l,r = hd_opt at in - l,TVoid r - | TInt (k,at) -> let l,r = hd_opt at in - l,TInt (k,r) - | TFloat (k,at) -> let l,r = hd_opt at in - l,TFloat (k,r) - | TPtr (t,at) -> let l,r = hd_opt at in - l,TPtr(t,r) - | TArray (t,s,at) -> let l,r = hd_opt at in - l,TArray(t,s,r) - | TFun (t,arg,v,at) -> let l,r = hd_opt at in - l,TFun(t,arg,v,r) - | TNamed (n,at) -> let l,r = hd_opt at in - l,TNamed(n,r) - | TStruct (n,at) -> let l,r = hd_opt at in - l,TStruct(n,r) - | TUnion (n,at) -> let l,r = hd_opt at in - l,TUnion(n,r) - | TEnum (n,at) -> let l,r = hd_opt at in - l,TEnum(n,r) +let strip_attributes typ = strip_attributes_type typ [AConst;AVolatile] (* Does the type already exist? *) let exist_type (ty: typ) = -- cgit From 9873f9ee01c6ccca88fd461d318e107ff303fe88 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Mon, 12 Oct 2015 18:39:31 +0200 Subject: Use a more descriptive type for diab debug entries. Instead of using a tuple we now use a record with descriptive names for the different entries. Bug 17392 --- debug/DwarfPrinter.ml | 18 +++++++----------- debug/DwarfTypes.mli | 11 ++++++++++- debug/Dwarfgen.ml | 9 ++++++++- 3 files changed, 25 insertions(+), 13 deletions(-) (limited to 'debug') diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index 1bd54470..e2f062d8 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -559,11 +559,6 @@ module DwarfPrinter(Target: DWARF_TARGET): if e.children <> [] then print_sleb128 oc 0) entry - (* Print the debug abbrev section *) - let print_debug_abbrev oc entries = - List.iter (fun (_,_,_,e,_) -> compute_abbrev e) entries; - print_abbrev oc - (* Print the debug info section *) let print_debug_info oc start line_start entry = Hashtbl.reset entry_labels; @@ -608,13 +603,14 @@ module DwarfPrinter(Target: DWARF_TARGET): let print_diab_entries oc entries = let abbrev_start = new_label () in - abbrev_start_addr := abbrev_start; - print_debug_abbrev oc entries; - List.iter (fun (s,d,l,e,_) -> - section oc (Section_debug_info s); - print_debug_info oc d l e) entries; + abbrev_start_addr := abbrev_start; + List.iter (fun e -> compute_abbrev e.entry) entries; + print_abbrev oc; + List.iter (fun e -> + section oc (Section_debug_info e.section_name); + print_debug_info oc e.start_label e.line_label e.entry) entries; section oc Section_debug_loc; - List.iter (fun (_,_,_,_,l) -> print_location_list oc l) entries + List.iter (fun e -> print_location_list oc e.locs) entries let print_gnu_entries oc cp loc = compute_abbrev cp; diff --git a/debug/DwarfTypes.mli b/debug/DwarfTypes.mli index 8f03eb8d..233ada2e 100644 --- a/debug/DwarfTypes.mli +++ b/debug/DwarfTypes.mli @@ -249,7 +249,16 @@ type location_entry = } type dw_locations = int option * location_entry list -type diab_entries = (string * int * int * dw_entry * dw_locations) list +type diab_entry = + { + section_name: string; + start_label: int; + line_label: int; + entry: dw_entry; + locs: dw_locations; + } + +type diab_entries = diab_entry list type gnu_entries = dw_entry * dw_locations diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml index eff80110..8048ea43 100644 --- a/debug/Dwarfgen.ml +++ b/debug/Dwarfgen.ml @@ -463,7 +463,14 @@ let gen_diab_debug_info sec_name var_section : debug_entries = } in let cp = new_entry (next_id ()) (DW_TAG_compile_unit cp) in let cp = add_children cp ((gen_types (diab_file_loc s) ty) @ defs) in - (s,debug_start,line_start,cp,(Some low_pc,locs))::acc) defs [] in + let entry = { + section_name = s; + start_label = debug_start; + line_label = line_start; + entry = cp; + locs = Some low_pc,locs; + } in + entry::acc) defs [] in Diab entries let gnu_file_loc (f,l) = -- cgit From 3b0bbd7a60771265ff81cc98310d413130ae4d79 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Mon, 12 Oct 2015 19:09:42 +0200 Subject: Changed definition of implem for debug information. Instead of making each filed mutuable we use a reference to a record of type implem. Now only the default implementation and the default debug information need to be upated to add a new function. Bug 17392. --- debug/Debug.ml | 123 +++++++++++++++++++++++----------------------- debug/Debug.mli | 64 ++++++++++++------------ debug/DebugInformation.ml | 16 +----- debug/DebugInit.ml | 102 +++++++++++++++----------------------- 4 files changed, 134 insertions(+), 171 deletions(-) (limited to 'debug') diff --git a/debug/Debug.ml b/debug/Debug.ml index 22f913c5..25517eee 100644 --- a/debug/Debug.ml +++ b/debug/Debug.ml @@ -22,39 +22,38 @@ open DwarfTypes (* Record used for stroring references to the actual implementation functions *) type implem = { - mutable init: string -> unit; - mutable atom_global: ident -> atom -> unit; - mutable set_composite_size: ident -> struct_or_union -> int option -> unit; - mutable set_member_offset: ident -> string -> int -> unit; - mutable set_bitfield_offset: ident -> string -> int -> string -> int -> unit; - mutable insert_global_declaration: Env.t -> globdecl -> unit; - mutable add_fun_addr: atom -> (int * int) -> unit; - mutable generate_debug_info: (atom -> string) -> string -> debug_entries option; - mutable all_files_iter: (string -> unit) -> unit; - mutable insert_local_declaration: storage -> ident -> typ -> location -> unit; - mutable atom_local_variable: ident -> atom -> unit; - mutable enter_scope: int -> int -> int -> unit; - mutable enter_function_scope: int -> int -> unit; - mutable add_lvar_scope: int -> ident -> int -> unit; - mutable open_scope: atom -> int -> positive -> unit; - mutable close_scope: atom -> int -> positive -> unit; - mutable start_live_range: (atom * atom) -> positive -> int * int builtin_arg -> unit; - mutable end_live_range: (atom * atom) -> positive -> unit; - mutable stack_variable: (atom * atom) -> int * int builtin_arg -> unit; - mutable function_end: atom -> positive -> unit; - mutable add_label: atom -> positive -> int -> unit; - mutable atom_parameter: ident -> ident -> atom -> unit; - mutable add_compilation_section_start: string -> int -> unit; - mutable add_compilation_section_end: string -> int -> unit; - mutable compute_diab_file_enum: (string -> int) -> (string-> int) -> (unit -> unit) -> unit; - mutable compute_gnu_file_enum: (string -> unit) -> unit; - mutable exists_section: string -> bool; - mutable remove_unused: ident -> unit; - mutable variable_printed: string -> unit; - mutable add_diab_info: string -> (int * int * string) -> unit; + init: string -> unit; + atom_global: ident -> atom -> unit; + set_composite_size: ident -> struct_or_union -> int option -> unit; + set_member_offset: ident -> string -> int -> unit; + set_bitfield_offset: ident -> string -> int -> string -> int -> unit; + insert_global_declaration: Env.t -> globdecl -> unit; + add_fun_addr: atom -> (int * int) -> unit; + generate_debug_info: (atom -> string) -> string -> debug_entries option; + all_files_iter: (string -> unit) -> unit; + insert_local_declaration: storage -> ident -> typ -> location -> unit; + atom_local_variable: ident -> atom -> unit; + enter_scope: int -> int -> int -> unit; + enter_function_scope: int -> int -> unit; + add_lvar_scope: int -> ident -> int -> unit; + open_scope: atom -> int -> positive -> unit; + close_scope: atom -> int -> positive -> unit; + start_live_range: (atom * atom) -> positive -> int * int builtin_arg -> unit; + end_live_range: (atom * atom) -> positive -> unit; + stack_variable: (atom * atom) -> int * int builtin_arg -> unit; + add_label: atom -> positive -> int -> unit; + atom_parameter: ident -> ident -> atom -> unit; + add_compilation_section_start: string -> int -> unit; + add_compilation_section_end: string -> int -> unit; + compute_diab_file_enum: (string -> int) -> (string-> int) -> (unit -> unit) -> unit; + compute_gnu_file_enum: (string -> unit) -> unit; + exists_section: string -> bool; + remove_unused: ident -> unit; + variable_printed: string -> unit; + add_diab_info: string -> (int * int * string) -> unit; } -let implem = +let default_implem = { init = (fun _ -> ()); atom_global = (fun _ _ -> ()); @@ -75,7 +74,6 @@ let implem = start_live_range = (fun _ _ _ -> ()); end_live_range = (fun _ _ -> ()); stack_variable = (fun _ _ -> ()); - function_end = (fun _ _ -> ()); add_label = (fun _ _ _ -> ()); atom_parameter = (fun _ _ _ -> ()); add_compilation_section_start = (fun _ _ -> ()); @@ -88,33 +86,34 @@ let implem = add_diab_info = (fun _ _ -> ()); } -let init_compile_unit name = implem.init name -let atom_global id atom = implem.atom_global id atom -let set_composite_size id sou size = implem.set_composite_size id sou size -let set_member_offset id field off = implem.set_member_offset id field off -let set_bitfield_offset id field off underlying size = implem.set_bitfield_offset id field off underlying size -let insert_global_declaration env dec = implem.insert_global_declaration env dec -let add_fun_addr atom addr = implem.add_fun_addr atom addr -let generate_debug_info fun_s var_s = implem.generate_debug_info fun_s var_s -let all_files_iter f = implem.all_files_iter f -let insert_local_declaration sto id ty loc = implem.insert_local_declaration sto id ty loc -let atom_local_variable id atom = implem.atom_local_variable id atom -let enter_scope p_id id = implem.enter_scope p_id id -let enter_function_scope fun_id sc_id = implem.enter_function_scope fun_id sc_id -let add_lvar_scope fun_id var_id s_id = implem.add_lvar_scope fun_id var_id s_id -let open_scope atom id lbl = implem.open_scope atom id lbl -let close_scope atom id lbl = implem.close_scope atom id lbl -let start_live_range atom lbl loc = implem.start_live_range atom lbl loc -let end_live_range atom lbl = implem.end_live_range atom lbl -let stack_variable atom loc = implem.stack_variable atom loc -let function_end atom loc = implem.function_end atom loc -let add_label atom p lbl = implem.add_label atom p lbl -let atom_parameter fid pid atom = implem.atom_parameter fid pid atom -let add_compilation_section_start sec addr = implem.add_compilation_section_start sec addr -let add_compilation_section_end sec addr = implem.add_compilation_section_end sec addr -let exists_section sec = implem.exists_section sec -let compute_diab_file_enum end_l entry_l line_e = implem.compute_diab_file_enum end_l entry_l line_e -let compute_gnu_file_enum f = implem.compute_gnu_file_enum f -let remove_unused ident = implem.remove_unused ident -let variable_printed ident = implem.variable_printed ident -let add_diab_info sec addr = implem.add_diab_info sec addr +let implem = ref default_implem + +let init_compile_unit name = !implem.init name +let atom_global id atom = !implem.atom_global id atom +let set_composite_size id sou size = !implem.set_composite_size id sou size +let set_member_offset id field off = !implem.set_member_offset id field off +let set_bitfield_offset id field off underlying size = !implem.set_bitfield_offset id field off underlying size +let insert_global_declaration env dec = !implem.insert_global_declaration env dec +let add_fun_addr atom addr = !implem.add_fun_addr atom addr +let generate_debug_info fun_s var_s = !implem.generate_debug_info fun_s var_s +let all_files_iter f = !implem.all_files_iter f +let insert_local_declaration sto id ty loc = !implem.insert_local_declaration sto id ty loc +let atom_local_variable id atom = !implem.atom_local_variable id atom +let enter_scope p_id id = !implem.enter_scope p_id id +let enter_function_scope fun_id sc_id = !implem.enter_function_scope fun_id sc_id +let add_lvar_scope fun_id var_id s_id = !implem.add_lvar_scope fun_id var_id s_id +let open_scope atom id lbl = !implem.open_scope atom id lbl +let close_scope atom id lbl = !implem.close_scope atom id lbl +let start_live_range atom lbl loc = !implem.start_live_range atom lbl loc +let end_live_range atom lbl = !implem.end_live_range atom lbl +let stack_variable atom loc = !implem.stack_variable atom loc +let add_label atom p lbl = !implem.add_label atom p lbl +let atom_parameter fid pid atom = !implem.atom_parameter fid pid atom +let add_compilation_section_start sec addr = !implem.add_compilation_section_start sec addr +let add_compilation_section_end sec addr = !implem.add_compilation_section_end sec addr +let exists_section sec = !implem.exists_section sec +let compute_diab_file_enum end_l entry_l line_e = !implem.compute_diab_file_enum end_l entry_l line_e +let compute_gnu_file_enum f = !implem.compute_gnu_file_enum f +let remove_unused ident = !implem.remove_unused ident +let variable_printed ident = !implem.variable_printed ident +let add_diab_info sec addr = !implem.add_diab_info sec addr diff --git a/debug/Debug.mli b/debug/Debug.mli index 94862844..553e1412 100644 --- a/debug/Debug.mli +++ b/debug/Debug.mli @@ -20,39 +20,40 @@ open BinNums (* Record used for stroring references to the actual implementation functions *) type implem = { - mutable init: string -> unit; - mutable atom_global: ident -> atom -> unit; - mutable set_composite_size: ident -> struct_or_union -> int option -> unit; - mutable set_member_offset: ident -> string -> int -> unit; - mutable set_bitfield_offset: ident -> string -> int -> string -> int -> unit; - mutable insert_global_declaration: Env.t -> globdecl -> unit; - mutable add_fun_addr: atom -> (int * int) -> unit; - mutable generate_debug_info: (atom -> string) -> string -> debug_entries option; - mutable all_files_iter: (string -> unit) -> unit; - mutable insert_local_declaration: storage -> ident -> typ -> location -> unit; - mutable atom_local_variable: ident -> atom -> unit; - mutable enter_scope: int -> int -> int -> unit; - mutable enter_function_scope: int -> int -> unit; - mutable add_lvar_scope: int -> ident -> int -> unit; - mutable open_scope: atom -> int -> positive -> unit; - mutable close_scope: atom -> int -> positive -> unit; - mutable start_live_range: (atom * atom) -> positive -> int * int builtin_arg -> unit; - mutable end_live_range: (atom * atom) -> positive -> unit; - mutable stack_variable: (atom * atom) -> int * int builtin_arg -> unit; - mutable function_end: atom -> positive -> unit; - mutable add_label: atom -> positive -> int -> unit; - mutable atom_parameter: ident -> ident -> atom -> unit; - mutable add_compilation_section_start: string -> int -> unit; - mutable add_compilation_section_end: string -> int -> unit; - mutable compute_diab_file_enum: (string -> int) -> (string-> int) -> (unit -> unit) -> unit; - mutable compute_gnu_file_enum: (string -> unit) -> unit; - mutable exists_section: string -> bool; - mutable remove_unused: ident -> unit; - mutable variable_printed: string -> unit; - mutable add_diab_info: string -> (int * int * string) -> unit; + init: string -> unit; + atom_global: ident -> atom -> unit; + set_composite_size: ident -> struct_or_union -> int option -> unit; + set_member_offset: ident -> string -> int -> unit; + set_bitfield_offset: ident -> string -> int -> string -> int -> unit; + insert_global_declaration: Env.t -> globdecl -> unit; + add_fun_addr: atom -> (int * int) -> unit; + generate_debug_info: (atom -> string) -> string -> debug_entries option; + all_files_iter: (string -> unit) -> unit; + insert_local_declaration: storage -> ident -> typ -> location -> unit; + atom_local_variable: ident -> atom -> unit; + enter_scope: int -> int -> int -> unit; + enter_function_scope: int -> int -> unit; + add_lvar_scope: int -> ident -> int -> unit; + open_scope: atom -> int -> positive -> unit; + close_scope: atom -> int -> positive -> unit; + start_live_range: (atom * atom) -> positive -> int * int builtin_arg -> unit; + end_live_range: (atom * atom) -> positive -> unit; + stack_variable: (atom * atom) -> int * int builtin_arg -> unit; + add_label: atom -> positive -> int -> unit; + atom_parameter: ident -> ident -> atom -> unit; + add_compilation_section_start: string -> int -> unit; + add_compilation_section_end: string -> int -> unit; + compute_diab_file_enum: (string -> int) -> (string-> int) -> (unit -> unit) -> unit; + compute_gnu_file_enum: (string -> unit) -> unit; + exists_section: string -> bool; + remove_unused: ident -> unit; + variable_printed: string -> unit; + add_diab_info: string -> (int * int * string) -> unit; } -val implem: implem +val default_implem: implem + +val implem: implem ref val init_compile_unit: string -> unit val atom_global: ident -> atom -> unit @@ -72,7 +73,6 @@ val close_scope: atom -> int -> positive -> unit val start_live_range: (atom * atom) -> positive -> (int * int builtin_arg) -> unit val end_live_range: (atom * atom) -> positive -> unit val stack_variable: (atom * atom) -> int * int builtin_arg -> unit -val function_end: atom -> positive -> unit val add_label: atom -> positive -> int -> unit val generate_debug_info: (atom -> string) -> string -> debug_entries option val atom_parameter: ident -> ident -> atom -> unit diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index 96355d66..0f9c8ff3 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -60,7 +60,7 @@ let typ_to_string (ty: typ) = Buffer.contents buf (* Helper functions for the attributes *) -let strip_attributes typ = strip_attributes_type typ [AConst;AVolatile] +let strip_attributes typ = strip_attributes_type typ [AConst; AVolatile] (* Does the type already exist? *) let exist_type (ty: typ) = @@ -536,20 +536,11 @@ let label_translation: (atom * positive, int) Hashtbl.t = Hashtbl.create 7 let add_label atom p i = Hashtbl.add label_translation (atom,p) i -(* Auxiliary data structures and functions *) -module IntSet = Set.Make(struct - type t = int - let compare (x:int) (y:int) = compare x y -end) - -let open_scopes: IntSet.t ref = ref IntSet.empty - let open_scope atom s_id lbl = try let s_id = Hashtbl.find atom_to_scope (atom,s_id) in let old_r = try Hashtbl.find scope_ranges s_id with Not_found -> [] in let n_scop = { start_addr = Some lbl; end_addr = None;} in - open_scopes := IntSet.add s_id !open_scopes; Hashtbl.replace scope_ranges s_id (n_scop::old_r) with Not_found -> () @@ -564,7 +555,6 @@ let close_scope atom s_id lbl = | _ -> assert false (* We must have an opening scope *) end in let new_r = ({last_r with end_addr = Some lbl;})::rest in - open_scopes := IntSet.remove s_id !open_scopes; Hashtbl.replace scope_ranges s_id new_r with Not_found -> () @@ -590,10 +580,6 @@ let end_live_range (f,v) lbl = let stack_variable (f,v) (sp,loc) = Hashtbl.add var_locations (f,v) (FunctionLoc (sp,loc)) -let function_end atom loc = - IntSet.iter (fun id -> close_scope atom id loc) !open_scopes; - open_scopes := IntSet.empty - let compilation_section_start: (string,int) Hashtbl.t = Hashtbl.create 7 let compilation_section_end: (string,int) Hashtbl.t = Hashtbl.create 7 diff --git a/debug/DebugInit.ml b/debug/DebugInit.ml index 09714628..209f2024 100644 --- a/debug/DebugInit.ml +++ b/debug/DebugInit.ml @@ -18,71 +18,49 @@ open Dwarfgen open DwarfTypes open Debug +let default_debug = + { + init = DebugInformation.init; + atom_global = DebugInformation.atom_global; + set_composite_size = DebugInformation.set_composite_size; + set_member_offset = DebugInformation.set_member_offset; + set_bitfield_offset = DebugInformation.set_bitfield_offset; + insert_global_declaration = DebugInformation.insert_global_declaration; + add_fun_addr = DebugInformation.add_fun_addr; + generate_debug_info = (fun _ _ -> None); + all_files_iter = (fun f -> DebugInformation.StringSet.iter f !DebugInformation.all_files); + insert_local_declaration = DebugInformation.insert_local_declaration; + atom_local_variable = DebugInformation.atom_local_variable; + enter_scope = DebugInformation.enter_scope; + enter_function_scope = DebugInformation.enter_function_scope; + add_lvar_scope = DebugInformation.add_lvar_scope; + open_scope = DebugInformation.open_scope; + close_scope = DebugInformation.close_scope; + start_live_range = DebugInformation.start_live_range; + end_live_range = DebugInformation.end_live_range; + stack_variable = DebugInformation.stack_variable; + add_label = DebugInformation.add_label; + atom_parameter = DebugInformation.atom_parameter; + add_compilation_section_start = DebugInformation.add_compilation_section_start; + add_compilation_section_end = DebugInformation.add_compilation_section_end; + compute_diab_file_enum = DebugInformation.compute_diab_file_enum; + compute_gnu_file_enum = DebugInformation.compute_gnu_file_enum; + exists_section = DebugInformation.exists_section; + remove_unused = DebugInformation.remove_unused; + variable_printed = DebugInformation.variable_printed; + add_diab_info = DebugInformation.add_diab_info; + } + let init_debug () = - implem.init <- DebugInformation.init; - implem.atom_global <- DebugInformation.atom_global; - implem.set_composite_size <- DebugInformation.set_composite_size; - implem.set_member_offset <- DebugInformation.set_member_offset; - implem.set_bitfield_offset <- DebugInformation.set_bitfield_offset; - implem.insert_global_declaration <- DebugInformation.insert_global_declaration; - implem.add_fun_addr <- DebugInformation.add_fun_addr; - implem.generate_debug_info <- - if Configuration.system = "diab" then - (fun a b -> Some (Dwarfgen.gen_diab_debug_info a b)) - else - (fun a b -> Some (Dwarfgen.gen_gnu_debug_info a b)); - implem.all_files_iter <- (fun f -> DebugInformation.StringSet.iter f !DebugInformation.all_files); - implem.insert_local_declaration <- DebugInformation.insert_local_declaration; - implem.atom_local_variable <- DebugInformation.atom_local_variable; - implem.enter_scope <- DebugInformation.enter_scope; - implem.enter_function_scope <- DebugInformation.enter_function_scope; - implem.add_lvar_scope <- DebugInformation.add_lvar_scope; - implem.open_scope <- DebugInformation.open_scope; - implem.close_scope <- DebugInformation.close_scope; - implem.start_live_range <- DebugInformation.start_live_range; - implem.end_live_range <- DebugInformation.end_live_range; - implem.stack_variable <- DebugInformation.stack_variable; - implem.add_label <- DebugInformation.add_label; - implem.atom_parameter <- DebugInformation.atom_parameter; - implem.add_compilation_section_start <- DebugInformation.add_compilation_section_start; - implem.add_compilation_section_end <- DebugInformation.add_compilation_section_end; - implem.compute_diab_file_enum <- DebugInformation.compute_diab_file_enum; - implem.compute_gnu_file_enum <- DebugInformation.compute_gnu_file_enum; - implem.exists_section <- DebugInformation.exists_section; - implem.remove_unused <- DebugInformation.remove_unused; - implem.variable_printed <- DebugInformation.variable_printed; - implem.add_diab_info <- DebugInformation.add_diab_info + let gen = + if Configuration.system = "diab" then + (fun a b -> Some (Dwarfgen.gen_diab_debug_info a b)) + else + (fun a b -> Some (Dwarfgen.gen_gnu_debug_info a b)) in + implem := {default_debug with generate_debug_info = gen;} let init_none () = - implem.init <- (fun _ -> ()); - implem.atom_global <- (fun _ _ -> ()); - implem.set_composite_size <- (fun _ _ _ -> ()); - implem.set_member_offset <- (fun _ _ _ -> ()); - implem.set_bitfield_offset <- (fun _ _ _ _ _ -> ()); - implem.insert_global_declaration <- (fun _ _ -> ()); - implem.add_fun_addr <- (fun _ _ -> ()); - implem.generate_debug_info <- (fun _ _ -> None); - implem.all_files_iter <- (fun _ -> ()); - implem.insert_local_declaration <- (fun _ _ _ _ -> ()); - implem.atom_local_variable <- (fun _ _ -> ()); - implem.enter_scope <- (fun _ _ _ -> ()); - implem.enter_function_scope <- (fun _ _ -> ()); - implem.add_lvar_scope <- (fun _ _ _ -> ()); - implem.open_scope <- (fun _ _ _ -> ()); - implem.close_scope <- (fun _ _ _ -> ()); - implem.start_live_range <- (fun _ _ _ -> ()); - implem.end_live_range <- (fun _ _ -> ()); - implem.stack_variable <- (fun _ _ -> ()); - implem.add_label <- (fun _ _ _ -> ()); - implem.atom_parameter <- (fun _ _ _ -> ()); - implem.add_compilation_section_start <- (fun _ _ -> ()); - implem.add_compilation_section_end <- (fun _ _ -> ()); - implem.compute_diab_file_enum <- (fun _ _ _ -> ()); - implem.compute_gnu_file_enum <- (fun _ -> ()); - implem.exists_section <- (fun _ -> true); - implem.remove_unused <- (fun _ -> ()); - implem.variable_printed <- (fun _ -> ()); - implem.add_diab_info <- (fun _ _ -> ()) + implem := default_implem let init () = if !Clflags.option_g && Configuration.advanced_debug then -- cgit From 09ca4e17ad5cd9bd4d7a6eada42f450a92987226 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Tue, 13 Oct 2015 10:29:01 +0200 Subject: Removed unused function. The function exists_type is not really used so we can remove it. Bug 17392. --- debug/DebugInformation.ml | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) (limited to 'debug') diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index 0f9c8ff3..96f55f40 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -62,12 +62,6 @@ let typ_to_string (ty: typ) = (* Helper functions for the attributes *) let strip_attributes typ = strip_attributes_type typ [AConst; AVolatile] -(* Does the type already exist? *) -let exist_type (ty: typ) = - (* We are only interrested in Const and Volatile *) - let ty = strip_attributes ty in - Hashtbl.mem lookup_types (typ_to_string ty) - (* Find the type id to an type *) let find_type (ty: typ) = (* We are only interrested in Const and Volatile *) @@ -227,6 +221,7 @@ let name_to_definition: (string,int) Hashtbl.t = Hashtbl.create 7 (* Mapping from atom to debug id *) let atom_to_definition: (atom, int) Hashtbl.t = Hashtbl.create 7 +(* Various lookup functions for defintions *) let find_gvar_stamp id = let id = (Hashtbl.find stamp_to_definition id) in let var = Hashtbl.find definitions id in @@ -636,4 +631,4 @@ let init name = Hashtbl.reset scope_ranges; Hashtbl.reset label_translation; all_files := StringSet.singleton name; - printed_vars := StringSet.empty; + printed_vars := StringSet.empty -- cgit From daed22eb5afdc86267c8f90b55008267c9383fca Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Tue, 13 Oct 2015 10:49:36 +0200 Subject: Remove unused members from debug types. The dwarf 2 standard allows more attributes for certain debuggint entries than used by gcc or diab data. Since they are also not set by compcert they can be removed. Bug 17392. --- debug/DwarfPrinter.ml | 10 ---------- debug/DwarfTypes.mli | 5 ----- debug/Dwarfgen.ml | 6 ------ 3 files changed, 21 deletions(-) (limited to 'debug') diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index e2f062d8..e6d9cd5e 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -95,7 +95,6 @@ module DwarfPrinter(Target: DWARF_TARGET): (match entity.tag with | DW_TAG_array_type e -> prologue 0x1; - add_attr_some e.array_type_file_loc add_file_loc; add_type buf | DW_TAG_base_type b -> prologue 0x24; @@ -122,12 +121,10 @@ module DwarfPrinter(Target: DWARF_TARGET): add_attr_some e.enumeration_name add_name | DW_TAG_enumerator e -> prologue 0x28; - add_attr_some e.enumerator_file_loc add_file_loc; add_abbr_entry (0x1c,value_type_abbr) buf; add_name buf | DW_TAG_formal_parameter e -> prologue 0x5; - add_attr_some e.formal_parameter_file_loc add_file_loc; add_attr_some e.formal_parameter_artificial (add_abbr_entry (0x34,artificial_type_abbr)); add_attr_some e.formal_parameter_name add_name; add_type buf; @@ -143,7 +140,6 @@ module DwarfPrinter(Target: DWARF_TARGET): add_attr_some a.lexical_block_low_pc add_low_pc | DW_TAG_member e -> prologue 0xd; - add_attr_some e.member_file_loc add_file_loc; add_attr_some e.member_byte_size add_byte_size; add_attr_some e.member_bit_offset (add_abbr_entry (0xc,bit_offset_type_abbr)); add_attr_some e.member_bit_size (add_abbr_entry (0xd,bit_size_type_abbr)); @@ -196,7 +192,6 @@ module DwarfPrinter(Target: DWARF_TARGET): add_attr_some e.union_name add_name | DW_TAG_unspecified_parameter e -> prologue 0x18; - add_attr_some e.unspecified_parameter_file_loc add_file_loc; add_attr_some e.unspecified_parameter_artificial (add_abbr_entry (0x34,artificial_type_abbr)) | DW_TAG_variable e -> prologue 0x34; @@ -381,7 +376,6 @@ module DwarfPrinter(Target: DWARF_TARGET): fprintf oc " .4byte %a\n" label a let print_array_type oc at = - print_file_loc oc at.array_type_file_loc; print_ref oc at.array_type let print_bound_value oc = function @@ -432,12 +426,10 @@ module DwarfPrinter(Target: DWARF_TARGET): print_opt_value oc et.enumeration_name print_string let print_enumerator oc en = - print_file_loc oc en.enumerator_file_loc; print_sleb128 oc en.enumerator_value; print_string oc en.enumerator_name let print_formal_parameter oc fp = - print_file_loc oc fp.formal_parameter_file_loc; print_opt_value oc fp.formal_parameter_artificial print_flag; print_opt_value oc fp.formal_parameter_name print_string; print_ref oc fp.formal_parameter_type; @@ -454,7 +446,6 @@ module DwarfPrinter(Target: DWARF_TARGET): print_opt_value oc lb.lexical_block_low_pc print_addr let print_member oc mb = - print_file_loc oc mb.member_file_loc; print_opt_value oc mb.member_byte_size print_byte; print_opt_value oc mb.member_bit_offset print_byte; print_opt_value oc mb.member_bit_size print_byte; @@ -506,7 +497,6 @@ module DwarfPrinter(Target: DWARF_TARGET): print_opt_value oc ut.union_name print_string let print_unspecified_parameter oc up = - print_file_loc oc up.unspecified_parameter_file_loc; print_opt_value oc up.unspecified_parameter_artificial print_flag let print_variable oc var = diff --git a/debug/DwarfTypes.mli b/debug/DwarfTypes.mli index 233ada2e..669ceabc 100644 --- a/debug/DwarfTypes.mli +++ b/debug/DwarfTypes.mli @@ -66,7 +66,6 @@ type file_loc = type dw_tag_array_type = { - array_type_file_loc: file_loc option; array_type: reference; } @@ -99,14 +98,12 @@ type dw_tag_enumeration_type = type dw_tag_enumerator = { - enumerator_file_loc: file_loc option; enumerator_value: constant; enumerator_name: string; } type dw_tag_formal_parameter = { - formal_parameter_file_loc: file_loc option; formal_parameter_artificial: flag option; formal_parameter_name: string option; formal_parameter_type: reference; @@ -128,7 +125,6 @@ type dw_tag_lexical_block = type dw_tag_member = { - member_file_loc: file_loc option; member_byte_size: constant option; member_bit_offset: constant option; member_bit_size: constant option; @@ -191,7 +187,6 @@ type dw_tag_union_type = type dw_tag_unspecified_parameter = { - unspecified_parameter_file_loc: file_loc option; unspecified_parameter_artificial: flag option; } diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml index 8048ea43..a3414831 100644 --- a/debug/Dwarfgen.ml +++ b/debug/Dwarfgen.ml @@ -107,7 +107,6 @@ let pointer_to_entry id p = let array_to_entry id arr = let arr_tag = { - array_type_file_loc = None; array_type = arr.arr_type; } in let arr_entry = new_entry id (DW_TAG_array_type arr_tag) in @@ -134,7 +133,6 @@ let enum_to_entry file id e = let enumerator_to_entry e = let tag = { - enumerator_file_loc = None; enumerator_value = Int64.to_int (e.enumerator_const); enumerator_name = e.enumerator_name; } in @@ -153,14 +151,12 @@ let enum_to_entry file id e = let fun_type_to_entry id f = let children = if f.fun_prototyped then let u = { - unspecified_parameter_file_loc = None; unspecified_parameter_artificial = None; } in [new_entry (next_id ()) (DW_TAG_unspecified_parameter u)] else List.map (fun p -> let fp = { - formal_parameter_file_loc = None; formal_parameter_artificial = None; formal_parameter_name = if p.param_name <> "" then Some p.param_name else None; formal_parameter_type = p.param_type; @@ -178,7 +174,6 @@ let fun_type_to_entry id f = let member_to_entry mem = let mem = { - member_file_loc = None; member_byte_size = mem.cfd_byte_size; member_bit_offset = mem.cfd_bit_offset; member_bit_size = mem.cfd_bit_size; @@ -353,7 +348,6 @@ let location_entry f_id atom = let function_parameter_to_entry f_id (acc,bcc) p = let loc,loc_list = location_entry f_id (get_opt_val p.parameter_atom) in let p = { - formal_parameter_file_loc = None; formal_parameter_artificial = None; formal_parameter_name = Some p.parameter_name; formal_parameter_type = p.parameter_type; -- cgit From 16315711d815580afa77f93424cc49c7362ab5b8 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Tue, 13 Oct 2015 14:57:31 +0200 Subject: Implement the usage of the debug_str section for the gcc backend. GCC prints all string larger than 3 characters in the debug_str section which reduces the size of the debug information since entries containing the same string now map to the same string in the debug_str sections. Bug 17392. --- debug/DwarfPrinter.ml | 76 +++-- debug/DwarfTypes.mli | 82 ++--- debug/Dwarfgen.ml | 849 ++++++++++++++++++++++++++------------------------ 3 files changed, 537 insertions(+), 470 deletions(-) (limited to 'debug') diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index e6d9cd5e..407850a5 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -57,8 +57,6 @@ module DwarfPrinter(Target: DWARF_TARGET): let add_type = add_abbr_entry (0x49,type_abbr) - let add_name = add_abbr_entry (0x3,name_type_abbr) - let add_byte_size = add_abbr_entry (0xb,byte_size_type_abbr) let add_member_size = add_abbr_entry (0xb,member_size_abbr) @@ -69,6 +67,16 @@ module DwarfPrinter(Target: DWARF_TARGET): let add_declaration = add_abbr_entry (0x3c,declaration_type_abbr) + let add_string buf id = function + | Simple_string _ -> add_abbr_entry (id,dw_form_string) buf + | Offset_string _ -> add_abbr_entry (id,dw_form_strp) buf + + let add_name buf = add_string buf 0x3 + + let add_name_opt buf = function + | None -> () + | Some s -> add_name buf s + let add_location loc buf = match loc with | None -> () @@ -77,6 +85,8 @@ module DwarfPrinter(Target: DWARF_TARGET): | Some (LocSymbol _) | Some (LocSimple _) -> add_abbr_entry (0x2,location_block_type_abbr) buf + + (* Dwarf entity to string function *) let abbrev_string_of_entity entity has_sibling = let buf = Buffer.create 12 in @@ -100,15 +110,15 @@ module DwarfPrinter(Target: DWARF_TARGET): prologue 0x24; add_byte_size buf; add_attr_some b.base_type_encoding (add_abbr_entry (0x3e,encoding_type_abbr)); - add_name buf + add_name buf b.base_type_name; | DW_TAG_compile_unit e -> prologue 0x11; - add_abbr_entry (0x1b,comp_dir_type_abbr) buf; + add_string buf 0x1b e.compile_unit_dir; add_low_pc buf; add_high_pc buf; add_abbr_entry (0x13,language_type_abbr) buf; - add_name buf; - add_abbr_entry (0x25,producer_type_abbr) buf; + add_name buf e.compile_unit_name; + add_string buf 0x25 e.compile_unit_prod_name; add_abbr_entry (0x10,stmt_list_type_abbr) buf; | DW_TAG_const_type _ -> prologue 0x26; @@ -118,22 +128,22 @@ module DwarfPrinter(Target: DWARF_TARGET): add_attr_some e.enumeration_file_loc add_file_loc; add_byte_size buf; add_attr_some e.enumeration_declaration add_declaration; - add_attr_some e.enumeration_name add_name + add_name buf e.enumeration_name | DW_TAG_enumerator e -> prologue 0x28; add_abbr_entry (0x1c,value_type_abbr) buf; - add_name buf + add_name buf e.enumerator_name | DW_TAG_formal_parameter e -> prologue 0x5; add_attr_some e.formal_parameter_artificial (add_abbr_entry (0x34,artificial_type_abbr)); - add_attr_some e.formal_parameter_name add_name; + add_name_opt buf e.formal_parameter_name; add_type buf; add_attr_some e.formal_parameter_variable_parameter (add_abbr_entry (0x4b,variable_parameter_type_abbr)); add_location e.formal_parameter_location buf - | DW_TAG_label _ -> + | DW_TAG_label e -> prologue 0xa; add_low_pc buf; - add_name buf; + add_name buf e.label_name; | DW_TAG_lexical_block a -> prologue 0xb; add_attr_some a.lexical_block_high_pc add_high_pc; @@ -144,7 +154,7 @@ module DwarfPrinter(Target: DWARF_TARGET): add_attr_some e.member_bit_offset (add_abbr_entry (0xc,bit_offset_type_abbr)); add_attr_some e.member_bit_size (add_abbr_entry (0xd,bit_size_type_abbr)); add_attr_some e.member_declaration add_declaration; - add_attr_some e.member_name add_name; + add_name buf e.member_name; add_type buf; (match e.member_data_member_location with | None -> () @@ -158,14 +168,14 @@ module DwarfPrinter(Target: DWARF_TARGET): add_attr_some e.structure_file_loc add_file_loc; add_attr_some e.structure_byte_size add_member_size; add_attr_some e.structure_declaration add_declaration; - add_attr_some e.structure_name add_name + add_name_opt buf e.structure_name | DW_TAG_subprogram e -> prologue 0x2e; add_file_loc buf; add_attr_some e.subprogram_external (add_abbr_entry (0x3f,external_type_abbr)); add_attr_some e.subprogram_high_pc add_high_pc; add_attr_some e.subprogram_low_pc add_low_pc; - add_name buf; + add_name buf e.subprogram_name; add_abbr_entry (0x27,prototyped_type_abbr) buf; add_attr_some e.subprogram_type add_type; | DW_TAG_subrange_type e -> @@ -182,14 +192,14 @@ module DwarfPrinter(Target: DWARF_TARGET): | DW_TAG_typedef e -> prologue 0x16; add_attr_some e.typedef_file_loc add_file_loc; - add_name buf; + add_name buf e.typedef_name; add_type buf | DW_TAG_union_type e -> prologue 0x17; add_attr_some e.union_file_loc add_file_loc; add_attr_some e.union_byte_size add_member_size; add_attr_some e.union_declaration add_declaration; - add_attr_some e.union_name add_name + add_name_opt buf e.union_name | DW_TAG_unspecified_parameter e -> prologue 0x18; add_attr_some e.unspecified_parameter_artificial (add_abbr_entry (0x34,artificial_type_abbr)) @@ -199,7 +209,7 @@ module DwarfPrinter(Target: DWARF_TARGET): add_attr_some e.variable_declaration add_declaration; add_attr_some e.variable_external (add_abbr_entry (0x3f,external_type_abbr)); add_location e.variable_location buf; - add_name buf; + add_name buf e.variable_name; add_type buf | DW_TAG_volatile_type _ -> prologue 0x35; @@ -289,8 +299,10 @@ module DwarfPrinter(Target: DWARF_TARGET): let print_flag oc b = output_string oc (string_of_byte b) - let print_string oc s = - fprintf oc " .asciz \"%s\"\n" s + let print_string oc = function + | Simple_string s -> + fprintf oc " .asciz \"%s\"\n" s + | Offset_string o -> print_loc_ref oc o let print_uleb128 oc d = fprintf oc " .uleb128 %d\n" d @@ -401,19 +413,12 @@ module DwarfPrinter(Target: DWARF_TARGET): print_string oc bt.base_type_name let print_compilation_unit oc tag = - let version_string = - if Version.buildnr <> "" && Version.tag <> "" then - sprintf "%s, Build: %s, Tag: %s" Version.version Version.buildnr Version.tag - else - Version.version in - let prod_name = sprintf "AbsInt Angewandte Informatik GmbH:CompCert Version %s:(%s,%s,%s,%s)" - version_string Configuration.arch Configuration.system Configuration.abi Configuration.model in - print_string oc (Sys.getcwd ()); + print_string oc tag.compile_unit_dir; print_addr oc tag.compile_unit_low_pc; print_addr oc tag.compile_unit_high_pc; print_uleb128 oc 1; print_string oc tag.compile_unit_name; - print_string oc prod_name; + print_string oc tag.compile_unit_prod_name; print_addr oc !debug_stmt_list let print_const_type oc ct = @@ -423,7 +428,7 @@ module DwarfPrinter(Target: DWARF_TARGET): print_file_loc oc et.enumeration_file_loc; print_uleb128 oc et.enumeration_byte_size; print_opt_value oc et.enumeration_declaration print_flag; - print_opt_value oc et.enumeration_name print_string + print_string oc et.enumeration_name let print_enumerator oc en = print_sleb128 oc en.enumerator_value; @@ -450,7 +455,7 @@ module DwarfPrinter(Target: DWARF_TARGET): print_opt_value oc mb.member_bit_offset print_byte; print_opt_value oc mb.member_bit_size print_byte; print_opt_value oc mb.member_declaration print_flag; - print_opt_value oc mb.member_name print_string; + print_string oc mb.member_name; print_ref oc mb.member_type; print_opt_value oc mb.member_data_member_location print_data_location @@ -602,7 +607,7 @@ module DwarfPrinter(Target: DWARF_TARGET): section oc Section_debug_loc; List.iter (fun e -> print_location_list oc e.locs) entries - let print_gnu_entries oc cp loc = + let print_gnu_entries oc cp loc s = compute_abbrev cp; let line_start = new_label () and start = new_label () @@ -614,11 +619,16 @@ module DwarfPrinter(Target: DWARF_TARGET): section oc Section_debug_loc; print_location_list oc loc; section oc (Section_debug_line ""); - print_label oc line_start + print_label oc line_start; + section oc Section_debug_str; + List.iter (fun (id,s) -> + print_label oc (loc_to_label id); + fprintf oc " .asciz \"%s\"\n" s) s + (* Print the debug info and abbrev section *) let print_debug oc = function | Diab entries -> print_diab_entries oc entries - | Gnu (cp,loc) -> print_gnu_entries oc cp loc + | Gnu (cp,loc,s) -> print_gnu_entries oc cp loc s end diff --git a/debug/DwarfTypes.mli b/debug/DwarfTypes.mli index 669ceabc..c7e5dce1 100644 --- a/debug/DwarfTypes.mli +++ b/debug/DwarfTypes.mli @@ -36,13 +36,11 @@ type encoding = type address = int -type block = string - type location_expression = | DW_OP_plus_uconst of constant - | DW_OP_bregx of int * int32 - | DW_OP_piece of int - | DW_OP_reg of int + | DW_OP_bregx of constant * int32 + | DW_OP_piece of constant + | DW_OP_reg of constant type location_value = | LocSymbol of atom @@ -58,11 +56,15 @@ type bound_value = | BoundConst of constant | BoundRef of reference +type string_const = + | Simple_string of string + | Offset_string of reference + (* Types representing the attribute information per tag value *) type file_loc = - | Diab_file_loc of int * constant - | Gnu_file_loc of int * constant + | Diab_file_loc of constant * constant + | Gnu_file_loc of constant * constant type dw_tag_array_type = { @@ -72,15 +74,17 @@ type dw_tag_array_type = type dw_tag_base_type = { base_type_byte_size: constant; - base_type_encoding: encoding option; - base_type_name: string; + base_type_encoding: encoding option; + base_type_name: string_const; } type dw_tag_compile_unit = { - compile_unit_name: string; - compile_unit_low_pc: int; - compile_unit_high_pc: int; + compile_unit_name: string_const; + compile_unit_low_pc: constant; + compile_unit_high_pc: constant; + compile_unit_dir: string_const; + compile_unit_prod_name: string_const; } type dw_tag_const_type = @@ -90,22 +94,22 @@ type dw_tag_const_type = type dw_tag_enumeration_type = { - enumeration_file_loc: file_loc option; + enumeration_file_loc: file_loc option; enumeration_byte_size: constant; - enumeration_declaration: flag option; - enumeration_name: string option; + enumeration_declaration: flag option; + enumeration_name: string_const; } type dw_tag_enumerator = { enumerator_value: constant; - enumerator_name: string; + enumerator_name: string_const; } type dw_tag_formal_parameter = { formal_parameter_artificial: flag option; - formal_parameter_name: string option; + formal_parameter_name: string_const option; formal_parameter_type: reference; formal_parameter_variable_parameter: flag option; formal_parameter_location: location_value option; @@ -114,7 +118,7 @@ type dw_tag_formal_parameter = type dw_tag_label = { label_low_pc: address; - label_name: string; + label_name: string_const; } type dw_tag_lexical_block = @@ -130,7 +134,7 @@ type dw_tag_member = member_bit_size: constant option; member_data_member_location: data_location_value option; member_declaration: flag option; - member_name: string option; + member_name: string_const; member_type: reference; } @@ -141,21 +145,21 @@ type dw_tag_pointer_type = type dw_tag_structure_type = { - structure_file_loc: file_loc option; - structure_byte_size: constant option; - structure_declaration: flag option; - structure_name: string option; + structure_file_loc: file_loc option; + structure_byte_size: constant option; + structure_declaration: flag option; + structure_name: string_const option; } type dw_tag_subprogram = { subprogram_file_loc: file_loc; - subprogram_external: flag option; - subprogram_name: string; + subprogram_external: flag option; + subprogram_name: string_const; subprogram_prototyped: flag; - subprogram_type: reference option; - subprogram_high_pc: reference option; - subprogram_low_pc: reference option; + subprogram_type: reference option; + subprogram_high_pc: reference option; + subprogram_low_pc: reference option; } type dw_tag_subrange_type = @@ -173,21 +177,21 @@ type dw_tag_subroutine_type = type dw_tag_typedef = { typedef_file_loc: file_loc option; - typedef_name: string; + typedef_name: string_const; typedef_type: reference; } type dw_tag_union_type = { - union_file_loc: file_loc option; - union_byte_size: constant option; - union_declaration: flag option; - union_name: string option; + union_file_loc: file_loc option; + union_byte_size: constant option; + union_declaration: flag option; + union_name: string_const option; } type dw_tag_unspecified_parameter = { - unspecified_parameter_artificial: flag option; + unspecified_parameter_artificial: flag option; } type dw_tag_variable = @@ -195,7 +199,7 @@ type dw_tag_variable = variable_file_loc: file_loc; variable_declaration: flag option; variable_external: flag option; - variable_name: string; + variable_name: string_const; variable_type: reference; variable_location: location_value option; } @@ -239,10 +243,10 @@ type dw_entry = (* The type for the location list. *) type location_entry = { - loc: (int * int * location_value) list; + loc: (address * address * location_value) list; loc_id: reference; } -type dw_locations = int option * location_entry list +type dw_locations = constant option * location_entry list type diab_entry = { @@ -255,7 +259,9 @@ type diab_entry = type diab_entries = diab_entry list -type gnu_entries = dw_entry * dw_locations +type dw_string = (int * string) list + +type gnu_entries = dw_entry * dw_locations * dw_string type debug_entries = | Diab of diab_entries diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml index a3414831..78c4fffb 100644 --- a/debug/Dwarfgen.ml +++ b/debug/Dwarfgen.ml @@ -50,392 +50,444 @@ let rec mmap_opt f env = function | None -> tl',env2 end -(* Functions to translate the basetypes. *) -let int_type_to_entry id i = - let encoding = - (match i.int_kind with - | IBool -> DW_ATE_boolean - | IChar -> - if !Machine.config.Machine.char_signed then - DW_ATE_signed_char - else - DW_ATE_unsigned_char - | IInt | ILong | ILongLong | IShort | ISChar -> DW_ATE_signed - | _ -> DW_ATE_unsigned)in - let int = { - base_type_byte_size = sizeof_ikind i.int_kind; - base_type_encoding = Some encoding; - base_type_name = typ_to_string (TInt (i.int_kind,[]));} in - new_entry id (DW_TAG_base_type int) - -let float_type_to_entry id f = - let byte_size = sizeof_fkind f.float_kind in - let float = { - base_type_byte_size = byte_size; - base_type_encoding = Some DW_ATE_float; - base_type_name = typ_to_string (TFloat (f.float_kind,[])); - } in - new_entry id (DW_TAG_base_type float) +module type TARGET = + sig + val file_loc: string * int -> file_loc + val string_entry: string -> string_const + end -let void_to_entry id = - let void = { - base_type_byte_size = 0; - base_type_encoding = None; - base_type_name = "void"; - } in - new_entry id (DW_TAG_base_type void) - -let file_loc_opt file = function - | None -> None - | Some (f,l) -> - try - Some (file (f,l)) - with Not_found -> None - -let typedef_to_entry file id t = - let i = get_opt_val t.typ in - let td = { - typedef_file_loc = file_loc_opt file t.typedef_file_loc; - typedef_name = t.typedef_name; - typedef_type = i; - } in - new_entry id (DW_TAG_typedef td) +module Dwarfgenaux (Target: TARGET) = + struct + + include Target + + let name_opt n = if n <> "" then Some (string_entry n) else None + + (* Functions to translate the basetypes. *) + let int_type_to_entry id i = + let encoding = + (match i.int_kind with + | IBool -> DW_ATE_boolean + | IChar -> + if !Machine.config.Machine.char_signed then + DW_ATE_signed_char + else + DW_ATE_unsigned_char + | IInt | ILong | ILongLong | IShort | ISChar -> DW_ATE_signed + | _ -> DW_ATE_unsigned)in + let int = { + base_type_byte_size = sizeof_ikind i.int_kind; + base_type_encoding = Some encoding; + base_type_name = string_entry (typ_to_string (TInt (i.int_kind,[]))); + } in + new_entry id (DW_TAG_base_type int) + + let float_type_to_entry id f = + let byte_size = sizeof_fkind f.float_kind in + let float = { + base_type_byte_size = byte_size; + base_type_encoding = Some DW_ATE_float; + base_type_name = string_entry (typ_to_string (TFloat (f.float_kind,[]))); + } in + new_entry id (DW_TAG_base_type float) -let pointer_to_entry id p = - let p = {pointer_type = p.pts} in - new_entry id (DW_TAG_pointer_type p) + let void_to_entry id = + let void = { + base_type_byte_size = 0; + base_type_encoding = None; + base_type_name = string_entry "void"; + } in + new_entry id (DW_TAG_base_type void) + + let file_loc_opt = function + | None -> None + | Some (f,l) -> + try + Some (file_loc (f,l)) + with Not_found -> None + + let typedef_to_entry id t = + let i = get_opt_val t.typ in + let td = { + typedef_file_loc = file_loc_opt t.typedef_file_loc; + typedef_name = string_entry t.typedef_name; + typedef_type = i; + } in + new_entry id (DW_TAG_typedef td) -let array_to_entry id arr = - let arr_tag = { - array_type = arr.arr_type; - } in - let arr_entry = new_entry id (DW_TAG_array_type arr_tag) in - let children = List.map (fun a -> - let r = match a with - | None -> None - | Some i -> - let bound = Int64.to_int (Int64.sub i Int64.one) in - Some (BoundConst bound) in - let s = { - subrange_type = None; - subrange_upper_bound = r; - } in - new_entry (next_id ()) (DW_TAG_subrange_type s)) arr.arr_size in - add_children arr_entry children - -let const_to_entry id c = - new_entry id (DW_TAG_const_type ({const_type = c.cst_type})) - -let volatile_to_entry id v = - new_entry id (DW_TAG_volatile_type ({volatile_type = v.vol_type})) - -let enum_to_entry file id e = - let enumerator_to_entry e = - let tag = - { - enumerator_value = Int64.to_int (e.enumerator_const); - enumerator_name = e.enumerator_name; - } in - new_entry (next_id ()) (DW_TAG_enumerator tag) in - let bs = sizeof_ikind enum_ikind in - let enum = { - enumeration_file_loc = file_loc_opt file e.enum_file_loc; - enumeration_byte_size = bs; - enumeration_declaration = Some false; - enumeration_name = Some e.enum_name; - } in - let enum = new_entry id (DW_TAG_enumeration_type enum) in - let child = List.map enumerator_to_entry e.enum_enumerators in - add_children enum child - -let fun_type_to_entry id f = - let children = if f.fun_prototyped then - let u = { - unspecified_parameter_artificial = None; - } in - [new_entry (next_id ()) (DW_TAG_unspecified_parameter u)] - else - List.map (fun p -> - let fp = { - formal_parameter_artificial = None; - formal_parameter_name = if p.param_name <> "" then Some p.param_name else None; - formal_parameter_type = p.param_type; - formal_parameter_variable_parameter = None; - formal_parameter_location = None; + let pointer_to_entry id p = + let p = {pointer_type = p.pts} in + new_entry id (DW_TAG_pointer_type p) + + let array_to_entry id arr = + let arr_tag = { + array_type = arr.arr_type; } in - new_entry (next_id ()) (DW_TAG_formal_parameter fp)) f.fun_params; - in - let s = { - subroutine_type = f.fun_return_type; - subroutine_prototyped = f.fun_prototyped - } in - let s = new_entry id (DW_TAG_subroutine_type s) in - add_children s children - -let member_to_entry mem = - let mem = { - member_byte_size = mem.cfd_byte_size; - member_bit_offset = mem.cfd_bit_offset; - member_bit_size = mem.cfd_bit_size; - member_data_member_location = - (match mem.cfd_byte_offset with - | None -> None - | Some s -> Some (DataLocBlock (DW_OP_plus_uconst s))); - member_declaration = None; - member_name = Some (mem.cfd_name); - member_type = mem.cfd_typ; - } in - new_entry (next_id ()) (DW_TAG_member mem) - -let struct_to_entry file id s = - let tag = { - structure_file_loc = file_loc_opt file s.ct_file_loc; - structure_byte_size = s.ct_sizeof; - structure_declaration = if s.ct_declaration then Some s.ct_declaration else None; - structure_name = if s.ct_name <> "" then Some s.ct_name else None; - } in - let entry = new_entry id (DW_TAG_structure_type tag) in - let child = List.map member_to_entry s.ct_members in - add_children entry child - -let union_to_entry file id s = - let tag = { - union_file_loc = file_loc_opt file s.ct_file_loc; - union_byte_size = s.ct_sizeof; - union_declaration = if s.ct_declaration then Some s.ct_declaration else None; - union_name = if s.ct_name <> "" then Some s.ct_name else None; - } in - let entry = new_entry id (DW_TAG_union_type tag) in - let child = List.map member_to_entry s.ct_members in - add_children entry child - -let composite_to_entry file id s = - match s.ct_sou with - | Struct -> struct_to_entry file id s - | Union -> union_to_entry file id s - -let infotype_to_entry file id = function - | IntegerType i -> int_type_to_entry id i - | FloatType f -> float_type_to_entry id f - | PointerType p -> pointer_to_entry id p - | ArrayType arr -> array_to_entry id arr - | CompositeType c -> composite_to_entry file id c - | EnumType e -> enum_to_entry file id e - | FunctionType f -> fun_type_to_entry id f - | Typedef t -> typedef_to_entry file id t - | ConstType c -> const_to_entry id c - | VolatileType v -> volatile_to_entry id v - | Void -> void_to_entry id - -let needs_types id d = - let add_type id d = - if not (IntSet.mem id d) then - IntSet.add id d,true - else - d,false in - let t = Hashtbl.find types id in - match t with - | IntegerType _ - | FloatType _ - | Void - | EnumType _ -> d,false - | Typedef t -> - add_type (get_opt_val t.typ) d - | PointerType p -> - add_type p.pts d - | ArrayType arr -> - add_type arr.arr_type d - | ConstType c -> - add_type c.cst_type d - | VolatileType v -> - add_type v.vol_type d - | FunctionType f -> - let d,c = match f.fun_return_type with - | Some t -> add_type t d - | None -> d,false in - List.fold_left (fun (d,c) p -> - let d,c' = add_type p.param_type d in - d,c||c') (d,c) f.fun_params - | CompositeType c -> - List.fold_left (fun (d,c) f -> - let d,c' = add_type f.cfd_typ d in - d,c||c') (d,false) c.ct_members - -let gen_types file needed = - let rec aux d = - let d,c = IntSet.fold (fun id (d,c) -> - let d,c' = needs_types id d in - d,c||c') d (d,false) in - if c then - aux d - else - d in - let typs = aux needed in - List.rev (Hashtbl.fold (fun id t acc -> - if IntSet.mem id typs then - (infotype_to_entry file id t)::acc - else - acc) types []) - -let global_variable_to_entry file acc id v = - let loc = match v.gvar_atom with - | Some a when StringSet.mem (extern_atom a) !printed_vars -> - Some (LocSymbol a) - | _ -> None in - let var = { - variable_file_loc = file v.gvar_file_loc; - variable_declaration = Some v.gvar_declaration; - variable_external = Some v.gvar_external; - variable_name = v.gvar_name; - variable_type = v.gvar_type; - variable_location = loc; - } in - new_entry id (DW_TAG_variable var),IntSet.add v.gvar_type acc - -let gen_splitlong op_hi op_lo = - let op_piece = DW_OP_piece 4 in - op_piece::op_hi@(op_piece::op_lo) - -let translate_function_loc a = function - | BA_addrstack (ofs) -> - let ofs = camlint_of_coqint ofs in - Some (LocSimple (DW_OP_bregx (a,ofs))),[] - | BA_splitlong (BA_addrstack hi,BA_addrstack lo)-> - let hi = camlint_of_coqint hi - and lo = camlint_of_coqint lo in - if lo = Int32.add hi 4l then - Some (LocSimple (DW_OP_bregx (a,hi))),[] + let arr_entry = new_entry id (DW_TAG_array_type arr_tag) in + let children = List.map (fun a -> + let r = match a with + | None -> None + | Some i -> + let bound = Int64.to_int (Int64.sub i Int64.one) in + Some (BoundConst bound) in + let s = { + subrange_type = None; + subrange_upper_bound = r; + } in + new_entry (next_id ()) (DW_TAG_subrange_type s)) arr.arr_size in + add_children arr_entry children + + let const_to_entry id c = + new_entry id (DW_TAG_const_type ({const_type = c.cst_type})) + + let volatile_to_entry id v = + new_entry id (DW_TAG_volatile_type ({volatile_type = v.vol_type})) + + let enum_to_entry id e = + let enumerator_to_entry e = + let tag = + { + enumerator_value = Int64.to_int (e.enumerator_const); + enumerator_name = string_entry e.enumerator_name; + } in + new_entry (next_id ()) (DW_TAG_enumerator tag) in + let bs = sizeof_ikind enum_ikind in + let enum = { + enumeration_file_loc = file_loc_opt e.enum_file_loc; + enumeration_byte_size = bs; + enumeration_declaration = Some false; + enumeration_name = string_entry e.enum_name; + } in + let enum = new_entry id (DW_TAG_enumeration_type enum) in + let child = List.map enumerator_to_entry e.enum_enumerators in + add_children enum child + + let fun_type_to_entry id f = + let children = if f.fun_prototyped then + let u = { + unspecified_parameter_artificial = None; + } in + [new_entry (next_id ()) (DW_TAG_unspecified_parameter u)] else - let op_hi = [DW_OP_bregx (a,hi)] - and op_lo = [DW_OP_bregx (a,lo)] in - Some (LocList (gen_splitlong op_hi op_lo)),[] - | _ -> None,[] - -let range_entry_loc (sp,l) = - let rec aux = function - | BA i -> [DW_OP_reg i] - | BA_addrstack ofs -> - let ofs = camlint_of_coqint ofs in - [DW_OP_bregx (sp,ofs)] - | BA_splitlong (hi,lo) -> - let hi = aux hi - and lo = aux lo in - gen_splitlong hi lo - | _ -> assert false in - match aux l with - | [] -> assert false - | [a] -> LocSimple a - | a::rest -> LocList (a::rest) - -let location_entry f_id atom = - try - begin - match (Hashtbl.find var_locations (f_id,atom)) with - | FunctionLoc (a,r) -> - translate_function_loc a r - | RangeLoc l -> - let l = List.rev_map (fun i -> - let hi = get_opt_val i.range_start - and lo = get_opt_val i.range_end in - let hi = Hashtbl.find label_translation (f_id,hi) - and lo = Hashtbl.find label_translation (f_id,lo) in - hi,lo,range_entry_loc i.var_loc) l in - let id = next_id () in - Some (LocRef id),[{loc = l;loc_id = id;}] - end - with Not_found -> None,[] - -let function_parameter_to_entry f_id (acc,bcc) p = - let loc,loc_list = location_entry f_id (get_opt_val p.parameter_atom) in - let p = { - formal_parameter_artificial = None; - formal_parameter_name = Some p.parameter_name; - formal_parameter_type = p.parameter_type; - 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) + List.map (fun p -> + let fp = { + formal_parameter_artificial = None; + formal_parameter_name = name_opt p.param_name; + formal_parameter_type = p.param_type; + formal_parameter_variable_parameter = None; + formal_parameter_location = None; + } in + new_entry (next_id ()) (DW_TAG_formal_parameter fp)) f.fun_params; + in + let s = { + subroutine_type = f.fun_return_type; + subroutine_prototyped = f.fun_prototyped + } in + let s = new_entry id (DW_TAG_subroutine_type s) in + add_children s children + + let member_to_entry mem = + let mem = { + member_byte_size = mem.cfd_byte_size; + member_bit_offset = mem.cfd_bit_offset; + member_bit_size = mem.cfd_bit_size; + member_data_member_location = + (match mem.cfd_byte_offset with + | None -> None + | Some s -> Some (DataLocBlock (DW_OP_plus_uconst s))); + member_declaration = None; + member_name = string_entry mem.cfd_name; + member_type = mem.cfd_typ; + } in + new_entry (next_id ()) (DW_TAG_member mem) + + let struct_to_entry id s = + let tag = { + structure_file_loc = file_loc_opt s.ct_file_loc; + structure_byte_size = s.ct_sizeof; + structure_declaration = if s.ct_declaration then Some s.ct_declaration else None; + structure_name = name_opt s.ct_name; + } in + let entry = new_entry id (DW_TAG_structure_type tag) in + let child = List.map member_to_entry s.ct_members in + add_children entry child + + let union_to_entry id s = + let tag = { + union_file_loc = file_loc_opt s.ct_file_loc; + union_byte_size = s.ct_sizeof; + union_declaration = if s.ct_declaration then Some s.ct_declaration else None; + union_name = name_opt s.ct_name; + } in + let entry = new_entry id (DW_TAG_union_type tag) in + let child = List.map member_to_entry s.ct_members in + add_children entry child + + let composite_to_entry id s = + match s.ct_sou with + | Struct -> struct_to_entry id s + | Union -> union_to_entry id s + + let infotype_to_entry id = function + | IntegerType i -> int_type_to_entry id i + | FloatType f -> float_type_to_entry id f + | PointerType p -> pointer_to_entry id p + | ArrayType arr -> array_to_entry id arr + | CompositeType c -> composite_to_entry id c + | EnumType e -> enum_to_entry id e + | FunctionType f -> fun_type_to_entry id f + | Typedef t -> typedef_to_entry id t + | ConstType c -> const_to_entry id c + | VolatileType v -> volatile_to_entry id v + | Void -> void_to_entry id + + let needs_types id d = + let add_type id d = + if not (IntSet.mem id d) then + IntSet.add id d,true + else + d,false in + let t = Hashtbl.find types id in + match t with + | IntegerType _ + | FloatType _ + | Void + | EnumType _ -> d,false + | Typedef t -> + add_type (get_opt_val t.typ) d + | PointerType p -> + add_type p.pts d + | ArrayType arr -> + add_type arr.arr_type d + | ConstType c -> + add_type c.cst_type d + | VolatileType v -> + add_type v.vol_type d + | FunctionType f -> + let d,c = match f.fun_return_type with + | Some t -> add_type t d + | None -> d,false in + List.fold_left (fun (d,c) p -> + let d,c' = add_type p.param_type d in + d,c||c') (d,c) f.fun_params + | CompositeType c -> + List.fold_left (fun (d,c) f -> + let d,c' = add_type f.cfd_typ d in + d,c||c') (d,false) c.ct_members + + let gen_types needed = + let rec aux d = + let d,c = IntSet.fold (fun id (d,c) -> + let d,c' = needs_types id d in + d,c||c') d (d,false) in + if c then + aux d + else + d in + let typs = aux needed in + List.rev (Hashtbl.fold (fun id t acc -> + if IntSet.mem id typs then + (infotype_to_entry id t)::acc + else + acc) types []) -let rec local_variable_to_entry file f_id (acc,bcc) v id = - match v.lvar_atom with - | None -> None,(acc,bcc) - | Some loc -> - let loc,loc_list = location_entry f_id loc in + let global_variable_to_entry acc id v = + let loc = match v.gvar_atom with + | Some a when StringSet.mem (extern_atom a) !printed_vars -> + Some (LocSymbol a) + | _ -> None in let var = { - variable_file_loc = file v.lvar_file_loc; - variable_declaration = None; - variable_external = None; - variable_name = v.lvar_name; - variable_type = v.lvar_type; + variable_file_loc = file_loc v.gvar_file_loc; + variable_declaration = Some v.gvar_declaration; + variable_external = Some v.gvar_external; + variable_name = string_entry v.gvar_name; + variable_type = v.gvar_type; variable_location = loc; } in - Some (new_entry id (DW_TAG_variable var)),(IntSet.add v.lvar_type acc,loc_list@bcc) - -and scope_to_entry file f_id acc sc id = - let l_pc,h_pc = try - let r = Hashtbl.find scope_ranges id in - let lbl l = match l with - | Some l -> Some (Hashtbl.find label_translation (f_id,l)) - | None -> None in - begin - match r with - | [] -> None,None - | [a] -> lbl a.start_addr, lbl a.end_addr - | a::rest -> lbl (List.hd (List.rev rest)).start_addr,lbl a.end_addr - end - with Not_found -> None,None in - let scope = { - lexical_block_high_pc = h_pc; - lexical_block_low_pc = l_pc; - } in - let vars,acc = mmap_opt (local_to_entry file f_id) acc sc.scope_variables in - let entry = new_entry id (DW_TAG_lexical_block scope) in - add_children entry vars,acc - -and local_to_entry file f_id acc id = - match Hashtbl.find local_variables id with - | LocalVariable v -> local_variable_to_entry file f_id acc v id - | Scope v -> let s,acc = - (scope_to_entry file f_id acc v id) in - Some s,acc - -let fun_scope_to_entries file f_id acc id = - match id with - | None -> [],acc - | Some id -> - let sc = Hashtbl.find local_variables id in - (match sc with - | Scope sc ->mmap_opt (local_to_entry file f_id) acc sc.scope_variables - | _ -> assert false) - -let function_to_entry file (acc,bcc) id f = - let f_tag = { - subprogram_file_loc = file f.fun_file_loc; - subprogram_external = Some f.fun_external; - subprogram_name = f.fun_name; - subprogram_prototyped = true; - subprogram_type = f.fun_return_type; - subprogram_high_pc = f.fun_high_pc; - subprogram_low_pc = f.fun_low_pc; - } 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 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 file f_id (acc,bcc) f.fun_scope in - add_children f_entry (params@vars),(acc,bcc) - -let definition_to_entry file (acc,bcc) id t = - match t with - | GlobalVariable g -> let e,acc = global_variable_to_entry file acc id g in - e,(acc,bcc) - | Function f -> function_to_entry file (acc,bcc) id f + new_entry id (DW_TAG_variable var),IntSet.add v.gvar_type acc + + let gen_splitlong op_hi op_lo = + let op_piece = DW_OP_piece 4 in + op_piece::op_hi@(op_piece::op_lo) + + let translate_function_loc a = function + | BA_addrstack (ofs) -> + let ofs = camlint_of_coqint ofs in + Some (LocSimple (DW_OP_bregx (a,ofs))),[] + | BA_splitlong (BA_addrstack hi,BA_addrstack lo)-> + let hi = camlint_of_coqint hi + and lo = camlint_of_coqint lo in + if lo = Int32.add hi 4l then + Some (LocSimple (DW_OP_bregx (a,hi))),[] + else + let op_hi = [DW_OP_bregx (a,hi)] + and op_lo = [DW_OP_bregx (a,lo)] in + Some (LocList (gen_splitlong op_hi op_lo)),[] + | _ -> None,[] + + let range_entry_loc (sp,l) = + let rec aux = function + | BA i -> [DW_OP_reg i] + | BA_addrstack ofs -> + let ofs = camlint_of_coqint ofs in + [DW_OP_bregx (sp,ofs)] + | BA_splitlong (hi,lo) -> + let hi = aux hi + and lo = aux lo in + gen_splitlong hi lo + | _ -> assert false in + match aux l with + | [] -> assert false + | [a] -> LocSimple a + | a::rest -> LocList (a::rest) + + let location_entry f_id atom = + try + begin + match (Hashtbl.find var_locations (f_id,atom)) with + | FunctionLoc (a,r) -> + translate_function_loc a r + | RangeLoc l -> + let l = List.rev_map (fun i -> + let hi = get_opt_val i.range_start + and lo = get_opt_val i.range_end in + let hi = Hashtbl.find label_translation (f_id,hi) + and lo = Hashtbl.find label_translation (f_id,lo) in + hi,lo,range_entry_loc i.var_loc) l in + let id = next_id () in + Some (LocRef id),[{loc = l;loc_id = id;}] + end + with Not_found -> None,[] + + let function_parameter_to_entry f_id (acc,bcc) p = + let loc,loc_list = location_entry f_id (get_opt_val p.parameter_atom) in + let p = { + formal_parameter_artificial = None; + formal_parameter_name = name_opt p.parameter_name; + formal_parameter_type = p.parameter_type; + 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 rec local_variable_to_entry f_id (acc,bcc) v id = + match v.lvar_atom with + | None -> None,(acc,bcc) + | Some loc -> + let loc,loc_list = location_entry f_id loc in + let var = { + variable_file_loc = file_loc v.lvar_file_loc; + variable_declaration = None; + variable_external = None; + variable_name = string_entry v.lvar_name; + 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) + + and scope_to_entry f_id acc sc id = + let l_pc,h_pc = try + let r = Hashtbl.find scope_ranges id in + let lbl l = match l with + | Some l -> Some (Hashtbl.find label_translation (f_id,l)) + | None -> None in + begin + match r with + | [] -> None,None + | [a] -> lbl a.start_addr, lbl a.end_addr + | a::rest -> lbl (List.hd (List.rev rest)).start_addr,lbl a.end_addr + end + with Not_found -> None,None in + let scope = { + lexical_block_high_pc = h_pc; + lexical_block_low_pc = l_pc; + } 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 + + 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 + Some s,acc + + let fun_scope_to_entries f_id acc id = + match id with + | None -> [],acc + | 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 + | _ -> assert false) + + let function_to_entry (acc,bcc) id f = + let f_tag = { + subprogram_file_loc = file_loc f.fun_file_loc; + subprogram_external = Some f.fun_external; + subprogram_name = string_entry f.fun_name; + subprogram_prototyped = true; + subprogram_type = f.fun_return_type; + subprogram_high_pc = f.fun_high_pc; + subprogram_low_pc = f.fun_low_pc; + } 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 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 definition_to_entry (acc,bcc) 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 + + end module StringMap = Map.Make(String) let diab_file_loc sec (f,l) = Diab_file_loc (Hashtbl.find filenum (sec,f),l) +let prod_name = + let version_string = + if Version.buildnr <> "" && Version.tag <> "" then + Printf.sprintf "%s, Build: %s, Tag: %s" Version.version Version.buildnr Version.tag + else + Version.version in + 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 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 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 + let cp = { + compile_unit_name = Simple_string !file_name; + compile_unit_low_pc = low_pc; + compile_unit_high_pc = high_pc; + compile_unit_dir = Simple_string (Sys.getcwd ()); + 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 + { + section_name = s; + start_label = debug_start; + line_label = line_start; + entry = cp; + locs = Some low_pc,locs; + }::acc + let gen_diab_debug_info sec_name var_section : debug_entries = let defs = Hashtbl.fold (fun id t acc -> let s = match t with @@ -443,49 +495,48 @@ 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) definitions StringMap.empty in - let entries = StringMap.fold (fun s defs acc -> - let defs,(ty,locs) = List.fold_left (fun (acc,bcc) (id,t) -> - let t,bcc = definition_to_entry (diab_file_loc s) bcc id t in - t::acc,bcc) ([],(IntSet.empty,[])) 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 - let cp = { - compile_unit_name = !file_name; - compile_unit_low_pc = low_pc; - compile_unit_high_pc = high_pc; - } in - let cp = new_entry (next_id ()) (DW_TAG_compile_unit cp) in - let cp = add_children cp ((gen_types (diab_file_loc s) ty) @ defs) in - let entry = { - section_name = s; - start_label = debug_start; - line_label = line_start; - entry = cp; - locs = Some low_pc,locs; - } in - entry::acc) defs [] in + let entries = StringMap.fold diab_gen_compilation_section defs [] in Diab entries let gnu_file_loc (f,l) = - Gnu_file_loc ((fst (Hashtbl.find Fileinfo.filename_info f),l)) + Gnu_file_loc ((fst (Hashtbl.find Fileinfo.filename_info f),l)) +let string_table: (string,int) Hashtbl.t = Hashtbl.create 7 + +let gnu_string_entry s = + if String.length s < 4 || Configuration.system = "cygwin" then (*Cygwin does not use the debug_str seciton *) + Simple_string s + else + try + Offset_string (Hashtbl.find string_table s) + with Not_found -> + let id = next_id () in + Hashtbl.add string_table s id; + Offset_string id + let gen_gnu_debug_info sec_name var_section : debug_entries = let low_pc = Hashtbl.find compilation_section_start ".text" and high_pc = Hashtbl.find compilation_section_end ".text" 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 s = match t with | GlobalVariable _ -> var_section | Function f -> sec_name (get_opt_val f.fun_atom) in - let t,bcc = definition_to_entry gnu_file_loc bcc id t 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_types gnu_file_loc ty in + let types = Gen.gen_types ty in let cp = { - compile_unit_name = !file_name; + compile_unit_name = gnu_string_entry !file_name; compile_unit_low_pc = low_pc; - compile_unit_high_pc = high_pc; + compile_unit_high_pc = high_pc; + compile_unit_dir = gnu_string_entry (Sys.getcwd ()); + compile_unit_prod_name = gnu_string_entry prod_name; } in let cp = new_entry (next_id ()) (DW_TAG_compile_unit cp) in let cp = add_children cp (types@defs) in let loc_pc = if StringSet.cardinal sec > 1 then None else Some low_pc in - Gnu (cp,(loc_pc,locs)) + let string_table = Hashtbl.fold (fun s i acc -> (i,s)::acc) string_table [] in + Gnu (cp,(loc_pc,locs),string_table) -- cgit From a479c280441b91007c379b0b63b907926d54f930 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Tue, 13 Oct 2015 16:23:20 +0200 Subject: Changed the type of the debug sections with additional string. Instead of using a string they now take an optional string, which should be none if the backend is not the diab backend and the corresponding section is the text section and Some s with s being the custom section name else. Bug 17392. --- debug/DwarfPrinter.ml | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) (limited to 'debug') diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index 407850a5..12ad16bf 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -602,7 +602,8 @@ module DwarfPrinter(Target: DWARF_TARGET): List.iter (fun e -> compute_abbrev e.entry) entries; print_abbrev oc; List.iter (fun e -> - section oc (Section_debug_info e.section_name); + let name = if e.section_name <> ".text" then Some e.section_name else None in + section oc (Section_debug_info name); print_debug_info oc e.start_label e.line_label e.entry) entries; section oc Section_debug_loc; List.iter (fun e -> print_location_list oc e.locs) entries @@ -613,12 +614,12 @@ module DwarfPrinter(Target: DWARF_TARGET): and start = new_label () and abbrev_start = new_label () in abbrev_start_addr := abbrev_start; - section oc (Section_debug_info ""); + section oc (Section_debug_info None); print_debug_info oc start line_start cp; print_abbrev oc; section oc Section_debug_loc; print_location_list oc loc; - section oc (Section_debug_line ""); + section oc (Section_debug_line None); print_label oc line_start; section oc Section_debug_str; List.iter (fun (id,s) -> -- cgit From 60ab550a952c3d9719b2a91ec90c9b58769f6717 Mon Sep 17 00:00:00 2001 From: Michael Schmidt Date: Wed, 14 Oct 2015 15:07:48 +0200 Subject: bug 17392: remove trailing whitespace in source files --- debug/Debug.ml | 2 +- debug/Debug.mli | 2 +- debug/DebugInformation.ml | 58 ++++++++++++++++++------------------- debug/DebugTypes.mli | 6 ++-- debug/DwarfPrinter.ml | 8 ++--- debug/DwarfTypes.mli | 6 ++-- debug/Dwarfgen.ml | 74 +++++++++++++++++++++++------------------------ 7 files changed, 78 insertions(+), 78 deletions(-) (limited to 'debug') diff --git a/debug/Debug.ml b/debug/Debug.ml index 25517eee..806ebb08 100644 --- a/debug/Debug.ml +++ b/debug/Debug.ml @@ -20,7 +20,7 @@ open DwarfTypes (* Interface for generating and printing debug information *) (* Record used for stroring references to the actual implementation functions *) -type implem = +type implem = { init: string -> unit; atom_global: ident -> atom -> unit; diff --git a/debug/Debug.mli b/debug/Debug.mli index 553e1412..145927f4 100644 --- a/debug/Debug.mli +++ b/debug/Debug.mli @@ -18,7 +18,7 @@ open BinNums (* Record used for stroring references to the actual implementation functions *) -type implem = +type implem = { init: string -> unit; atom_global: ident -> atom -> unit; diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index 96f55f40..55d49e72 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -17,7 +17,7 @@ open Camlcoq open Cutil open DebugTypes -(* This implements an interface for the collection of debugging +(* This implements an interface for the collection of debugging information. *) (* Simple id generator *) @@ -71,20 +71,20 @@ let find_type (ty: typ) = (* Add type and information *) let insert_type (ty: typ) = let insert d_ty ty = - let id = next_id () + let id = next_id () and name = typ_to_string ty in Hashtbl.add types id d_ty; Hashtbl.add lookup_types name id; id in (* We are only interrested in Const and Volatile *) let ty = strip_attributes ty in - let rec typ_aux ty = + let rec typ_aux ty = try find_type ty with | Not_found -> let d_ty = match ty with | TVoid _ -> Void - | TInt (k,_) -> + | TInt (k,_) -> IntegerType ({int_kind = k }) | TFloat (k,_) -> FloatType ({float_kind = k}) @@ -104,14 +104,14 @@ let insert_type (ty: typ) = } in ArrayType arr | TFun (t,param,va,_) -> - let param,prot = (match param with + let param,prot = (match param with | None -> [],false - | Some p -> List.map (fun (i,t) -> let t = attr_aux t in + | Some p -> List.map (fun (i,t) -> let t = attr_aux t in { param_type = t; - param_name = i.name; + param_name = i.name; }) p,true) in - let ret = (match t with + let ret = (match t with | TVoid _ -> None | _ -> Some (attr_aux t)) in let ftype = { @@ -155,7 +155,7 @@ let insert_type (ty: typ) = } in CompositeType union | TEnum (id,_) -> - let enum = + let enum = { enum_name = id.name; enum_byte_size = None; @@ -164,13 +164,13 @@ let insert_type (ty: typ) = } in EnumType enum in insert d_ty ty - and attr_aux ty = + and attr_aux ty = try find_type ty with Not_found -> match strip_last_attribute ty with - | Some AConst,t -> + | Some AConst,t -> let id = attr_aux t in let const = { cst_type = id} in insert (ConstType const) ty @@ -285,7 +285,7 @@ let replace_scope id var = let var = Scope var in Hashtbl.replace local_variables id var -let gen_comp_typ sou id at = +let gen_comp_typ sou id at = if sou = Struct then TStruct (id,at) else @@ -329,11 +329,11 @@ let insert_global_declaration env dec= end end else begin (* Implict declarations need special handling *) - let id' = try Hashtbl.find name_to_definition id.name with Not_found -> + let id' = try Hashtbl.find name_to_definition id.name with Not_found -> let id' = next_id () in Hashtbl.add name_to_definition id.name id';id' in Hashtbl.add stamp_to_definition id.stamp id' - end + end | Gfundef f -> let ret = (match f.fd_ret with | TVoid _ -> None @@ -350,7 +350,7 @@ let insert_global_declaration env dec= parameter_type = ty; }) f.fd_params in let fd = - { + { fun_name = f.fd_name.name; fun_atom = None; fun_file_loc = dec.gloc; @@ -363,19 +363,19 @@ let insert_global_declaration env dec= fun_scope = None; } in begin - let id' = try Hashtbl.find name_to_definition f.fd_name.name with Not_found -> + let id' = try Hashtbl.find name_to_definition f.fd_name.name with Not_found -> let id' = next_id () in Hashtbl.add name_to_definition f.fd_name.name id';id' in Hashtbl.add stamp_to_definition f.fd_name.stamp id'; Hashtbl.add definitions id' (Function fd) end - | Gcompositedecl (sou,id,at) -> + | Gcompositedecl (sou,id,at) -> ignore (insert_type (gen_comp_typ sou id at)); let id = find_type (gen_comp_typ sou id []) in replace_composite id (fun comp -> if comp.ct_file_loc = None then {comp with ct_file_loc = Some (dec.gloc);} else comp) - | Gcompositedef (sou,id,at,fi) -> + | Gcompositedef (sou,id,at,fi) -> ignore (insert_type (gen_comp_typ sou id at)); let id = find_type (gen_comp_typ sou id []) in let fi = List.filter (fun f -> f.fld_name <> "") fi in (* Fields without names need no info *) @@ -392,15 +392,15 @@ let insert_global_declaration env dec= replace_composite id (fun comp -> let loc = if comp.ct_file_loc = None then Some dec.gloc else comp.ct_file_loc in {comp with ct_file_loc = loc; ct_members = fields; ct_declaration = false;}) - | Gtypedef (id,t) -> + | Gtypedef (id,t) -> let id = insert_type (TNamed (id,[])) in let tid = insert_type t in replace_typedef id (fun typ -> {typ with typedef_file_loc = Some dec.gloc; typ = Some tid;}); - | Genumdef (n,at,e) -> + | Genumdef (n,at,e) -> ignore(insert_type (TEnum (n,at))); let id = find_type (TEnum (n,[])) in let enumerator = List.map (fun (i,c,_) -> - { + { enumerator_name = i.name; enumerator_const = c; }) e in @@ -411,19 +411,19 @@ let insert_global_declaration env dec= let set_member_offset str field offset = let id = find_type (TStruct (str,[])) in replace_composite id (fun comp -> - let name f = f.cfd_name = field || match f.cfd_bitfield with Some n -> n = field | _ -> false in + let name f = f.cfd_name = field || match f.cfd_bitfield with Some n -> n = field | _ -> false in let members = list_replace name (fun a -> {a with cfd_byte_offset = Some offset;}) comp.ct_members in {comp with ct_members = members;}) let set_composite_size comp sou size = let id = find_type (gen_comp_typ sou comp []) in - replace_composite id (fun comp -> {comp with ct_sizeof = size;}) + replace_composite id (fun comp -> {comp with ct_sizeof = size;}) let set_bitfield_offset str field offset underlying size = let id = find_type (TStruct (str,[])) in replace_composite id (fun comp -> let name f = f.cfd_name = field in - let members = list_replace name (fun a -> + let members = list_replace name (fun a -> {a with cfd_bit_offset = Some offset; cfd_bitfield = Some underlying; cfd_byte_size = Some size}) comp.ct_members in {comp with ct_members = members;}) @@ -433,10 +433,10 @@ let atom_global id atom = let id' = (Hashtbl.find stamp_to_definition id.stamp) in let g = Hashtbl.find definitions id' in match g with - | Function f -> + | Function f -> replace_fun id' ({f with fun_atom = Some atom;}); Hashtbl.add atom_to_definition atom id'; - Hashtbl.iter (fun (fid,sid) tid -> if fid = id.stamp then + Hashtbl.iter (fun (fid,sid) tid -> if fid = id.stamp then Hashtbl.add atom_to_scope (atom,sid) tid) scope_to_local | GlobalVariable var -> replace_var id' ({var with gvar_atom = Some atom;}) @@ -449,7 +449,7 @@ let atom_parameter fid id atom = let params = list_replace name (fun p -> {p with parameter_atom = Some atom;}) f.fun_parameter in replace_fun fid' ({f with fun_parameter = params;}) with Not_found -> () - + let add_fun_addr atom (high,low) = try let id,f = find_fun_atom atom in @@ -465,7 +465,7 @@ let atom_local_variable id atom = let add_lvar_scope f_id var_id s_id = try let s_id',scope = find_scope_id f_id s_id in - let var_id,_ = find_lvar_stamp var_id.stamp in + let var_id,_ = find_lvar_stamp var_id.stamp in replace_scope s_id' ({scope_variables = var_id::scope.scope_variables;}) with Not_found -> () @@ -543,7 +543,7 @@ let close_scope atom s_id lbl = try let s_id = Hashtbl.find atom_to_scope (atom,s_id) in let old_r = try Hashtbl.find scope_ranges s_id with Not_found -> [] in - let last_r,rest = + let last_r,rest = begin match old_r with | a::rest -> a,rest diff --git a/debug/DebugTypes.mli b/debug/DebugTypes.mli index 6a4f619c..b2f19f7a 100644 --- a/debug/DebugTypes.mli +++ b/debug/DebugTypes.mli @@ -68,7 +68,7 @@ type enum_type = { enum_name: string; enum_byte_size: int option; enum_file_loc: location option; - enum_enumerators: enumerator list; + enum_enumerators: enumerator list; } type int_type = { @@ -115,7 +115,7 @@ type global_variable_information = { gvar_type: int; } -type parameter_information = +type parameter_information = { parameter_name: string; parameter_ident: int; @@ -150,7 +150,7 @@ type local_variable_information = { lvar_static: bool; (* Static variable are mapped to symbols *) } -type scope_information = +type scope_information = { scope_variables: int list; (* Variable and Scope ids *) } diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index 12ad16bf..b7ecb62c 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -85,7 +85,7 @@ module DwarfPrinter(Target: DWARF_TARGET): | Some (LocSymbol _) | Some (LocSimple _) -> add_abbr_entry (0x2,location_block_type_abbr) buf - + (* Dwarf entity to string function *) let abbrev_string_of_entity entity has_sibling = @@ -326,7 +326,7 @@ module DwarfPrinter(Target: DWARF_TARGET): print_uleb128 oc col | Some (Gnu_file_loc (file,col)) -> fprintf oc " .4byte %l\n" file; - print_uleb128 oc col + print_uleb128 oc col | None -> () let print_loc_expr oc = function @@ -472,7 +472,7 @@ module DwarfPrinter(Target: DWARF_TARGET): let print_subprogram_addr oc (s,e) = fprintf oc " .4byte %a\n" label e; fprintf oc " .4byte %a\n" label s - + let print_subprogram oc sp = print_file_loc oc (Some sp.subprogram_file_loc); print_opt_value oc sp.subprogram_external print_flag; @@ -603,7 +603,7 @@ module DwarfPrinter(Target: DWARF_TARGET): print_abbrev oc; List.iter (fun e -> let name = if e.section_name <> ".text" then Some e.section_name else None in - section oc (Section_debug_info name); + section oc (Section_debug_info name); print_debug_info oc e.start_label e.line_label e.entry) entries; section oc Section_debug_loc; List.iter (fun e -> print_location_list oc e.locs) entries diff --git a/debug/DwarfTypes.mli b/debug/DwarfTypes.mli index c7e5dce1..7048d8d3 100644 --- a/debug/DwarfTypes.mli +++ b/debug/DwarfTypes.mli @@ -47,7 +47,7 @@ type location_value = | LocRef of address | LocSimple of location_expression | LocList of location_expression list - + type data_location_value = | DataLocBlock of location_expression | DataLocRef of reference @@ -62,10 +62,10 @@ type string_const = (* Types representing the attribute information per tag value *) -type file_loc = +type file_loc = | Diab_file_loc of constant * constant | Gnu_file_loc of constant * constant - + type dw_tag_array_type = { array_type: reference; diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml index 78c4fffb..1ef3938a 100644 --- a/debug/Dwarfgen.ml +++ b/debug/Dwarfgen.ml @@ -58,20 +58,20 @@ module type TARGET = module Dwarfgenaux (Target: TARGET) = struct - + include Target let name_opt n = if n <> "" then Some (string_entry n) else None - + (* Functions to translate the basetypes. *) let int_type_to_entry id i = let encoding = (match i.int_kind with | IBool -> DW_ATE_boolean | IChar -> - if !Machine.config.Machine.char_signed then - DW_ATE_signed_char - else + if !Machine.config.Machine.char_signed then + DW_ATE_signed_char + else DW_ATE_unsigned_char | IInt | ILong | ILongLong | IShort | ISChar -> DW_ATE_signed | _ -> DW_ATE_unsigned)in @@ -82,7 +82,7 @@ module Dwarfgenaux (Target: TARGET) = } in new_entry id (DW_TAG_base_type int) - let float_type_to_entry id f = + let float_type_to_entry id f = let byte_size = sizeof_fkind f.float_kind in let float = { base_type_byte_size = byte_size; @@ -102,7 +102,7 @@ module Dwarfgenaux (Target: TARGET) = let file_loc_opt = function | None -> None | Some (f,l) -> - try + try Some (file_loc (f,l)) with Not_found -> None @@ -113,7 +113,7 @@ module Dwarfgenaux (Target: TARGET) = typedef_name = string_entry t.typedef_name; typedef_type = i; } in - new_entry id (DW_TAG_typedef td) + new_entry id (DW_TAG_typedef td) let pointer_to_entry id p = let p = {pointer_type = p.pts} in @@ -192,8 +192,8 @@ module Dwarfgenaux (Target: TARGET) = member_bit_offset = mem.cfd_bit_offset; member_bit_size = mem.cfd_bit_size; member_data_member_location = - (match mem.cfd_byte_offset with - | None -> None + (match mem.cfd_byte_offset with + | None -> None | Some s -> Some (DataLocBlock (DW_OP_plus_uconst s))); member_declaration = None; member_name = string_entry mem.cfd_name; @@ -245,19 +245,19 @@ module Dwarfgenaux (Target: TARGET) = let add_type id d = if not (IntSet.mem id d) then IntSet.add id d,true - else + else d,false in let t = Hashtbl.find types id in match t with - | IntegerType _ + | IntegerType _ | FloatType _ | Void | EnumType _ -> d,false | Typedef t -> add_type (get_opt_val t.typ) d - | PointerType p -> + | PointerType p -> add_type p.pts d - | ArrayType arr -> + | ArrayType arr -> add_type arr.arr_type d | ConstType c -> add_type c.cst_type d @@ -265,12 +265,12 @@ module Dwarfgenaux (Target: TARGET) = add_type v.vol_type d | FunctionType f -> let d,c = match f.fun_return_type with - | Some t -> add_type t d + | Some t -> add_type t d | None -> d,false in List.fold_left (fun (d,c) p -> let d,c' = add_type p.param_type d in d,c||c') (d,c) f.fun_params - | CompositeType c -> + | CompositeType c -> List.fold_left (fun (d,c) f -> let d,c' = add_type f.cfd_typ d in d,c||c') (d,false) c.ct_members @@ -285,10 +285,10 @@ module Dwarfgenaux (Target: TARGET) = else d in let typs = aux needed in - List.rev (Hashtbl.fold (fun id t acc -> + List.rev (Hashtbl.fold (fun id t acc -> if IntSet.mem id typs then (infotype_to_entry id t)::acc - else + else acc) types []) let global_variable_to_entry acc id v = @@ -309,13 +309,13 @@ module Dwarfgenaux (Target: TARGET) = let gen_splitlong op_hi op_lo = let op_piece = DW_OP_piece 4 in op_piece::op_hi@(op_piece::op_lo) - - let translate_function_loc a = function + + let translate_function_loc a = function | BA_addrstack (ofs) -> let ofs = camlint_of_coqint ofs in Some (LocSimple (DW_OP_bregx (a,ofs))),[] | BA_splitlong (BA_addrstack hi,BA_addrstack lo)-> - let hi = camlint_of_coqint hi + let hi = camlint_of_coqint hi and lo = camlint_of_coqint lo in if lo = Int32.add hi 4l then Some (LocSimple (DW_OP_bregx (a,hi))),[] @@ -324,11 +324,11 @@ module Dwarfgenaux (Target: TARGET) = and op_lo = [DW_OP_bregx (a,lo)] in Some (LocList (gen_splitlong op_hi op_lo)),[] | _ -> None,[] - + let range_entry_loc (sp,l) = let rec aux = function | BA i -> [DW_OP_reg i] - | BA_addrstack ofs -> + | BA_addrstack ofs -> let ofs = camlint_of_coqint ofs in [DW_OP_bregx (sp,ofs)] | BA_splitlong (hi,lo) -> @@ -343,12 +343,12 @@ module Dwarfgenaux (Target: TARGET) = let location_entry f_id atom = try - begin + begin match (Hashtbl.find var_locations (f_id,atom)) with | FunctionLoc (a,r) -> translate_function_loc a r | RangeLoc l -> - let l = List.rev_map (fun i -> + let l = List.rev_map (fun i -> let hi = get_opt_val i.range_start and lo = get_opt_val i.range_end in let hi = Hashtbl.find label_translation (f_id,hi) @@ -388,8 +388,8 @@ module Dwarfgenaux (Target: TARGET) = and scope_to_entry f_id acc sc id = let l_pc,h_pc = try let r = Hashtbl.find scope_ranges id in - let lbl l = match l with - | Some l -> Some (Hashtbl.find label_translation (f_id,l)) + let lbl l = match l with + | Some l -> Some (Hashtbl.find label_translation (f_id,l)) | None -> None in begin match r with @@ -409,8 +409,8 @@ module Dwarfgenaux (Target: TARGET) = 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 = @@ -438,7 +438,7 @@ module Dwarfgenaux (Target: TARGET) = 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 definition_to_entry (acc,bcc) id t = match t with | GlobalVariable g -> let e,acc = global_variable_to_entry acc id g in @@ -453,19 +453,19 @@ let diab_file_loc sec (f,l) = Diab_file_loc (Hashtbl.find filenum (sec,f),l) let prod_name = - let version_string = + let version_string = if Version.buildnr <> "" && Version.tag <> "" then Printf.sprintf "%s, Build: %s, Tag: %s" Version.version Version.buildnr Version.tag else Version.version in - Printf.sprintf "AbsInt Angewandte Informatik GmbH:CompCert Version %s:(%s,%s,%s,%s)" + 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 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 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 low_pc = Hashtbl.find compilation_section_start s @@ -487,7 +487,7 @@ let diab_gen_compilation_section s defs acc = entry = cp; locs = Some low_pc,locs; }::acc - + let gen_diab_debug_info sec_name var_section : debug_entries = let defs = Hashtbl.fold (fun id t acc -> let s = match t with @@ -513,15 +513,15 @@ let gnu_string_entry s = let id = next_id () in Hashtbl.add string_table s id; Offset_string id - + let gen_gnu_debug_info sec_name var_section : debug_entries = let low_pc = Hashtbl.find compilation_section_start ".text" and high_pc = Hashtbl.find compilation_section_end ".text" in - let module Gen = Dwarfgenaux (struct + 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,(ty,locs),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 -- cgit From ccfc5ced6a09ce2c8a1ebce81050c328c17c9bec Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Wed, 14 Oct 2015 10:10:19 +0200 Subject: Reworked the section interface for the debug information. Instead of pushing strings around use the actual section. However the string is still used in the Hashtbl. Bug 17392. --- debug/Debug.ml | 13 +++++++------ debug/Debug.mli | 21 +++++++++++---------- debug/DebugInformation.ml | 16 ++++++++++++---- 3 files changed, 30 insertions(+), 20 deletions(-) (limited to 'debug') diff --git a/debug/Debug.ml b/debug/Debug.ml index 806ebb08..14176d3b 100644 --- a/debug/Debug.ml +++ b/debug/Debug.ml @@ -16,6 +16,7 @@ open C open Camlcoq open Dwarfgen open DwarfTypes +open Sections (* Interface for generating and printing debug information *) @@ -43,14 +44,14 @@ type implem = stack_variable: (atom * atom) -> int * int builtin_arg -> unit; add_label: atom -> positive -> int -> unit; atom_parameter: ident -> ident -> atom -> unit; - add_compilation_section_start: string -> int -> unit; - add_compilation_section_end: string -> int -> unit; - compute_diab_file_enum: (string -> int) -> (string-> int) -> (unit -> unit) -> unit; + add_compilation_section_start: section_name -> int -> unit; + add_compilation_section_end: section_name -> int -> unit; + compute_diab_file_enum: (section_name -> int) -> (string-> int) -> (unit -> unit) -> unit; compute_gnu_file_enum: (string -> unit) -> unit; - exists_section: string -> bool; + exists_section: section_name -> bool; remove_unused: ident -> unit; variable_printed: string -> unit; - add_diab_info: string -> (int * int * string) -> unit; + add_diab_info: section_name -> int -> int -> unit; } let default_implem = @@ -83,7 +84,7 @@ let default_implem = exists_section = (fun _ -> true); remove_unused = (fun _ -> ()); variable_printed = (fun _ -> ()); - add_diab_info = (fun _ _ -> ()); + add_diab_info = (fun _ _ _ -> ()); } let implem = ref default_implem diff --git a/debug/Debug.mli b/debug/Debug.mli index 145927f4..83d5703b 100644 --- a/debug/Debug.mli +++ b/debug/Debug.mli @@ -15,6 +15,7 @@ open C open Camlcoq open DwarfTypes open BinNums +open Sections (* Record used for stroring references to the actual implementation functions *) @@ -41,14 +42,14 @@ type implem = stack_variable: (atom * atom) -> int * int builtin_arg -> unit; add_label: atom -> positive -> int -> unit; atom_parameter: ident -> ident -> atom -> unit; - add_compilation_section_start: string -> int -> unit; - add_compilation_section_end: string -> int -> unit; - compute_diab_file_enum: (string -> int) -> (string-> int) -> (unit -> unit) -> unit; + add_compilation_section_start: section_name -> int -> unit; + add_compilation_section_end: section_name -> int -> unit; + compute_diab_file_enum: (section_name -> int) -> (string-> int) -> (unit -> unit) -> unit; compute_gnu_file_enum: (string -> unit) -> unit; - exists_section: string -> bool; + exists_section: section_name -> bool; remove_unused: ident -> unit; variable_printed: string -> unit; - add_diab_info: string -> (int * int * string) -> unit; + add_diab_info: section_name -> int -> int -> unit; } val default_implem: implem @@ -76,11 +77,11 @@ val stack_variable: (atom * atom) -> int * int builtin_arg -> unit val add_label: atom -> positive -> int -> unit val generate_debug_info: (atom -> string) -> string -> debug_entries option val atom_parameter: ident -> ident -> atom -> unit -val add_compilation_section_start: string -> int -> unit -val add_compilation_section_end: string -> int -> unit -val compute_diab_file_enum: (string -> int) -> (string-> int) -> (unit -> unit) -> unit +val add_compilation_section_start: section_name -> int -> unit +val add_compilation_section_end: section_name -> int -> unit +val compute_diab_file_enum: (section_name -> int) -> (string-> int) -> (unit -> unit) -> unit val compute_gnu_file_enum: (string -> unit) -> unit -val exists_section: string -> bool +val exists_section: section_name -> bool val remove_unused: ident -> unit val variable_printed: string -> unit -val add_diab_info: string -> (int * int * string) -> unit +val add_diab_info: section_name -> int -> int -> unit diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index 55d49e72..95f34b1d 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -16,6 +16,7 @@ open C open Camlcoq open Cutil open DebugTypes +open Sections (* This implements an interface for the collection of debugging information. *) @@ -578,19 +579,26 @@ let stack_variable (f,v) (sp,loc) = let compilation_section_start: (string,int) Hashtbl.t = Hashtbl.create 7 let compilation_section_end: (string,int) Hashtbl.t = Hashtbl.create 7 -let diab_additional: (string,int * int * string) Hashtbl.t = Hashtbl.create 7 +let diab_additional: (string,int * int * section_name) Hashtbl.t = Hashtbl.create 7 + +let section_to_string = function + | Section_user (n,_,_) -> n + | _ -> ".text" let add_compilation_section_start sec addr = + let sec = section_to_string sec in Hashtbl.add compilation_section_start sec addr let add_compilation_section_end sec addr = + let sec = section_to_string sec in Hashtbl.add compilation_section_end sec addr -let add_diab_info sec addr = - Hashtbl.add diab_additional sec addr +let add_diab_info sec addr1 add2 = + let sec' = section_to_string sec in + Hashtbl.add diab_additional sec' (addr1,add2,sec) let exists_section sec = - Hashtbl.mem compilation_section_start sec + Hashtbl.mem compilation_section_start (section_to_string sec) let filenum: (string * string,int) Hashtbl.t = Hashtbl.create 7 -- cgit From df78560fdf859644274dbdabccdd1fdb9e75634e Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Wed, 14 Oct 2015 18:06:04 +0200 Subject: More verbose debug printer. Like, for example the clang, CompCert now prints a more detailed descriptions of the debug information in the assembler file. For each abbreviation and debug entry the dwarf attributes and their encodings are added. Bug 17392. --- debug/DwarfPrinter.ml | 396 +++++++++++++++++++++++++------------------------- debug/DwarfTypes.mli | 28 +++- debug/DwarfUtil.ml | 75 ++++++---- 3 files changed, 273 insertions(+), 226 deletions(-) (limited to 'debug') diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index b7ecb62c..abed6a91 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -27,51 +27,57 @@ module DwarfPrinter(Target: DWARF_TARGET): open Target + let print_comment oc s = + if s <> "" then + fprintf oc " %s %s" comment s + + let string_of_comment s = sprintf " %s %s" comment s + + let add_comment buf s = + Buffer.add_string buf (sprintf " %s %s" comment s) + (* Byte value to string *) - let string_of_byte value = - sprintf " .byte %s\n" (if value then "0x1" else "0x0") + let string_of_byte value ct = + sprintf " .byte %s%s\n" (if value then "0x1" else "0x0") (string_of_comment ct) (* Print a label *) let print_label oc lbl = fprintf oc "%a:\n" label lbl - (* Print a positive label *) - let print_plabel oc lbl = - print_label oc (transl_label lbl) - (* Helper functions for abbreviation printing *) - let add_byte buf value = - Buffer.add_string buf (string_of_byte value) + let add_byte buf value ct = + Buffer.add_string buf (string_of_byte value ct) - let add_abbr_uleb v buf = - Buffer.add_string buf (Printf.sprintf " .uleb128 %d\n" v) + let add_abbr_uleb v ct buf = + Buffer.add_string buf (sprintf " .uleb128 %d%s\n" v (string_of_comment ct)) + + let add_abbr_entry (v1,c1,v2) buf = + add_abbr_uleb v1 c1 buf; + let v2,c2 = code_of_dw_form v2 in + Buffer.add_string buf (sprintf " .uleb128 %d%s\n" v2 (string_of_comment c2)) - let add_abbr_entry (v1,v2) buf = - add_abbr_uleb v1 buf; - add_abbr_uleb v2 buf let add_file_loc buf = - let file,line = file_loc_type_abbr in - add_abbr_entry (0x3a,file) buf; - add_abbr_entry (0x3b,line) buf + add_abbr_entry (0x3a,"DW_AT_decl_file",DW_FORM_data4) buf; + add_abbr_entry (0x3b,"DW_AT_decl_line",DW_FORM_udata) buf - let add_type = add_abbr_entry (0x49,type_abbr) + let add_type = add_abbr_entry (0x49,"DW_AT_type",DW_FORM_ref_addr) - let add_byte_size = add_abbr_entry (0xb,byte_size_type_abbr) + let add_byte_size = add_abbr_entry (0x0b,"DW_AT_byte_size",DW_FORM_data1) - let add_member_size = add_abbr_entry (0xb,member_size_abbr) + let add_member_size = add_abbr_entry (0x0b,"DW_AT_byte_size",DW_FORM_udata) - let add_high_pc = add_abbr_entry (0x12,high_pc_type_abbr) + let add_high_pc = add_abbr_entry (0x12,"DW_AT_high_pc",DW_FORM_addr) - let add_low_pc = add_abbr_entry (0x11,low_pc_type_abbr) + let add_low_pc = add_abbr_entry (0x11,"DW_AT_low_pc",DW_FORM_addr) - let add_declaration = add_abbr_entry (0x3c,declaration_type_abbr) + let add_declaration = add_abbr_entry (0x3c,"DW_AT_declaration",DW_FORM_flag) - let add_string buf id = function - | Simple_string _ -> add_abbr_entry (id,dw_form_string) buf - | Offset_string _ -> add_abbr_entry (id,dw_form_strp) buf + let add_string buf id c = function + | Simple_string _ -> add_abbr_entry (id,c,DW_FORM_string) buf + | Offset_string _ -> add_abbr_entry (id,c,DW_FORM_strp) buf - let add_name buf = add_string buf 0x3 + let add_name buf = add_string buf 0x3 "DW_AT_name" let add_name_opt buf = function | None -> () @@ -80,10 +86,10 @@ module DwarfPrinter(Target: DWARF_TARGET): let add_location loc buf = match loc with | None -> () - | Some (LocRef _) -> add_abbr_entry (0x2,location_ref_type_abbr) buf + | Some (LocRef _) -> add_abbr_entry (0x2,"DW_AT_location",DW_FORM_data4) buf | Some (LocList _ ) | Some (LocSymbol _) - | Some (LocSimple _) -> add_abbr_entry (0x2,location_block_type_abbr) buf + | Some (LocSimple _) -> add_abbr_entry (0x2,"DW_AT_location",DW_FORM_block) buf @@ -94,125 +100,125 @@ module DwarfPrinter(Target: DWARF_TARGET): match v with | None -> () | Some _ -> f buf in - let prologue id = + let prologue id c = let has_child = match entity.children with | [] -> false | _ -> true in - add_abbr_uleb id buf; - add_byte buf has_child; - if has_sibling then add_abbr_entry (0x1,sibling_type_abbr) buf; + add_abbr_uleb id c buf; + add_byte buf has_child (if has_child then "DW_CHILDREN_yes" else "DW_CHILDREN_no"); + if has_sibling then add_abbr_entry (0x1,"DW_AT_sibling",DW_FORM_ref4) buf; in (match entity.tag with | DW_TAG_array_type e -> - prologue 0x1; + prologue 0x1 "DW_TAG_array_type"; add_type buf | DW_TAG_base_type b -> - prologue 0x24; + prologue 0x24 "DW_TAG_base_type"; add_byte_size buf; - add_attr_some b.base_type_encoding (add_abbr_entry (0x3e,encoding_type_abbr)); + add_attr_some b.base_type_encoding (add_abbr_entry (0x3e,"DW_AT_encoding",DW_FORM_data1)); add_name buf b.base_type_name; | DW_TAG_compile_unit e -> - prologue 0x11; - add_string buf 0x1b e.compile_unit_dir; + prologue 0x11 "DW_TAG_compile_unit"; + add_string buf 0x1b "DW_AT_comp_dir" e.compile_unit_dir; add_low_pc buf; add_high_pc buf; - add_abbr_entry (0x13,language_type_abbr) buf; + add_abbr_entry (0x13,"DW_AT_language",DW_FORM_udata) buf; add_name buf e.compile_unit_name; - add_string buf 0x25 e.compile_unit_prod_name; - add_abbr_entry (0x10,stmt_list_type_abbr) buf; + add_string buf 0x25 "DW_AT_producer" e.compile_unit_prod_name; + add_abbr_entry (0x10,"DW_AT_stmt_list",DW_FORM_data4) buf; | DW_TAG_const_type _ -> - prologue 0x26; + prologue 0x26 "DW_TAG_const_type"; add_type buf | DW_TAG_enumeration_type e -> - prologue 0x4; + prologue 0x4 "DW_TAG_enumeration_type"; add_attr_some e.enumeration_file_loc add_file_loc; add_byte_size buf; add_attr_some e.enumeration_declaration add_declaration; add_name buf e.enumeration_name | DW_TAG_enumerator e -> - prologue 0x28; - add_abbr_entry (0x1c,value_type_abbr) buf; + prologue 0x28 "DW_TAG_enumerator"; + add_abbr_entry (0x1c,"DW_AT_const_value",DW_FORM_sdata) buf; add_name buf e.enumerator_name | DW_TAG_formal_parameter e -> - prologue 0x5; - add_attr_some e.formal_parameter_artificial (add_abbr_entry (0x34,artificial_type_abbr)); + prologue 0x5 "DW_TAG_formal_parameter"; + add_attr_some e.formal_parameter_artificial (add_abbr_entry (0x34,"DW_AT_artificial",DW_FORM_flag)); add_name_opt buf e.formal_parameter_name; add_type buf; - add_attr_some e.formal_parameter_variable_parameter (add_abbr_entry (0x4b,variable_parameter_type_abbr)); + add_attr_some e.formal_parameter_variable_parameter (add_abbr_entry (0x4b,"DW_AT_variable_parameter",DW_FORM_flag)); add_location e.formal_parameter_location buf | DW_TAG_label e -> - prologue 0xa; + prologue 0xa "DW_TAG_label"; add_low_pc buf; add_name buf e.label_name; | DW_TAG_lexical_block a -> - prologue 0xb; + prologue 0xb "DW_TAG_lexical_block"; add_attr_some a.lexical_block_high_pc add_high_pc; add_attr_some a.lexical_block_low_pc add_low_pc | DW_TAG_member e -> - prologue 0xd; + prologue 0xd "DW_TAG_member"; add_attr_some e.member_byte_size add_byte_size; - add_attr_some e.member_bit_offset (add_abbr_entry (0xc,bit_offset_type_abbr)); - add_attr_some e.member_bit_size (add_abbr_entry (0xd,bit_size_type_abbr)); + add_attr_some e.member_bit_offset (add_abbr_entry (0xc,"DW_AT_bit_offset",DW_FORM_data1)); + add_attr_some e.member_bit_size (add_abbr_entry (0xd,"DW_AT_bit_size",DW_FORM_data1)); add_attr_some e.member_declaration add_declaration; add_name buf e.member_name; add_type buf; (match e.member_data_member_location with | None -> () - | Some (DataLocBlock __) -> add_abbr_entry (0x38,data_location_block_type_abbr) buf - | Some (DataLocRef _) -> add_abbr_entry (0x38,data_location_ref_type_abbr) buf) + | Some (DataLocBlock __) -> add_abbr_entry (0x38,"DW_AT_data_member_location",DW_FORM_block) buf + | Some (DataLocRef _) -> add_abbr_entry (0x38,"DW_AT_data_member_location",DW_FORM_ref4) buf) | DW_TAG_pointer_type _ -> - prologue 0xf; + prologue 0xf "DW_TAG_pointer_type"; add_type buf | DW_TAG_structure_type e -> - prologue 0x13; + prologue 0x13 "DW_TAG_structure_type"; add_attr_some e.structure_file_loc add_file_loc; add_attr_some e.structure_byte_size add_member_size; add_attr_some e.structure_declaration add_declaration; add_name_opt buf e.structure_name | DW_TAG_subprogram e -> - prologue 0x2e; + prologue 0x2e "DW_TAG_subprogram"; add_file_loc buf; - add_attr_some e.subprogram_external (add_abbr_entry (0x3f,external_type_abbr)); - add_attr_some e.subprogram_high_pc add_high_pc; + add_attr_some e.subprogram_external (add_abbr_entry (0x3f,"DW_AT_external",DW_FORM_flag)); add_attr_some e.subprogram_low_pc add_low_pc; + add_attr_some e.subprogram_high_pc add_high_pc; add_name buf e.subprogram_name; - add_abbr_entry (0x27,prototyped_type_abbr) buf; + add_abbr_entry (0x27,"DW_AT_prototyped",DW_FORM_flag) buf; add_attr_some e.subprogram_type add_type; | DW_TAG_subrange_type e -> - prologue 0x21; + prologue 0x21 "DW_TAG_subrange_type"; add_attr_some e.subrange_type add_type; (match e.subrange_upper_bound with | None -> () - | Some (BoundConst _) -> add_abbr_entry (0x2f,bound_const_type_abbr) buf - | Some (BoundRef _) -> add_abbr_entry (0x2f,bound_ref_type_abbr) buf) + | Some (BoundConst _) -> add_abbr_entry (0x2f,"DW_AT_upper_bound",DW_FORM_udata) buf + | Some (BoundRef _) -> add_abbr_entry (0x2f,"DW_AT_upper_bound",DW_FORM_ref4) buf) | DW_TAG_subroutine_type e -> - prologue 0x15; + prologue 0x15 "DW_TAG_subroutine_type"; add_attr_some e.subroutine_type add_type; - add_abbr_entry (0x27,prototyped_type_abbr) buf + add_abbr_entry (0x27,"DW_AT_prototyped",DW_FORM_flag) buf | DW_TAG_typedef e -> - prologue 0x16; + prologue 0x16 "DW_TAG_typedef"; add_attr_some e.typedef_file_loc add_file_loc; add_name buf e.typedef_name; add_type buf | DW_TAG_union_type e -> - prologue 0x17; + prologue 0x17 "DW_TAG_union_type"; add_attr_some e.union_file_loc add_file_loc; add_attr_some e.union_byte_size add_member_size; add_attr_some e.union_declaration add_declaration; add_name_opt buf e.union_name | DW_TAG_unspecified_parameter e -> - prologue 0x18; - add_attr_some e.unspecified_parameter_artificial (add_abbr_entry (0x34,artificial_type_abbr)) + prologue 0x18 "DW_TAG_unspecified_parameter"; + add_attr_some e.unspecified_parameter_artificial (add_abbr_entry (0x34,"DW_AT_artificial",DW_FORM_flag)) | DW_TAG_variable e -> - prologue 0x34; + prologue 0x34 "DW_TAG_variable"; add_file_loc buf; add_attr_some e.variable_declaration add_declaration; - add_attr_some e.variable_external (add_abbr_entry (0x3f,external_type_abbr)); - add_location e.variable_location buf; + add_attr_some e.variable_external (add_abbr_entry (0x3f,"DW_AT_external",DW_FORM_flag)); + add_location e.variable_location buf; add_name buf e.variable_name; add_type buf | DW_TAG_volatile_type _ -> - prologue 0x35; + prologue 0x35 "DW_TAG_volatile_type"; add_type buf); Buffer.contents buf @@ -253,11 +259,11 @@ module DwarfPrinter(Target: DWARF_TARGET): section oc Section_debug_abbrev; print_label oc !abbrev_start_addr; List.iter (fun (s,id) -> - fprintf oc " .uleb128 %d\n" id; + fprintf oc " .uleb128 %d%a\n" id print_comment "Abbreviation Code"; output_string oc s; - fprintf oc " .uleb128 0\n"; - fprintf oc " .uleb128 0\n\n") abbrevs; - fprintf oc " .sleb128 0\n" + fprintf oc " .uleb128 0%a\n" print_comment "EOM(1)"; + fprintf oc " .uleb128 0%a\n" print_comment "EOM(2)") abbrevs; + fprintf oc " .sleb128 0%a\n" print_comment "EOM(3)" let debug_start_addr = ref (-1) @@ -285,117 +291,117 @@ module DwarfPrinter(Target: DWARF_TARGET): Hashtbl.add loc_labels id label; label - let print_loc_ref oc r = + let print_loc_ref oc c r = let ref = loc_to_label r in - fprintf oc " .4byte %a\n" label ref + fprintf oc " .4byte %a%a\n" label ref print_comment c (* Helper functions for debug printing *) - let print_opt_value oc o f = + let print_opt_value oc c o f = match o with | None -> () - | Some o -> f oc o + | Some o -> f oc c o - let print_flag oc b = - output_string oc (string_of_byte b) + let print_flag oc c b = + output_string oc (string_of_byte b c) - let print_string oc = function + let print_string oc c = function | Simple_string s -> - fprintf oc " .asciz \"%s\"\n" s - | Offset_string o -> print_loc_ref oc o + fprintf oc " .asciz \"%s\"%a\n" s print_comment c + | Offset_string o -> print_loc_ref oc c o - let print_uleb128 oc d = - fprintf oc " .uleb128 %d\n" d + let print_uleb128 oc c d = + fprintf oc " .uleb128 %d%a\n" d print_comment c - let print_sleb128 oc d = - fprintf oc " .sleb128 %d\n" d + let print_sleb128 oc c d = + fprintf oc " .sleb128 %d%a\n" d print_comment c - let print_byte oc b = - fprintf oc " .byte 0x%X\n" b + let print_byte oc c b = + fprintf oc " .byte 0x%X%a\n" b print_comment c - let print_2byte oc b = - fprintf oc " .2byte 0x%X\n" b + let print_2byte oc c b = + fprintf oc " .2byte 0x%X%a\n" b print_comment c - let print_ref oc r = + let print_ref oc c r = let ref = entry_to_label r in - fprintf oc " .4byte %a\n" label ref + fprintf oc " .4byte %a%a\n" label ref print_comment c let print_file_loc oc = function | Some (Diab_file_loc (file,col)) -> - fprintf oc " .4byte %a\n" label file; - print_uleb128 oc col + fprintf oc " .4byte %a%a\n" label file print_comment "DW_AT_decl_file"; + print_uleb128 oc "DW_AT_decl_line" col | Some (Gnu_file_loc (file,col)) -> - fprintf oc " .4byte %l\n" file; - print_uleb128 oc col + fprintf oc " .4byte %l%a\n" file print_comment "DW_AT_decl_file"; + print_uleb128 oc "DW_AT_decl_line" col | None -> () let print_loc_expr oc = function | DW_OP_bregx (a,b) -> - print_byte oc dw_op_bregx; - print_uleb128 oc a; - fprintf oc " .sleb128 %ld\n" b + print_byte oc "" dw_op_bregx; + print_uleb128 oc "" a; + fprintf oc " .sleb128 %ld\n" b; | DW_OP_plus_uconst i -> - print_byte oc dw_op_plus_uconst; - print_uleb128 oc i + print_byte oc "" dw_op_plus_uconst; + print_uleb128 oc "" i | DW_OP_piece i -> - print_byte oc dw_op_piece; - print_uleb128 oc i + print_byte oc "" dw_op_piece; + print_uleb128 oc "" i | DW_OP_reg i -> if i < 32 then - print_byte oc (dw_op_reg0 + i) + print_byte oc "" (dw_op_reg0 + i) else begin - print_byte oc dw_op_regx; - print_uleb128 oc i + print_byte oc "" dw_op_regx; + print_uleb128 oc "" i end - let print_loc oc loc = + let print_loc oc c loc = match loc with | LocSymbol s -> - print_sleb128 oc 5; - print_byte oc dw_op_addr; + print_sleb128 oc c 5; + print_byte oc "" dw_op_addr; fprintf oc " .4byte %a\n" symbol s | LocSimple e -> - print_sleb128 oc (size_of_loc_expr e); + print_sleb128 oc c (size_of_loc_expr e); print_loc_expr oc e | LocList e -> let size = List.fold_left (fun acc a -> acc + size_of_loc_expr a) 0 e in - print_sleb128 oc size; + print_sleb128 oc "" size; List.iter (print_loc_expr oc) e - | LocRef f -> print_loc_ref oc f + | LocRef f -> print_loc_ref oc c f let print_list_loc oc = function | LocSymbol s -> - print_2byte oc 5; - print_byte oc dw_op_addr; + print_2byte oc "" 5; + print_byte oc "" dw_op_addr; fprintf oc " .4byte %a\n" symbol s | LocSimple e -> - print_2byte oc (size_of_loc_expr e); + print_2byte oc "" (size_of_loc_expr e); print_loc_expr oc e | LocList e -> let size = List.fold_left (fun acc a -> acc + size_of_loc_expr a) 0 e in - print_2byte oc size; + print_2byte oc "" size; List.iter (print_loc_expr oc) e - | LocRef f -> print_loc_ref oc f + | LocRef f -> print_loc_ref oc "" f - let print_data_location oc dl = + let print_data_location oc c dl = match dl with | DataLocBlock e -> - print_sleb128 oc (size_of_loc_expr e); + print_sleb128 oc c (size_of_loc_expr e); print_loc_expr oc e | _ -> () - let print_addr oc a = - fprintf oc " .4byte %a\n" label a + let print_addr oc c a = + fprintf oc " .4byte %a%a\n" label a print_comment c let print_array_type oc at = - print_ref oc at.array_type + print_ref oc "DW_AT_type" at.array_type - let print_bound_value oc = function - | BoundConst bc -> print_uleb128 oc bc - | BoundRef br -> print_ref oc br + let print_bound_value oc c = function + | BoundConst bc -> print_uleb128 oc c bc + | BoundRef br -> print_ref oc c br let print_base_type oc bt = - print_byte oc bt.base_type_byte_size; + print_byte oc "DW_AT_byte_size" bt.base_type_byte_size; (match bt.base_type_encoding with | Some e -> let encoding = match e with @@ -408,66 +414,66 @@ module DwarfPrinter(Target: DWARF_TARGET): | DW_ATE_unsigned -> 0x7 | DW_ATE_unsigned_char -> 0x8 in - print_byte oc encoding; + print_byte oc "DW_AT_encoding" encoding; | None -> ()); - print_string oc bt.base_type_name + print_string oc "DW_AT_name" bt.base_type_name let print_compilation_unit oc tag = - print_string oc tag.compile_unit_dir; - print_addr oc tag.compile_unit_low_pc; - print_addr oc tag.compile_unit_high_pc; - print_uleb128 oc 1; - print_string oc tag.compile_unit_name; - print_string oc tag.compile_unit_prod_name; - print_addr oc !debug_stmt_list + print_string oc "DW_AT_comp_dir" tag.compile_unit_dir; + print_addr oc "DW_AT_low_pc" tag.compile_unit_low_pc; + print_addr oc "DW_AT_high_pc" tag.compile_unit_high_pc; + print_uleb128 oc "DW_AT_language" 1; + print_string oc "DW_AT_name" tag.compile_unit_name; + print_string oc "DW_AT_producer" tag.compile_unit_prod_name; + print_addr oc "DW_AT_stmt_list" !debug_stmt_list let print_const_type oc ct = - print_ref oc ct.const_type + print_ref oc "DW_AT_type" ct.const_type let print_enumeration_type oc et = print_file_loc oc et.enumeration_file_loc; - print_uleb128 oc et.enumeration_byte_size; - print_opt_value oc et.enumeration_declaration print_flag; - print_string oc et.enumeration_name + print_uleb128 oc "DW_AT_byte_size" et.enumeration_byte_size; + print_opt_value oc "DW_AT_declaration" et.enumeration_declaration print_flag; + print_string oc "DW_AT_name" et.enumeration_name let print_enumerator oc en = - print_sleb128 oc en.enumerator_value; - print_string oc en.enumerator_name + print_sleb128 oc "DW_AT_const_value" en.enumerator_value; + print_string oc "DW_AT_name" en.enumerator_name let print_formal_parameter oc fp = - print_opt_value oc fp.formal_parameter_artificial print_flag; - print_opt_value oc fp.formal_parameter_name print_string; - print_ref oc fp.formal_parameter_type; - print_opt_value oc fp.formal_parameter_variable_parameter print_flag; - print_opt_value oc fp.formal_parameter_location print_loc + print_opt_value oc "DW_AT_artificial" fp.formal_parameter_artificial print_flag; + print_opt_value oc "DW_AT_name" fp.formal_parameter_name print_string; + print_ref oc "DW_AT_type" fp.formal_parameter_type; + print_opt_value oc "DW_AT_variable_parameter" fp.formal_parameter_variable_parameter print_flag; + print_opt_value oc "DW_AT_location" fp.formal_parameter_location print_loc let print_tag_label oc tl = - print_ref oc tl.label_low_pc; - print_string oc tl.label_name + print_ref oc "DW_AT_low_pc" tl.label_low_pc; + print_string oc "DW_AT_name" tl.label_name let print_lexical_block oc lb = - print_opt_value oc lb.lexical_block_high_pc print_addr; - print_opt_value oc lb.lexical_block_low_pc print_addr + print_opt_value oc "DW_AT_high_pc" lb.lexical_block_high_pc print_addr; + print_opt_value oc "DW_AT_low_pc" lb.lexical_block_low_pc print_addr let print_member oc mb = - print_opt_value oc mb.member_byte_size print_byte; - print_opt_value oc mb.member_bit_offset print_byte; - print_opt_value oc mb.member_bit_size print_byte; - print_opt_value oc mb.member_declaration print_flag; - print_string oc mb.member_name; - print_ref oc mb.member_type; - print_opt_value oc mb.member_data_member_location print_data_location + print_opt_value oc "DW_AT_byte_size" mb.member_byte_size print_byte; + print_opt_value oc "DW_AT_bit_offset" mb.member_bit_offset print_byte; + print_opt_value oc "DW_AT_bit_size" mb.member_bit_size print_byte; + print_opt_value oc "DW_AT_declaration" mb.member_declaration print_flag; + print_string oc "DW_AT_name" mb.member_name; + print_ref oc "DW_AT_type" mb.member_type; + print_opt_value oc "DW_AT_data_member_location" mb.member_data_member_location print_data_location let print_pointer oc pt = - print_ref oc pt.pointer_type + print_ref oc "DW_AT_type" pt.pointer_type let print_structure oc st = print_file_loc oc st.structure_file_loc; - print_opt_value oc st.structure_byte_size print_uleb128; - print_opt_value oc st.structure_declaration print_flag; - print_opt_value oc st.structure_name print_string + print_opt_value oc "DW_AT_byte_size" st.structure_byte_size print_uleb128; + print_opt_value oc "DW_AT_declaration" st.structure_declaration print_flag; + print_opt_value oc "DW_AT_name" st.structure_name print_string let print_subprogram_addr oc (s,e) = fprintf oc " .4byte %a\n" label e; @@ -475,45 +481,45 @@ module DwarfPrinter(Target: DWARF_TARGET): let print_subprogram oc sp = print_file_loc oc (Some sp.subprogram_file_loc); - print_opt_value oc sp.subprogram_external print_flag; - print_opt_value oc sp.subprogram_high_pc print_addr; - print_opt_value oc sp.subprogram_low_pc print_addr; - print_string oc sp.subprogram_name; - print_flag oc sp.subprogram_prototyped; - print_opt_value oc sp.subprogram_type print_ref + print_opt_value oc "DW_AT_external" sp.subprogram_external print_flag; + print_opt_value oc "DW_AT_low_pc" sp.subprogram_low_pc print_addr; + print_opt_value oc "DW_AT_high_pc" sp.subprogram_high_pc print_addr; + print_string oc "DW_AT_name" sp.subprogram_name; + print_flag oc "DW_AT_prototyped" sp.subprogram_prototyped; + print_opt_value oc "DW_AT_type" sp.subprogram_type print_ref let print_subrange oc sr = - print_opt_value oc sr.subrange_type print_ref; - print_opt_value oc sr.subrange_upper_bound print_bound_value + print_opt_value oc "DW_AT_type" sr.subrange_type print_ref; + print_opt_value oc "DW_AT_upper_bound" sr.subrange_upper_bound print_bound_value let print_subroutine oc st = - print_opt_value oc st.subroutine_type print_ref; - print_flag oc st.subroutine_prototyped + print_opt_value oc "DW_AT_type" st.subroutine_type print_ref; + print_flag oc "DW_AT_prototyped" st.subroutine_prototyped let print_typedef oc td = print_file_loc oc td.typedef_file_loc; - print_string oc td.typedef_name; - print_ref oc td.typedef_type + print_string oc "DW_AT_name" td.typedef_name; + print_ref oc "DW_AT_type" td.typedef_type let print_union_type oc ut = print_file_loc oc ut.union_file_loc; - print_opt_value oc ut.union_byte_size print_uleb128; - print_opt_value oc ut.union_declaration print_flag; - print_opt_value oc ut.union_name print_string + print_opt_value oc "DW_AT_byte_size" ut.union_byte_size print_uleb128; + print_opt_value oc "DW_AT_declaration" ut.union_declaration print_flag; + print_opt_value oc "DW_AT_name" ut.union_name print_string let print_unspecified_parameter oc up = - print_opt_value oc up.unspecified_parameter_artificial print_flag + print_opt_value oc "DW_AT_artificial" up.unspecified_parameter_artificial print_flag let print_variable oc var = print_file_loc oc (Some var.variable_file_loc); - print_opt_value oc var.variable_declaration print_flag; - print_opt_value oc var.variable_external print_flag; - print_opt_value oc var.variable_location print_loc; - print_string oc var.variable_name; - print_ref oc var.variable_type + print_opt_value oc "DW_AT_declaration" var.variable_declaration print_flag; + print_opt_value oc "DW_AT_external" var.variable_external print_flag; + print_opt_value oc "DW_AT_location" var.variable_location print_loc; + print_string oc "DW_AT_name" var.variable_name; + print_ref oc "DW_AT_type" var.variable_type let print_volatile_type oc vt = - print_ref oc vt.volatile_type + print_ref oc "DW_AT_type" vt.volatile_type (* Print an debug entry *) let print_entry oc entry = @@ -523,11 +529,11 @@ module DwarfPrinter(Target: DWARF_TARGET): | None -> false | Some _ -> true in let id = get_abbrev entry has_sib in - print_sleb128 oc id; + print_sleb128 oc (sprintf "Abbrev [%d] %s" id (string_of_dw_tag entry.tag)) id; (match sib with | None -> () | Some s -> let lbl = entry_to_label s in - fprintf oc " .4byte %a-%a\n" label lbl label !debug_start_addr); + fprintf oc " .4byte %a-%a%a\n" label lbl label !debug_start_addr print_comment "DW_AT_sibling"); begin match entry.tag with | DW_TAG_array_type arr_type -> print_array_type oc arr_type @@ -552,7 +558,7 @@ module DwarfPrinter(Target: DWARF_TARGET): | DW_TAG_volatile_type vt -> print_volatile_type oc vt end) (fun e -> if e.children <> [] then - print_sleb128 oc 0) entry + print_sleb128 oc "End Of Children Mark" 0) entry (* Print the debug info section *) let print_debug_info oc start line_start entry = @@ -562,13 +568,13 @@ module DwarfPrinter(Target: DWARF_TARGET): print_label oc start; let debug_length_start = new_label () (* Address used for length calculation *) and debug_end = new_label () in - fprintf oc " .4byte %a-%a\n" label debug_end label debug_length_start; + fprintf oc " .4byte %a-%a%a\n" label debug_end label debug_length_start print_comment "Length of Unit"; print_label oc debug_length_start; - fprintf oc " .2byte 0x2\n"; (* Dwarf version *) - print_addr oc !abbrev_start_addr; (* Offset into the abbreviation *) - print_byte oc !Machine.config.Machine.sizeof_ptr; (* Sizeof pointer type *) + fprintf oc " .2byte 0x2%a\n" print_comment "DWARF version number"; (* Dwarf version *) + print_addr oc "Offset Into Abbrev. Section" !abbrev_start_addr; (* Offset into the abbreviation *) + print_byte oc "Address Size (in bytes)" !Machine.config.Machine.sizeof_ptr; (* Sizeof pointer type *) print_entry oc entry; - print_sleb128 oc 0; + print_sleb128 oc "" 0; print_label oc debug_end (* End of the debug section *) let print_location_entry oc c_low l = diff --git a/debug/DwarfTypes.mli b/debug/DwarfTypes.mli index 7048d8d3..fb1725d9 100644 --- a/debug/DwarfTypes.mli +++ b/debug/DwarfTypes.mli @@ -60,12 +60,35 @@ type string_const = | Simple_string of string | Offset_string of reference -(* Types representing the attribute information per tag value *) - type file_loc = | Diab_file_loc of constant * constant | Gnu_file_loc of constant * constant +type dw_form = + | DW_FORM_addr + | DW_FORM_block2 + | DW_FORM_block4 + | DW_FORM_data2 + | DW_FORM_data4 + | DW_FORM_data8 + | DW_FORM_string + | DW_FORM_block + | DW_FORM_block1 + | DW_FORM_data1 + | DW_FORM_flag + | DW_FORM_sdata + | DW_FORM_strp + | DW_FORM_udata + | DW_FORM_ref_addr + | DW_FORM_ref1 + | DW_FORM_ref2 + | DW_FORM_ref4 + | DW_FORM_ref8 + | DW_FORM_ref_udata + | DW_FORM_ref_indirect + +(* Types representing the attribute information per tag value *) + type dw_tag_array_type = { array_type: reference; @@ -273,4 +296,5 @@ module type DWARF_TARGET= val label: out_channel -> int -> unit val section: out_channel -> section_name -> unit val symbol: out_channel -> atom -> unit + val comment: string end diff --git a/debug/DwarfUtil.ml b/debug/DwarfUtil.ml index 16e446ee..3e252dd2 100644 --- a/debug/DwarfUtil.ml +++ b/debug/DwarfUtil.ml @@ -53,6 +53,30 @@ let rec entry_fold f acc entry = let acc = f acc entry.tag in List.fold_left (entry_fold f) acc entry.children +(* Return the code and the corresponding comment for a DW_FORM *) +let code_of_dw_form = function + | DW_FORM_addr -> 0x01,"DW_FORM_addr" + | DW_FORM_block2 -> 0x03,"DW_FORM_block2" + | DW_FORM_block4 -> 0x04,"DW_FORM_block4" + | DW_FORM_data2 -> 0x05,"DW_FORM_data2" + | DW_FORM_data4 -> 0x06,"DW_FORM_data4" + | DW_FORM_data8 -> 0x07,"DW_FORM_data8" + | DW_FORM_string -> 0x08,"DW_FORM_string" + | DW_FORM_block -> 0x09,"DW_FORM_block" + | DW_FORM_block1 -> 0x0a,"DW_FORM_block1" + | DW_FORM_data1 -> 0x0b,"DW_FORM_data1" + | DW_FORM_flag -> 0x0c,"DW_FORM_flag" + | DW_FORM_sdata -> 0x0d,"DW_FORM_sdata" + | DW_FORM_strp -> 0x0e,"DW_FORM_strp" + | DW_FORM_udata -> 0x0f,"DW_FORM_udata" + | DW_FORM_ref_addr -> 0x10,"DW_FORM_ref_addr" + | DW_FORM_ref1 -> 0x11,"DW_FORM_ref1" + | DW_FORM_ref2 -> 0x12,"DW_FORM_ref2" + | DW_FORM_ref4 -> 0x13,"DW_FORM_ref4" + | DW_FORM_ref8 -> 0x14,"DW_FORM_ref8" + | DW_FORM_ref_udata -> 0x15,"DW_FORM_ref_udata" + | DW_FORM_ref_indirect -> 0x16,"DW_FORM_ref_indirect" + (* Attribute form encoding *) let dw_form_addr = 0x01 let dw_form_block2 = 0x03 @@ -84,35 +108,28 @@ let dw_op_regx = 0x90 let dw_op_bregx = 0x92 let dw_op_piece = 0x93 - -(* Default corresponding encoding for the different abbreviations *) -let sibling_type_abbr = dw_form_ref4 -let file_loc_type_abbr = dw_form_data4,dw_form_udata -let type_abbr = dw_form_ref_addr -let name_type_abbr = dw_form_string -let encoding_type_abbr = dw_form_data1 -let byte_size_type_abbr = dw_form_data1 -let member_size_abbr = dw_form_udata -let high_pc_type_abbr = dw_form_addr -let low_pc_type_abbr = dw_form_addr -let stmt_list_type_abbr = dw_form_data4 -let declaration_type_abbr = dw_form_flag -let external_type_abbr = dw_form_flag -let prototyped_type_abbr = dw_form_flag -let bit_offset_type_abbr = dw_form_data1 -let comp_dir_type_abbr = dw_form_string -let language_type_abbr = dw_form_udata -let producer_type_abbr = dw_form_string -let value_type_abbr = dw_form_sdata -let artificial_type_abbr = dw_form_flag -let variable_parameter_type_abbr = dw_form_flag -let bit_size_type_abbr = dw_form_data1 -let location_ref_type_abbr = dw_form_data4 -let location_block_type_abbr = dw_form_block -let data_location_block_type_abbr = dw_form_block -let data_location_ref_type_abbr = dw_form_ref4 -let bound_const_type_abbr = dw_form_udata -let bound_ref_type_abbr=dw_form_ref4 +(* Tag to string function *) +let string_of_dw_tag = function + | DW_TAG_array_type _ -> "DW_TAG_array_type" + | DW_TAG_compile_unit _ -> "DW_TAG_compile_unit" + | DW_TAG_base_type _ -> "DW_TAG_base_type" + | DW_TAG_const_type _ -> "DW_TAG_const_type" + | DW_TAG_enumeration_type _ -> "DW_TAG_enumeration_type" + | DW_TAG_enumerator _ -> "DW_TAG_enumerator" + | DW_TAG_formal_parameter _ -> "DW_TAG_formal_parameter" + | DW_TAG_label _ -> "DW_TAG_label" + | DW_TAG_lexical_block _ -> "DW_TAG_lexical_block" + | DW_TAG_member _ -> "DW_TAG_member" + | DW_TAG_pointer_type _ -> "DW_TAG_pointer_type" + | DW_TAG_structure_type _ -> "DW_TAG_structure_type" + | DW_TAG_subprogram _ -> "DW_TAG_subprogram" + | DW_TAG_subrange_type _ -> "DW_TAG_subrange_type" + | DW_TAG_subroutine_type _ -> "DW_TAG_subroutine_type" + | DW_TAG_typedef _ -> "DW_TAG_typedef" + | DW_TAG_union_type _ -> "DW_TAG_union_type" + | DW_TAG_unspecified_parameter _ -> "DW_TAG_unspecified_parameter" + | DW_TAG_variable _ -> "DW_TAG_variable" + | DW_TAG_volatile_type _ -> "DW_TAG_volatile_type" (* Sizeof functions for the encoding of uleb128 and sleb128 *) let sizeof_uleb128 value = -- cgit From 1e52bb2001964d87086cea00d0cb779e270b99ce Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Thu, 15 Oct 2015 13:15:28 +0200 Subject: First step to implemente address ranges for the gnu backend. In contrast to the dcc, the gcc uses address ranges to express non-contiguous range of addresses. As a first step we set the start and end addresses for the different address ranges for the compilation unit by using the start and end addresses of functions. Bug 17392. --- debug/Debug.ml | 16 +++++-------- debug/Debug.mli | 12 ++++------ debug/DebugInformation.ml | 12 +++++++++- debug/DebugInit.ml | 17 +++++++------- debug/DwarfPrinter.ml | 57 ++++++++++++++++++++++++++++------------------- debug/DwarfTypes.mli | 14 +++++++----- debug/Dwarfgen.ml | 43 +++++++++++++++++++---------------- 7 files changed, 95 insertions(+), 76 deletions(-) (limited to 'debug') diff --git a/debug/Debug.ml b/debug/Debug.ml index 14176d3b..87d04ad7 100644 --- a/debug/Debug.ml +++ b/debug/Debug.ml @@ -29,7 +29,7 @@ type implem = set_member_offset: ident -> string -> int -> unit; set_bitfield_offset: ident -> string -> int -> string -> int -> unit; insert_global_declaration: Env.t -> globdecl -> unit; - add_fun_addr: atom -> (int * int) -> unit; + add_fun_addr: atom -> section_name -> (int * int) -> unit; generate_debug_info: (atom -> string) -> string -> debug_entries option; all_files_iter: (string -> unit) -> unit; insert_local_declaration: storage -> ident -> typ -> location -> unit; @@ -44,14 +44,12 @@ type implem = stack_variable: (atom * atom) -> int * int builtin_arg -> unit; add_label: atom -> positive -> int -> unit; atom_parameter: ident -> ident -> atom -> unit; - add_compilation_section_start: section_name -> int -> unit; - add_compilation_section_end: section_name -> int -> unit; compute_diab_file_enum: (section_name -> int) -> (string-> int) -> (unit -> unit) -> unit; compute_gnu_file_enum: (string -> unit) -> unit; exists_section: section_name -> bool; remove_unused: ident -> unit; variable_printed: string -> unit; - add_diab_info: section_name -> int -> int -> unit; + add_diab_info: section_name -> int -> int -> int -> unit; } let default_implem = @@ -62,7 +60,7 @@ let default_implem = set_member_offset = (fun _ _ _ -> ()); set_bitfield_offset = (fun _ _ _ _ _ -> ()); insert_global_declaration = (fun _ _ -> ()); - add_fun_addr = (fun _ _ -> ()); + add_fun_addr = (fun _ _ _ -> ()); generate_debug_info = (fun _ _ -> None); all_files_iter = (fun _ -> ()); insert_local_declaration = (fun _ _ _ _ -> ()); @@ -77,14 +75,12 @@ let default_implem = stack_variable = (fun _ _ -> ()); add_label = (fun _ _ _ -> ()); atom_parameter = (fun _ _ _ -> ()); - add_compilation_section_start = (fun _ _ -> ()); - add_compilation_section_end = (fun _ _ -> ()); compute_diab_file_enum = (fun _ _ _ -> ()); compute_gnu_file_enum = (fun _ -> ()); exists_section = (fun _ -> true); remove_unused = (fun _ -> ()); variable_printed = (fun _ -> ()); - add_diab_info = (fun _ _ _ -> ()); + add_diab_info = (fun _ _ _ _ -> ()); } let implem = ref default_implem @@ -110,11 +106,9 @@ let end_live_range atom lbl = !implem.end_live_range atom lbl let stack_variable atom loc = !implem.stack_variable atom loc let add_label atom p lbl = !implem.add_label atom p lbl let atom_parameter fid pid atom = !implem.atom_parameter fid pid atom -let add_compilation_section_start sec addr = !implem.add_compilation_section_start sec addr -let add_compilation_section_end sec addr = !implem.add_compilation_section_end sec addr let exists_section sec = !implem.exists_section sec let compute_diab_file_enum end_l entry_l line_e = !implem.compute_diab_file_enum end_l entry_l line_e let compute_gnu_file_enum f = !implem.compute_gnu_file_enum f let remove_unused ident = !implem.remove_unused ident let variable_printed ident = !implem.variable_printed ident -let add_diab_info sec addr = !implem.add_diab_info sec addr +let add_diab_info sec line_start debug_info low_pc = !implem.add_diab_info sec line_start debug_info low_pc diff --git a/debug/Debug.mli b/debug/Debug.mli index 83d5703b..1585e7e4 100644 --- a/debug/Debug.mli +++ b/debug/Debug.mli @@ -27,7 +27,7 @@ type implem = set_member_offset: ident -> string -> int -> unit; set_bitfield_offset: ident -> string -> int -> string -> int -> unit; insert_global_declaration: Env.t -> globdecl -> unit; - add_fun_addr: atom -> (int * int) -> unit; + add_fun_addr: atom -> section_name -> (int * int) -> unit; generate_debug_info: (atom -> string) -> string -> debug_entries option; all_files_iter: (string -> unit) -> unit; insert_local_declaration: storage -> ident -> typ -> location -> unit; @@ -42,14 +42,12 @@ type implem = stack_variable: (atom * atom) -> int * int builtin_arg -> unit; add_label: atom -> positive -> int -> unit; atom_parameter: ident -> ident -> atom -> unit; - add_compilation_section_start: section_name -> int -> unit; - add_compilation_section_end: section_name -> int -> unit; compute_diab_file_enum: (section_name -> int) -> (string-> int) -> (unit -> unit) -> unit; compute_gnu_file_enum: (string -> unit) -> unit; exists_section: section_name -> bool; remove_unused: ident -> unit; variable_printed: string -> unit; - add_diab_info: section_name -> int -> int -> unit; + add_diab_info: section_name -> int -> int -> int -> unit; } val default_implem: implem @@ -62,7 +60,7 @@ val set_composite_size: ident -> struct_or_union -> int option -> unit val set_member_offset: ident -> string -> int -> unit val set_bitfield_offset: ident -> string -> int -> string -> int -> unit val insert_global_declaration: Env.t -> globdecl -> unit -val add_fun_addr: atom -> (int * int) -> unit +val add_fun_addr: atom -> section_name -> (int * int) -> unit val all_files_iter: (string -> unit) -> unit val insert_local_declaration: storage -> ident -> typ -> location -> unit val atom_local_variable: ident -> atom -> unit @@ -77,11 +75,9 @@ val stack_variable: (atom * atom) -> int * int builtin_arg -> unit val add_label: atom -> positive -> int -> unit val generate_debug_info: (atom -> string) -> string -> debug_entries option val atom_parameter: ident -> ident -> atom -> unit -val add_compilation_section_start: section_name -> int -> unit -val add_compilation_section_end: section_name -> int -> unit val compute_diab_file_enum: (section_name -> int) -> (string-> int) -> (unit -> unit) -> unit val compute_gnu_file_enum: (string -> unit) -> unit val exists_section: section_name -> bool val remove_unused: ident -> unit val variable_printed: string -> unit -val add_diab_info: section_name -> int -> int -> unit +val add_diab_info: section_name -> int -> int -> int -> unit diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index 95f34b1d..51fbfde9 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -593,10 +593,20 @@ let add_compilation_section_end sec addr = let sec = section_to_string sec in Hashtbl.add compilation_section_end sec addr -let add_diab_info sec addr1 add2 = +let add_diab_info sec addr1 add2 addr3 = let sec' = section_to_string sec in + Hashtbl.add compilation_section_start sec' addr3; Hashtbl.add diab_additional sec' (addr1,add2,sec) +let diab_add_fun_addr name _ addr = add_fun_addr name addr + +let gnu_add_fun_addr name sec (high,low) = + let sec = section_to_string sec in + if not (Hashtbl.mem compilation_section_start sec) then + Hashtbl.add compilation_section_start sec low; + Hashtbl.replace compilation_section_end sec high; + add_fun_addr name (high,low) + let exists_section sec = Hashtbl.mem compilation_section_start (section_to_string sec) diff --git a/debug/DebugInit.ml b/debug/DebugInit.ml index 209f2024..b4240af7 100644 --- a/debug/DebugInit.ml +++ b/debug/DebugInit.ml @@ -26,7 +26,7 @@ let default_debug = set_member_offset = DebugInformation.set_member_offset; set_bitfield_offset = DebugInformation.set_bitfield_offset; insert_global_declaration = DebugInformation.insert_global_declaration; - add_fun_addr = DebugInformation.add_fun_addr; + add_fun_addr = (fun _ _ _ -> ()); generate_debug_info = (fun _ _ -> None); all_files_iter = (fun f -> DebugInformation.StringSet.iter f !DebugInformation.all_files); insert_local_declaration = DebugInformation.insert_local_declaration; @@ -41,23 +41,24 @@ let default_debug = stack_variable = DebugInformation.stack_variable; add_label = DebugInformation.add_label; atom_parameter = DebugInformation.atom_parameter; - add_compilation_section_start = DebugInformation.add_compilation_section_start; - add_compilation_section_end = DebugInformation.add_compilation_section_end; compute_diab_file_enum = DebugInformation.compute_diab_file_enum; compute_gnu_file_enum = DebugInformation.compute_gnu_file_enum; exists_section = DebugInformation.exists_section; remove_unused = DebugInformation.remove_unused; variable_printed = DebugInformation.variable_printed; - add_diab_info = DebugInformation.add_diab_info; + add_diab_info = (fun _ _ _ _ -> ()); } let init_debug () = - let gen = + implem := if Configuration.system = "diab" then - (fun a b -> Some (Dwarfgen.gen_diab_debug_info a b)) + let gen = (fun a b -> Some (Dwarfgen.gen_diab_debug_info a b)) in + {default_debug with generate_debug_info = gen; + add_diab_info = DebugInformation.add_diab_info; + add_fun_addr = DebugInformation.diab_add_fun_addr;} else - (fun a b -> Some (Dwarfgen.gen_gnu_debug_info a b)) in - implem := {default_debug with generate_debug_info = gen;} + {default_debug with generate_debug_info = (fun a b -> Some (Dwarfgen.gen_gnu_debug_info a b)); + add_fun_addr = DebugInformation.gnu_add_fun_addr} let init_none () = implem := default_implem diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index abed6a91..afa4799e 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -91,7 +91,13 @@ module DwarfPrinter(Target: DWARF_TARGET): | Some (LocSymbol _) | Some (LocSimple _) -> add_abbr_entry (0x2,"DW_AT_location",DW_FORM_block) buf - + let add_range buf = function + | Pc_pair _ -> + add_abbr_entry (0x11,"DW_AT_low_pc",DW_FORM_addr) buf; + add_abbr_entry (0x12,"DW_AT_high_pc",DW_FORM_addr) buf + | Offset _ -> + add_abbr_entry (0x55,"DW_AT_ranges",DW_FORM_data4) buf + | Empty -> () (* Dwarf entity to string function *) let abbrev_string_of_entity entity has_sibling = @@ -120,8 +126,7 @@ module DwarfPrinter(Target: DWARF_TARGET): | DW_TAG_compile_unit e -> prologue 0x11 "DW_TAG_compile_unit"; add_string buf 0x1b "DW_AT_comp_dir" e.compile_unit_dir; - add_low_pc buf; - add_high_pc buf; + add_range buf e.compile_unit_range; add_abbr_entry (0x13,"DW_AT_language",DW_FORM_udata) buf; add_name buf e.compile_unit_name; add_string buf 0x25 "DW_AT_producer" e.compile_unit_prod_name; @@ -152,8 +157,7 @@ module DwarfPrinter(Target: DWARF_TARGET): add_name buf e.label_name; | DW_TAG_lexical_block a -> prologue 0xb "DW_TAG_lexical_block"; - add_attr_some a.lexical_block_high_pc add_high_pc; - add_attr_some a.lexical_block_low_pc add_low_pc + add_range buf a.lexical_block_range; | DW_TAG_member e -> prologue 0xd "DW_TAG_member"; add_attr_some e.member_byte_size add_byte_size; @@ -179,8 +183,7 @@ module DwarfPrinter(Target: DWARF_TARGET): prologue 0x2e "DW_TAG_subprogram"; add_file_loc buf; add_attr_some e.subprogram_external (add_abbr_entry (0x3f,"DW_AT_external",DW_FORM_flag)); - add_attr_some e.subprogram_low_pc add_low_pc; - add_attr_some e.subprogram_high_pc add_high_pc; + add_range buf e.subprogram_range; add_name buf e.subprogram_name; add_abbr_entry (0x27,"DW_AT_prototyped",DW_FORM_flag) buf; add_attr_some e.subprogram_type add_type; @@ -418,10 +421,15 @@ module DwarfPrinter(Target: DWARF_TARGET): | None -> ()); print_string oc "DW_AT_name" bt.base_type_name + let print_range oc = function + | Pc_pair (l,h) -> + print_addr oc "DW_AT_low_pc" l; + print_addr oc "DW_AT_high_pc" h + | _ -> () + let print_compilation_unit oc tag = print_string oc "DW_AT_comp_dir" tag.compile_unit_dir; - print_addr oc "DW_AT_low_pc" tag.compile_unit_low_pc; - print_addr oc "DW_AT_high_pc" tag.compile_unit_high_pc; + print_range oc tag.compile_unit_range; print_uleb128 oc "DW_AT_language" 1; print_string oc "DW_AT_name" tag.compile_unit_name; print_string oc "DW_AT_producer" tag.compile_unit_prod_name; @@ -453,8 +461,7 @@ module DwarfPrinter(Target: DWARF_TARGET): let print_lexical_block oc lb = - print_opt_value oc "DW_AT_high_pc" lb.lexical_block_high_pc print_addr; - print_opt_value oc "DW_AT_low_pc" lb.lexical_block_low_pc print_addr + print_range oc lb.lexical_block_range let print_member oc mb = print_opt_value oc "DW_AT_byte_size" mb.member_byte_size print_byte; @@ -475,15 +482,11 @@ module DwarfPrinter(Target: DWARF_TARGET): print_opt_value oc "DW_AT_declaration" st.structure_declaration print_flag; print_opt_value oc "DW_AT_name" st.structure_name print_string - let print_subprogram_addr oc (s,e) = - fprintf oc " .4byte %a\n" label e; - fprintf oc " .4byte %a\n" label s let print_subprogram oc sp = print_file_loc oc (Some sp.subprogram_file_loc); print_opt_value oc "DW_AT_external" sp.subprogram_external print_flag; - print_opt_value oc "DW_AT_low_pc" sp.subprogram_low_pc print_addr; - print_opt_value oc "DW_AT_high_pc" sp.subprogram_high_pc print_addr; + print_range oc sp.subprogram_range; print_string oc "DW_AT_name" sp.subprogram_name; print_flag oc "DW_AT_prototyped" sp.subprogram_prototyped; print_opt_value oc "DW_AT_type" sp.subprogram_type print_ref @@ -602,6 +605,11 @@ module DwarfPrinter(Target: DWARF_TARGET): | None -> print_location_entry_abs oc in List.iter f l + let list_opt l f = + match l with + | [] -> () + | _ -> f () + let print_diab_entries oc entries = let abbrev_start = new_label () in abbrev_start_addr := abbrev_start; @@ -614,7 +622,8 @@ module DwarfPrinter(Target: DWARF_TARGET): section oc Section_debug_loc; List.iter (fun e -> print_location_list oc e.locs) entries - let print_gnu_entries oc cp loc s = + + let print_gnu_entries oc cp (lpc,loc) s = compute_abbrev cp; let line_start = new_label () and start = new_label () @@ -623,14 +632,16 @@ module DwarfPrinter(Target: DWARF_TARGET): section oc (Section_debug_info None); print_debug_info oc start line_start cp; print_abbrev oc; - section oc Section_debug_loc; - print_location_list oc loc; + list_opt loc (fun () -> + section oc Section_debug_loc; + print_location_list oc (lpc,loc)); section oc (Section_debug_line None); print_label oc line_start; - section oc Section_debug_str; - List.iter (fun (id,s) -> - print_label oc (loc_to_label id); - fprintf oc " .asciz \"%s\"\n" s) s + list_opt s (fun () -> + section oc Section_debug_str; + List.iter (fun (id,s) -> + print_label oc (loc_to_label id); + fprintf oc " .asciz \"%s\"\n" s) s) (* Print the debug info and abbrev section *) diff --git a/debug/DwarfTypes.mli b/debug/DwarfTypes.mli index fb1725d9..ff895623 100644 --- a/debug/DwarfTypes.mli +++ b/debug/DwarfTypes.mli @@ -87,6 +87,11 @@ type dw_form = | DW_FORM_ref_udata | DW_FORM_ref_indirect +type dw_range = + | Pc_pair of reference * reference (* Simple low,high pc *) + | Offset of reference * constant (* DWARF 3 version for different range *) + | Empty (* Needed for compilation units only containing variables *) + (* Types representing the attribute information per tag value *) type dw_tag_array_type = @@ -104,8 +109,7 @@ type dw_tag_base_type = type dw_tag_compile_unit = { compile_unit_name: string_const; - compile_unit_low_pc: constant; - compile_unit_high_pc: constant; + compile_unit_range: dw_range; compile_unit_dir: string_const; compile_unit_prod_name: string_const; } @@ -146,8 +150,7 @@ type dw_tag_label = type dw_tag_lexical_block = { - lexical_block_high_pc: address option; - lexical_block_low_pc: address option; + lexical_block_range: dw_range; } type dw_tag_member = @@ -181,8 +184,7 @@ type dw_tag_subprogram = subprogram_name: string_const; subprogram_prototyped: flag; subprogram_type: reference option; - subprogram_high_pc: reference option; - subprogram_low_pc: reference option; + subprogram_range: dw_range; } type dw_tag_subrange_type = diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml index 1ef3938a..980c8a34 100644 --- a/debug/Dwarfgen.ml +++ b/debug/Dwarfgen.ml @@ -386,21 +386,23 @@ module Dwarfgenaux (Target: TARGET) = Some (new_entry id (DW_TAG_variable var)),(IntSet.add v.lvar_type acc,loc_list@bcc) and scope_to_entry f_id acc sc id = - let l_pc,h_pc = try + let r = try let r = Hashtbl.find scope_ranges id in - let lbl l = match l with - | Some l -> Some (Hashtbl.find label_translation (f_id,l)) - | None -> None 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 - | [] -> None,None - | [a] -> lbl a.start_addr, lbl a.end_addr - | a::rest -> lbl (List.hd (List.rev rest)).start_addr,lbl a.end_addr + | [] -> 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 -> None,None in + with Not_found -> Empty in let scope = { - lexical_block_high_pc = h_pc; - lexical_block_low_pc = l_pc; + 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 @@ -423,14 +425,16 @@ module Dwarfgenaux (Target: TARGET) = | _ -> assert false) let function_to_entry (acc,bcc) id f = + let r = match f.fun_low_pc, f.fun_high_pc with + | Some l,Some h -> Pc_pair (l,h) + | _ -> Empty in let f_tag = { subprogram_file_loc = file_loc f.fun_file_loc; subprogram_external = Some f.fun_external; subprogram_name = string_entry f.fun_name; subprogram_prototyped = true; subprogram_type = f.fun_return_type; - subprogram_high_pc = f.fun_high_pc; - subprogram_low_pc = f.fun_low_pc; + 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 @@ -473,8 +477,7 @@ let diab_gen_compilation_section s defs acc = and high_pc = Hashtbl.find compilation_section_end s in let cp = { compile_unit_name = Simple_string !file_name; - compile_unit_low_pc = low_pc; - compile_unit_high_pc = high_pc; + compile_unit_range = Pc_pair (low_pc,high_pc); compile_unit_dir = Simple_string (Sys.getcwd ()); compile_unit_prod_name = Simple_string prod_name } in @@ -515,8 +518,11 @@ let gnu_string_entry s = Offset_string id let gen_gnu_debug_info sec_name var_section : debug_entries = - let low_pc = Hashtbl.find compilation_section_start ".text" - and high_pc = Hashtbl.find compilation_section_end ".text" in + 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 module Gen = Dwarfgenaux (struct let file_loc = gnu_file_loc let string_entry = gnu_string_entry @@ -530,13 +536,12 @@ let gen_gnu_debug_info sec_name var_section : debug_entries = let types = Gen.gen_types ty in let cp = { compile_unit_name = gnu_string_entry !file_name; - compile_unit_low_pc = low_pc; - compile_unit_high_pc = high_pc; + compile_unit_range = r; compile_unit_dir = gnu_string_entry (Sys.getcwd ()); compile_unit_prod_name = gnu_string_entry prod_name; } in let cp = new_entry (next_id ()) (DW_TAG_compile_unit cp) in let cp = add_children cp (types@defs) in - let loc_pc = if StringSet.cardinal sec > 1 then None else Some low_pc 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) -- cgit From 24b4159b6a29328c529e0e59405e03ea192aa99e Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Fri, 16 Oct 2015 13:06:09 +0200 Subject: 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. --- debug/DebugInit.ml | 1 + debug/DwarfPrinter.ml | 27 ++++++++-- debug/DwarfTypes.mli | 12 +++-- debug/Dwarfgen.ml | 146 +++++++++++++++++++++++++++++++++----------------- 4 files changed, 127 insertions(+), 59 deletions(-) (limited to 'debug') diff --git a/debug/DebugInit.ml b/debug/DebugInit.ml index b4240af7..455112ed 100644 --- a/debug/DebugInit.ml +++ b/debug/DebugInit.ml @@ -53,6 +53,7 @@ let init_debug () = implem := if Configuration.system = "diab" then let gen = (fun a b -> Some (Dwarfgen.gen_diab_debug_info a b)) in + Clflags.option_gdwarf := 2; (* Dwarf 2 is the only supported target *) {default_debug with generate_debug_info = gen; add_diab_info = DebugInformation.add_diab_info; add_fun_addr = DebugInformation.diab_add_fun_addr;} diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index afa4799e..3e85ecfc 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -272,6 +272,8 @@ module DwarfPrinter(Target: DWARF_TARGET): let debug_stmt_list = ref (-1) + let debug_ranges_addr = ref (-1) + let entry_labels: (int,int) Hashtbl.t = Hashtbl.create 7 (* Translate the ids to address labels *) @@ -425,6 +427,8 @@ 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" | _ -> () let print_compilation_unit oc tag = @@ -573,7 +577,7 @@ module DwarfPrinter(Target: DWARF_TARGET): and debug_end = new_label () in fprintf oc " .4byte %a-%a%a\n" label debug_end label debug_length_start print_comment "Length of Unit"; print_label oc debug_length_start; - fprintf oc " .2byte 0x2%a\n" print_comment "DWARF version number"; (* Dwarf version *) + fprintf oc " .2byte 0x%d%a\n" !Clflags.option_gdwarf print_comment "DWARF version number"; (* Dwarf version *) print_addr oc "Offset Into Abbrev. Section" !abbrev_start_addr; (* Offset into the abbreviation *) print_byte oc "Address Size (in bytes)" !Machine.config.Machine.sizeof_ptr; (* Sizeof pointer type *) print_entry oc entry; @@ -622,12 +626,23 @@ module DwarfPrinter(Target: DWARF_TARGET): section oc Section_debug_loc; List.iter (fun e -> print_location_list oc e.locs) entries - - let print_gnu_entries oc cp (lpc,loc) s = + let print_ranges oc r = + section oc Section_debug_ranges; + print_label oc !debug_ranges_addr; + List.iter (fun l -> + List.iter (fun (b,e) -> + fprintf oc " .4byte %a\n" label b; + fprintf oc " .4byte %a\n" label e) l; + fprintf oc " .4byte 0\n"; + fprintf oc " .4byte 0\n") r + + let print_gnu_entries oc cp (lpc,loc) s r = compute_abbrev cp; let line_start = new_label () and start = new_label () - and abbrev_start = new_label () in + and abbrev_start = new_label () + and range_label = new_label () in + debug_ranges_addr := range_label; abbrev_start_addr := abbrev_start; section oc (Section_debug_info None); print_debug_info oc start line_start cp; @@ -635,6 +650,8 @@ module DwarfPrinter(Target: DWARF_TARGET): list_opt loc (fun () -> section oc Section_debug_loc; print_location_list oc (lpc,loc)); + list_opt r (fun () -> + print_ranges oc r); section oc (Section_debug_line None); print_label oc line_start; list_opt s (fun () -> @@ -647,6 +664,6 @@ module DwarfPrinter(Target: DWARF_TARGET): (* Print the debug info and abbrev section *) let print_debug oc = function | Diab entries -> print_diab_entries oc entries - | Gnu (cp,loc,s) -> print_gnu_entries oc cp loc s + | Gnu (cp,loc,s,r) -> print_gnu_entries oc cp loc s r end diff --git a/debug/DwarfTypes.mli b/debug/DwarfTypes.mli index ff895623..a4c75201 100644 --- a/debug/DwarfTypes.mli +++ b/debug/DwarfTypes.mli @@ -89,7 +89,7 @@ type dw_form = type dw_range = | Pc_pair of reference * reference (* Simple low,high pc *) - | Offset of reference * constant (* DWARF 3 version for different range *) + | Offset of constant (* DWARF 3 version for different range *) | Empty (* Needed for compilation units only containing variables *) (* Types representing the attribute information per tag value *) @@ -273,6 +273,12 @@ type location_entry = } type dw_locations = constant option * location_entry list +type range_entry = (address * address) list + +type dw_ranges = range_entry list + +type dw_string = (int * string) list + type diab_entry = { section_name: string; @@ -284,9 +290,7 @@ type diab_entry = type diab_entries = diab_entry list -type dw_string = (int * string) list - -type gnu_entries = dw_entry * dw_locations * dw_string +type gnu_entries = dw_entry * dw_locations * dw_string * dw_ranges type debug_entries = | Diab of diab_entries 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) -- cgit