From 8d2e4a51d56b7f4d3673a5132edd1adb37a14295 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Fri, 21 Aug 2015 15:21:36 +0200 Subject: Added symbol functions for printing of the location for global variables. --- debug/CtoDwarf.ml | 13 +++++-------- debug/DwarfPrinter.ml | 20 ++++++++++---------- debug/DwarfTypes.mli | 15 +++++++++------ 3 files changed, 24 insertions(+), 24 deletions(-) (limited to 'debug') diff --git a/debug/CtoDwarf.ml b/debug/CtoDwarf.ml index 99b77e6f..ee594d9e 100644 --- a/debug/CtoDwarf.ml +++ b/debug/CtoDwarf.ml @@ -164,15 +164,14 @@ and fun_to_dwarf_tag rt args = false,[u],[] | Some [] -> true,[],[] | Some l -> - let c,e = mmap (fun acc (_,t) -> + let c,e = mmap (fun acc (i,t) -> let t,e = type_to_dwarf t in let fp = { + formal_parameter_id = i.stamp; formal_parameter_file_loc = None; formal_parameter_artificial = None; - formal_parameter_location = None; formal_parameter_name = None; - formal_parameter_segment = None; formal_parameter_type = t; formal_parameter_variable_parameter = None; } in @@ -301,12 +300,11 @@ let glob_var_to_dwarf (s,n,t,_) gloc = | Storage_static -> false | _ -> true) in let decl = { + variable_id = n.stamp; variable_file_loc = (Some gloc); variable_declaration = Some at_decl; variable_external = Some ext; - variable_location = if ext then Some (LocSymbol n.name) else None; variable_name = n.name; - variable_segment = None; variable_type = i; } in let decl = new_entry (DW_TAG_variable decl) in @@ -322,9 +320,9 @@ let fundef_to_dwarf f gloc = | Storage_static -> false | _ -> true) in let fdef = { + subprogram_id = f.fd_name.stamp; subprogram_file_loc = (Some gloc); subprogram_external = Some ext; - subprogram_frame_base = None; subprogram_name = f.fd_name.name; subprogram_prototyped = true; subprogram_type = ret; @@ -333,11 +331,10 @@ let fundef_to_dwarf f gloc = let t,e = type_to_dwarf t in let fp = { + formal_parameter_id = p.stamp; formal_parameter_file_loc = None; formal_parameter_artificial = None; - formal_parameter_location = None; formal_parameter_name = (Some p.name); - formal_parameter_segment = None; formal_parameter_type = t; formal_parameter_variable_parameter = None; } in diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index 70b68634..85efea6e 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -128,9 +128,9 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): prologue 0x34; 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_location e.formal_parameter_location buf; + add_location (get_location e.formal_parameter_id) buf; add_attr_some e.formal_parameter_name add_name; - add_location e.formal_parameter_segment buf; + add_location (get_segment_location e.formal_parameter_id) buf; add_type buf; add_attr_some e.formal_parameter_variable_parameter (add_abbr_entry (0x4b,variable_parameter_type_abbr)) | DW_TAG_label _ -> @@ -203,9 +203,9 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): add_attr_some e.variable_file_loc add_file_loc; 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_location (get_location e.variable_id) buf; add_name buf; - add_location e.variable_segment buf; + add_location (get_segment_location e.variable_id) buf; add_type buf | DW_TAG_volatile_type _ -> prologue 0x35; @@ -299,7 +299,7 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): | LocSymbol s -> fprintf oc " .sleb128 5\n"; fprintf oc " .byte 3\n"; - fprintf oc " .4byte %s\n" s + fprintf oc " .4byte %a\n" symbol s | _ -> () let print_data_location oc dl = @@ -365,9 +365,9 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): 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_location print_loc; + print_opt_value oc (get_location fp.formal_parameter_id) print_loc; print_opt_value oc fp.formal_parameter_name print_string; - print_opt_value oc fp.formal_parameter_segment print_loc; + print_opt_value oc (get_segment_location fp.formal_parameter_id) print_loc; print_ref oc fp.formal_parameter_type; print_opt_value oc fp.formal_parameter_variable_parameter print_flag @@ -406,7 +406,7 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): let addr = get_fun_addr sp.subprogram_name in print_file_loc oc sp.subprogram_file_loc; print_opt_value oc sp.subprogram_external print_flag; - print_opt_value oc sp.subprogram_frame_base print_loc; + print_opt_value oc (get_frame_base sp.subprogram_id) print_loc; print_opt_value oc addr print_subprogram_addr; print_string oc sp.subprogram_name; print_flag oc sp.subprogram_prototyped; @@ -439,9 +439,9 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): print_file_loc oc 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_opt_value oc (get_location var.variable_id) print_loc; print_string oc var.variable_name; - print_opt_value oc var.variable_segment print_loc; + print_opt_value oc (get_segment_location var.variable_id) print_loc; print_ref oc var.variable_type let print_volatile_type oc vt = diff --git a/debug/DwarfTypes.mli b/debug/DwarfTypes.mli index 4852e550..174f2403 100644 --- a/debug/DwarfTypes.mli +++ b/debug/DwarfTypes.mli @@ -13,6 +13,7 @@ (* Types used for writing dwarf debug information *) open Sections +open Camlcoq (* Basic types for the value of attributes *) @@ -37,7 +38,7 @@ type address = int type block = string type location_value = - | LocSymbol of string + | LocSymbol of atom | LocConst of constant | LocBlock of block @@ -93,11 +94,10 @@ type dw_tag_enumerator = type dw_tag_formal_parameter = { + formal_parameter_id: int; formal_parameter_file_loc: file_loc option; formal_parameter_artificial: flag option; - formal_parameter_location: location_value option; formal_parameter_name: string option; - formal_parameter_segment: location_value option; formal_parameter_type: reference; formal_parameter_variable_parameter: flag option; } @@ -141,9 +141,9 @@ type dw_tag_structure_type = type dw_tag_subprogram = { + subprogram_id: int; subprogram_file_loc: file_loc option; subprogram_external: flag option; - subprogram_frame_base: location_value option; subprogram_name: string; subprogram_prototyped: flag; subprogram_type: reference option; @@ -184,12 +184,11 @@ type dw_tag_unspecified_parameter = type dw_tag_variable = { + variable_id: int; variable_file_loc: file_loc option; variable_declaration: flag option; variable_external: flag option; - variable_location: location_value option; variable_name: string; - variable_segment: location_value option; variable_type: reference; } @@ -270,4 +269,8 @@ module type DWARF_TARGET= val get_stmt_list_addr: unit -> int val name_of_section: section_name -> string val get_fun_addr: string -> (int * int) option + val get_location: int -> location_value option + val get_segment_location: int -> location_value option + val get_frame_base: int -> location_value option + val symbol: out_channel -> atom -> unit end -- cgit From 108db39b8b7c1d42cbc38c5aabf885ef5440f189 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Wed, 26 Aug 2015 14:28:22 +0200 Subject: Added the abbreviation for symbol constants. --- debug/DwarfPrinter.ml | 1 + 1 file changed, 1 insertion(+) (limited to 'debug') diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index cd888a80..c85a9efc 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -72,6 +72,7 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): let add_location loc buf = match loc with | None -> () + | Some (LocSymbol _) ->add_abbr_entry (0x2,location_block_type_abbr) buf | Some (LocConst _) -> add_abbr_entry (0x2,location_const_type_abbr) buf | Some (LocBlock _) -> add_abbr_entry (0x2,location_block_type_abbr) buf -- cgit From 861292a6c5e58b4f78bef207c717b801b3fc1fed Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Sun, 6 Sep 2015 20:32:55 +0200 Subject: Startet implementation of new Debug interface. Added a new file debug/Debug.ml which will be the interface between for generating and printing the debuging information. Currently it contains only the code for the line directived. --- debug/CtoDwarf.ml | 2 +- debug/Debug.ml | 86 ++++++++++++++++++++++++++++++++++++++++++++++++++ debug/DwarfPrinter.mli | 1 + 3 files changed, 88 insertions(+), 1 deletion(-) create mode 100644 debug/Debug.ml (limited to 'debug') diff --git a/debug/CtoDwarf.ml b/debug/CtoDwarf.ml index 063b0823..e37c6043 100644 --- a/debug/CtoDwarf.ml +++ b/debug/CtoDwarf.ml @@ -477,7 +477,7 @@ let union_to_dwarf (n,at,m) env gloc = (* Translate global declarations to there dwarf representation *) let globdecl_to_dwarf env (typs,decls) decl = - PrintAsmaux.add_file (fst decl.gloc); + Debug.add_file (fst decl.gloc); match decl.gdesc with | Gtypedef (n,t) -> let ret = typedef_to_dwarf (Some decl.gloc) (n.name,t) in typs@ret,decls diff --git a/debug/Debug.ml b/debug/Debug.ml new file mode 100644 index 00000000..dfe7fd94 --- /dev/null +++ b/debug/Debug.ml @@ -0,0 +1,86 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Bernhard Schommer, AbsInt Angewandte Informatik GmbH *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +open Printf + +(* Printing annotations in asm syntax *) +(** All files used in the debug entries *) +module StringSet = Set.Make(String) +let all_files : StringSet.t ref = ref StringSet.empty +let add_file file = + all_files := StringSet.add file !all_files + + +let filename_info : (string, int * Printlines.filebuf option) Hashtbl.t + = Hashtbl.create 7 + +let last_file = ref "" + +let reset_filenames () = + Hashtbl.clear filename_info; last_file := "" + +let close_filenames () = + Hashtbl.iter + (fun file (num, fb) -> + match fb with Some b -> Printlines.close b | None -> ()) + filename_info; + reset_filenames() + +let enter_filename f = + let num = Hashtbl.length filename_info + 1 in + let filebuf = + if !Clflags.option_S || !Clflags.option_dasm then begin + try Some (Printlines.openfile f) + with Sys_error _ -> None + end else None in + Hashtbl.add filename_info f (num, filebuf); + (num, filebuf) + + +(* Add file and line debug location, using GNU assembler-style DWARF2 + directives *) + +let print_file_line oc pref file line = + if !Clflags.option_g && file <> "" then begin + let (filenum, filebuf) = + try + Hashtbl.find filename_info file + with Not_found -> + let (filenum, filebuf as res) = enter_filename file in + fprintf oc " .file %d %S\n" filenum file; + res in + fprintf oc " .loc %d %d\n" filenum line; + match filebuf with + | None -> () + | Some fb -> Printlines.copy oc pref fb line line + end + +(* Add file and line debug location, using DWARF2 directives in the style + of Diab C 5 *) + +let print_file_line_d2 oc pref file line = + if !Clflags.option_g && file <> "" then begin + let (_, filebuf) = + try + Hashtbl.find filename_info file + with Not_found -> + enter_filename file in + if file <> !last_file then begin + fprintf oc " .d2file %S\n" file; + last_file := file + end; + fprintf oc " .d2line %d\n" line; + match filebuf with + | None -> () + | Some fb -> Printlines.copy oc pref fb line line + end diff --git a/debug/DwarfPrinter.mli b/debug/DwarfPrinter.mli index 9e0e6693..ccdecffb 100644 --- a/debug/DwarfPrinter.mli +++ b/debug/DwarfPrinter.mli @@ -1,3 +1,4 @@ + (* *********************************************************************) (* *) (* The Compcert verified compiler *) -- cgit From cc6ce2bf9b8be54375ea3285ea2fa658bc108df0 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Thu, 10 Sep 2015 13:42:43 +0200 Subject: Revert "Startet implementation of new Debug interface." This reverts commit 861292a6c5e58b4f78bef207c717b801b3fc1fed. --- debug/CtoDwarf.ml | 2 +- debug/Debug.ml | 86 -------------------------------------------------- debug/DwarfPrinter.mli | 1 - 3 files changed, 1 insertion(+), 88 deletions(-) delete mode 100644 debug/Debug.ml (limited to 'debug') diff --git a/debug/CtoDwarf.ml b/debug/CtoDwarf.ml index e37c6043..063b0823 100644 --- a/debug/CtoDwarf.ml +++ b/debug/CtoDwarf.ml @@ -477,7 +477,7 @@ let union_to_dwarf (n,at,m) env gloc = (* Translate global declarations to there dwarf representation *) let globdecl_to_dwarf env (typs,decls) decl = - Debug.add_file (fst decl.gloc); + PrintAsmaux.add_file (fst decl.gloc); match decl.gdesc with | Gtypedef (n,t) -> let ret = typedef_to_dwarf (Some decl.gloc) (n.name,t) in typs@ret,decls diff --git a/debug/Debug.ml b/debug/Debug.ml deleted file mode 100644 index dfe7fd94..00000000 --- a/debug/Debug.ml +++ /dev/null @@ -1,86 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* Bernhard Schommer, AbsInt Angewandte Informatik GmbH *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -open Printf - -(* Printing annotations in asm syntax *) -(** All files used in the debug entries *) -module StringSet = Set.Make(String) -let all_files : StringSet.t ref = ref StringSet.empty -let add_file file = - all_files := StringSet.add file !all_files - - -let filename_info : (string, int * Printlines.filebuf option) Hashtbl.t - = Hashtbl.create 7 - -let last_file = ref "" - -let reset_filenames () = - Hashtbl.clear filename_info; last_file := "" - -let close_filenames () = - Hashtbl.iter - (fun file (num, fb) -> - match fb with Some b -> Printlines.close b | None -> ()) - filename_info; - reset_filenames() - -let enter_filename f = - let num = Hashtbl.length filename_info + 1 in - let filebuf = - if !Clflags.option_S || !Clflags.option_dasm then begin - try Some (Printlines.openfile f) - with Sys_error _ -> None - end else None in - Hashtbl.add filename_info f (num, filebuf); - (num, filebuf) - - -(* Add file and line debug location, using GNU assembler-style DWARF2 - directives *) - -let print_file_line oc pref file line = - if !Clflags.option_g && file <> "" then begin - let (filenum, filebuf) = - try - Hashtbl.find filename_info file - with Not_found -> - let (filenum, filebuf as res) = enter_filename file in - fprintf oc " .file %d %S\n" filenum file; - res in - fprintf oc " .loc %d %d\n" filenum line; - match filebuf with - | None -> () - | Some fb -> Printlines.copy oc pref fb line line - end - -(* Add file and line debug location, using DWARF2 directives in the style - of Diab C 5 *) - -let print_file_line_d2 oc pref file line = - if !Clflags.option_g && file <> "" then begin - let (_, filebuf) = - try - Hashtbl.find filename_info file - with Not_found -> - enter_filename file in - if file <> !last_file then begin - fprintf oc " .d2file %S\n" file; - last_file := file - end; - fprintf oc " .d2line %d\n" line; - match filebuf with - | None -> () - | Some fb -> Printlines.copy oc pref fb line line - end diff --git a/debug/DwarfPrinter.mli b/debug/DwarfPrinter.mli index ccdecffb..9e0e6693 100644 --- a/debug/DwarfPrinter.mli +++ b/debug/DwarfPrinter.mli @@ -1,4 +1,3 @@ - (* *********************************************************************) (* *) (* The Compcert verified compiler *) -- cgit From ed50169fa51b8a9cfdbf65380348f6a02909d9d7 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Fri, 11 Sep 2015 10:43:30 +0200 Subject: Started implementing the types needed for storing the debug information. --- debug/CtoDwarf.ml | 2 +- debug/DebugInformation.ml | 109 ++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 110 insertions(+), 1 deletion(-) create mode 100644 debug/DebugInformation.ml (limited to 'debug') diff --git a/debug/CtoDwarf.ml b/debug/CtoDwarf.ml index 063b0823..f1e2aea6 100644 --- a/debug/CtoDwarf.ml +++ b/debug/CtoDwarf.ml @@ -19,7 +19,7 @@ open DwarfTypes open DwarfUtil open Env open Set - +open DebugInformation (* Functions to translate a C Ast into Dwarf 2 debugging information *) diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml new file mode 100644 index 00000000..be47f2a7 --- /dev/null +++ b/debug/DebugInformation.ml @@ -0,0 +1,109 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Bernhard Schommer, AbsInt Angewandte Informatik GmbH *) +(* *) +(* AbsInt Angewandte Informatik GmbH. All rights reserved. This file *) +(* is distributed under the terms of the INRIA Non-Commercial *) +(* License Agreement. *) +(* *) +(* *********************************************************************) + +open C + +(* This implements an interface for the collection of debugging + information. *) + +(* Types for the information of type info *) +type composite_field = + { + cfd_name: string; + cfd_typ: int; + cfd_bit_size: int option; + cfd_bit_offset: int option; + cfd_byte_offset: int option; + cfd_byte_size: int option; + } + +type composite_type = + { + ct_name: string; + ct_file_loc: location option; + ct_members: composite_field list; + ct_alignof: int option; + ct_sizeof: int option; + } + +type ptr_type = { + pts: int + } + +type array_type = { + arr_type: int; + arr_size: int64 option; + } + +type typedef = { + typedef_name: string; + typ: int; + } + +type enumerator = { + enumerator_file_loc: location option; + enumerator_name: string; + enumerator_const: int; + } + +type emum_type = { + enum_name: string; + enum_byte_size: int option; + enum_file_loc: location option; + enum_enumerators: enumerator list; + } + +type int_type = { + int_kind: ikind; + } + +type float_type = { + float_kind: fkind; + } + +type parameter_type = { + param_type: int; + param_name: string; + } + +type function_type = { + fun_return_type: int; + fun_prototyped: int; + fun_params: parameter_type list; + } + +type debug_types = + | IntegerType of int_type + | FloatType of float_type + | PointerType of ptr_type + | ArrayType of array_type + | StructType of composite_type + | UnionType of composite_type + | FunctionType of function_type + | Typedef of typedef + +(* All types encountered *) +let all_types: (int,debug_types) Hashtbl.t = Hashtbl.create 7 + +(* The basetypes, pointer, typedefs and enums all must have names *) +let name_types: (string,int) Hashtbl.t = Hashtbl.create 7 + +(* Composite types do not need to have a name. We thereore use the stamp for the mapping *) +let composite_types_table: (int, composite_type) Hashtbl.t = Hashtbl.create 7 + +(* Translate a C.typ to a string needed for hashing *) +let typ_to_string (ty: typ) = + let buf = Buffer.create 7 in + let chan = Format.formatter_of_buffer buf in + Cprint.typ chan ty; + Format.pp_print_flush chan (); + Buffer.contents buf -- cgit From 2b5940c2256384f837bcdfc2ddb4783f1b377dbf Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Fri, 11 Sep 2015 14:42:40 +0200 Subject: Started implementing the typ insert methods. In contrast to CtoDwarf this time we use the name to identify everything. To make this work we print the full identifier with stamp to avoid the problems with anonymous structs and unions. --- debug/CtoDwarf.ml | 45 -------------------- debug/DebugInformation.ml | 104 +++++++++++++++++++++++++++++++++++++++++++--- 2 files changed, 99 insertions(+), 50 deletions(-) (limited to 'debug') diff --git a/debug/CtoDwarf.ml b/debug/CtoDwarf.ml index f1e2aea6..dce8d81e 100644 --- a/debug/CtoDwarf.ml +++ b/debug/CtoDwarf.ml @@ -65,51 +65,6 @@ let rec mmap f env = function (hd' :: tl', env2) -(* 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) - (* Dwarf tag for the void type*) let rec void_dwarf_tag = let void = { diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index be47f2a7..e84172e6 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -15,6 +15,17 @@ open C (* This implements an interface for the collection of debugging information. *) +(* Simple id generator *) +let id = ref 0 + +let next_id () = + let nid = !id in + incr id; nid + +let reset_id () = + id := 0 + + (* Types for the information of type info *) type composite_field = { @@ -39,6 +50,15 @@ type ptr_type = { pts: int } +type const_type = { + const_type: int + } + +type volatile_type = { + volatile_type: int + } + + type array_type = { arr_type: int; arr_size: int64 option; @@ -90,20 +110,94 @@ type debug_types = | UnionType of composite_type | FunctionType of function_type | Typedef of typedef + | ConstType of const_type + | VolatileType of volatile_type + | Void (* All types encountered *) let all_types: (int,debug_types) Hashtbl.t = Hashtbl.create 7 -(* The basetypes, pointer, typedefs and enums all must have names *) -let name_types: (string,int) Hashtbl.t = Hashtbl.create 7 - -(* Composite types do not need to have a name. We thereore use the stamp for the mapping *) -let composite_types_table: (int, composite_type) Hashtbl.t = Hashtbl.create 7 +(* Lookup table for types *) +let lookup_types: (string, int) Hashtbl.t = Hashtbl.create 7 (* Translate a C.typ to a string needed for hashing *) let typ_to_string (ty: typ) = let buf = Buffer.create 7 in let chan = Format.formatter_of_buffer buf in + let old = !Cprint.print_idents_in_full in + Cprint.print_idents_in_full := true; Cprint.typ chan ty; + Cprint.print_idents_in_full := old; Format.pp_print_flush chan (); 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) + +(* 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 *) + let ty = strip_attributes ty in + Hashtbl.find lookup_types (typ_to_string ty) + +(* Add type and information *) +let insert_type (ty: typ) = + (* We are only interrested in Const and Volatile *) + let ty = strip_attributes ty in + if not (exist_type ty) then + begin + let rec typ_aux ty = () + and attr_aux ty = + match strip_last_attribute ty with + | Some AConst,t -> + () + | None,t -> typ_aux t + in + attr_aux ty + end -- cgit From d9e0b10ac078e936c9521f1f7dba14d3fac0077a Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Mon, 14 Sep 2015 17:53:17 +0200 Subject: Implemented insert_type function and started implementing add declaration. The insert_type function add types by adding their subtypes. Also currently the structs or unions are added as empty skeletopn and later during filled during the inserting of the declarations. --- debug/DebugInformation.ml | 219 +++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 206 insertions(+), 13 deletions(-) (limited to 'debug') diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index e84172e6..42c229fa 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -11,6 +11,8 @@ (* *********************************************************************) open C +open Camlcoq +open Cutil (* This implements an interface for the collection of debugging information. *) @@ -66,7 +68,7 @@ type array_type = { type typedef = { typedef_name: string; - typ: int; + typ: int option; } type enumerator = { @@ -75,7 +77,7 @@ type enumerator = { enumerator_const: int; } -type emum_type = { +type enum_type = { enum_name: string; enum_byte_size: int option; enum_file_loc: location option; @@ -97,7 +99,7 @@ type parameter_type = { type function_type = { fun_return_type: int; - fun_prototyped: int; + fun_prototyped: bool; fun_params: parameter_type list; } @@ -108,6 +110,7 @@ type debug_types = | ArrayType of array_type | StructType of composite_type | UnionType of composite_type + | EnumType of enum_type | FunctionType of function_type | Typedef of typedef | ConstType of const_type @@ -133,7 +136,7 @@ let typ_to_string (ty: typ) = (* Helper functions for the attributes *) let strip_attributes typ = - let strip = List.filter (fun a -> a = AConst || a = AVolatile) in + 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) @@ -187,17 +190,207 @@ let find_type (ty: typ) = Hashtbl.find lookup_types (typ_to_string ty) (* Add type and information *) -let insert_type (ty: typ) = +let insert_type (ty: typ) = + let insert d_ty ty = + let id = next_id () + and name = typ_to_string ty in + Hashtbl.add all_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 - if not (exist_type ty) then - begin - let rec typ_aux ty = () - and attr_aux ty = + let rec typ_aux ty = + try find_type ty with + | Not_found -> + let d_ty = + match ty with + | TVoid _ -> Void + | TInt (k,_) -> + IntegerType ({int_kind = k }) + | TFloat (k,_) -> + FloatType ({float_kind = k}) + | TPtr (t,_) -> + let id = attr_aux t in + PointerType ({pts = id}) + | TArray (t,s,_) -> + let id = attr_aux t in + let arr = { + arr_type = id; + arr_size= s; + } in + ArrayType arr + | TFun (t,param,va,_) -> + let param,prot = (match param with + | None -> [],false + | Some p -> List.map (fun (i,t) -> let t = attr_aux t in + { + param_type = t; + param_name = i.name; + }) p,true) in + let ret = attr_aux t in + let ftype = { + fun_return_type = ret; + fun_prototyped = prot; + fun_params = param; + } in + FunctionType ftype + | TNamed (id,_) -> + let t = { + typedef_name = id.name; + typ = None; + } in + Typedef t + | TStruct (id,_) -> + let str = + { + ct_name = id.name; + ct_file_loc = None; + ct_members = []; + ct_alignof = None; + ct_sizeof = None; + } in + StructType str + | TUnion (id,_) -> + let union = + { + ct_name = id.name; + ct_file_loc = None; + ct_members = []; + ct_alignof = None; + ct_sizeof = None; + } in + UnionType union + | TEnum (id,_) -> + let enum = + { + enum_name = id.name; + enum_byte_size = None; + enum_file_loc = None; + enum_enumerators = []; + } in + EnumType enum in + insert d_ty ty + and attr_aux ty = + try + find_type ty + with + Not_found -> match strip_last_attribute ty with | Some AConst,t -> - () + let id = attr_aux t in + let const = { const_type = id} in + insert (ConstType const) ty + | Some AVolatile,t -> + let id = attr_aux t in + let volatile = {volatile_type = id} in + insert (VolatileType volatile) ty + | Some (ARestrict|AAlignas _| Attr(_,_)),t -> + attr_aux t | None,t -> typ_aux t - in - attr_aux ty - end + in + attr_aux ty + +(* Replace the struct information *) +let replace_struct id f = + let str = Hashtbl.find all_types id in + match str with + | StructType comp -> let comp' = f comp in + if comp <> comp' then Hashtbl.replace all_types id (StructType comp') + | _ -> assert false (* This should never happen *) + +(* Replace the union information *) +let replace_union id f = + let union = Hashtbl.find all_types id in + match union with + | UnionType comp -> let comp' = f comp in + if comp <> comp' then Hashtbl.replace all_types id (UnionType comp') + | _ -> assert false (* This should never happen *) + +(* Replace the typdef information *) +let replace_typedef id f = + let typdef = Hashtbl.find all_types id in + match typdef with + | Typedef typ -> let typ' = f typ in + if typ <> typ' then Hashtbl.replace all_types id (Typedef typ') + | _ -> assert false (* This should never happen *) + +(* Types for global definitions *) + +(* Information for a global variable *) +type global_variable = { + gvar_name: string; + gvar_atom: atom option; + gvar_file_loc: location; + gvar_declaration: bool; + gvar_external: bool; + gvar_type: int; + } + +type definition_type = + | GlobalVariable of global_variable + +(* All definitions encountered *) +let definitions: (int,definition_type) Hashtbl.t = Hashtbl.create 7 + +(* Mapping from stamp to debug id *) +let stamp_to_definition: (int,int) Hashtbl.t = Hashtbl.create 7 + +let find_var_stamp id = + let id = (Hashtbl.find stamp_to_definition id) in + let var = Hashtbl.find definitions id in + match var with + | GlobalVariable var -> id,var + +let replace_var id var = + let var = GlobalVariable var in + Hashtbl.replace definitions id var + +let insert_declaration dec env = + let insert d_dec stamp = + let id = next_id () in + Hashtbl.add definitions id d_dec; + Hashtbl.add stamp_to_definition stamp id + in + match dec.gdesc with + | Gdecl (sto,id,ty,init) -> + if not (is_function_type env ty) then begin + if not (Hashtbl.mem stamp_to_definition id.stamp) then begin + let at_decl,ext = (match sto with + | Storage_extern -> init = None,true + | Storage_static -> false,false + | _ -> false,true) in + let ty = insert_type ty in + let decl = { + gvar_name = id.name; + gvar_atom = None; + gvar_file_loc = dec.gloc; + gvar_declaration = at_decl; + gvar_external = ext; + gvar_type = ty; + } in + insert (GlobalVariable decl) id.stamp + end else if init <> None || sto <> Storage_extern then begin (* It is a definition *) + let id,var = find_var_stamp id.stamp in + replace_var id ({var with gvar_declaration = false;}) + end + end + | Gfundef _ -> () + | Gcompositedecl (Struct,id,at) -> + ignore (insert_type (TStruct (id,at))); + let id = find_type (TStruct (id,[])) in + replace_struct id (fun comp -> if comp.ct_file_loc = None then + {comp with ct_file_loc = Some (dec.gloc);} + else comp) + | Gcompositedecl (Union,id,at) -> + ignore (insert_type (TUnion (id,at))); + let id = find_type (TUnion (id,[])) in + replace_union id (fun comp -> if comp.ct_file_loc = None then + {comp with ct_file_loc = Some (dec.gloc);} + else comp) + | Gcompositedef _ -> () + | Gtypedef (id,t) -> + let id = insert_type (TNamed (id,[])) in + let tid = insert_type t in + replace_typedef id (fun typ -> {typ with typ = Some tid;}); + | Genumdef _ -> () + | Gpragma _ -> () -- cgit From 5fc1db7170193a72f7bc6fc660a8e22090368994 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Tue, 15 Sep 2015 10:44:46 +0200 Subject: Started adding function information to the debug information. --- debug/DebugInformation.ml | 51 ++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 48 insertions(+), 3 deletions(-) (limited to 'debug') diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index 42c229fa..4d340e57 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -317,7 +317,7 @@ let replace_typedef id f = (* Types for global definitions *) (* Information for a global variable *) -type global_variable = { +type global_variable_information = { gvar_name: string; gvar_atom: atom option; gvar_file_loc: location; @@ -326,8 +326,27 @@ type global_variable = { gvar_type: int; } +type parameter_information = + { + parameter_name: string; + parameter_atom: atom option; + parameter_type: int; +} + +type function_information = { + fun_name: string; + fun_atom: atom option; + fun_file_loc: location; + fun_external: bool; + fun_return_type: int option; (* Again the special case of void functions *) + fun_vararg: bool; + fun_parameter: parameter_information list; + fun_locals: int list; + } + type definition_type = - | GlobalVariable of global_variable + | GlobalVariable of global_variable_information + | Function of function_information (* All definitions encountered *) let definitions: (int,definition_type) Hashtbl.t = Hashtbl.create 7 @@ -340,6 +359,7 @@ let find_var_stamp id = let var = Hashtbl.find definitions id in match var with | GlobalVariable var -> id,var + | _ -> assert false let replace_var id var = let var = GlobalVariable var in @@ -374,7 +394,32 @@ let insert_declaration dec env = replace_var id ({var with gvar_declaration = false;}) end end - | Gfundef _ -> () + | Gfundef f -> + let ret = (match f.fd_ret with + | TVoid _ -> None + | _ -> Some (insert_type f.fd_ret)) in + let ext = (match f.fd_storage with + | Storage_static -> false + | _ -> true) in + let params = List.map (fun (p,ty) -> + let ty = insert_type ty in + { + parameter_name = p.name; + parameter_atom = None; + parameter_type = ty; + }) f.fd_params in + let fd = + { + fun_name = f.fd_name.name; + fun_atom = None; + fun_file_loc = dec.gloc; + fun_external = ext; + fun_return_type = ret; + fun_vararg = f.fd_vararg; + fun_parameter = params; + fun_locals = []; + } in + insert (Function fd) f.fd_name.stamp | Gcompositedecl (Struct,id,at) -> ignore (insert_type (TStruct (id,at))); let id = find_type (TStruct (id,[])) in -- cgit From 36fe88d4cc2022947474a2fcc0b650e22f41ee3e Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Tue, 15 Sep 2015 18:42:04 +0200 Subject: Further function to add debug information. Added the rest of the global declarations and started adding functions to fill in the missing information about struct and union fields etc. --- debug/DebugInformation.ml | 98 ++++++++++++++++++++++++++++++++--------------- 1 file changed, 67 insertions(+), 31 deletions(-) (limited to 'debug') diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index 4d340e57..166a81e8 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -37,14 +37,15 @@ type composite_field = cfd_bit_offset: int option; cfd_byte_offset: int option; cfd_byte_size: int option; + cfd_bitfield: string option; } type composite_type = { ct_name: string; + ct_sou: struct_or_union; ct_file_loc: location option; ct_members: composite_field list; - ct_alignof: int option; ct_sizeof: int option; } @@ -72,9 +73,8 @@ type typedef = { } type enumerator = { - enumerator_file_loc: location option; enumerator_name: string; - enumerator_const: int; + enumerator_const: int64; } type enum_type = { @@ -108,8 +108,7 @@ type debug_types = | FloatType of float_type | PointerType of ptr_type | ArrayType of array_type - | StructType of composite_type - | UnionType of composite_type + | CompositeType of composite_type | EnumType of enum_type | FunctionType of function_type | Typedef of typedef @@ -244,22 +243,22 @@ let insert_type (ty: typ) = let str = { ct_name = id.name; + ct_sou = Struct; ct_file_loc = None; ct_members = []; - ct_alignof = None; ct_sizeof = None; } in - StructType str + CompositeType str | TUnion (id,_) -> let union = { ct_name = id.name; + ct_sou = Union; ct_file_loc = None; ct_members = []; - ct_alignof = None; ct_sizeof = None; } in - UnionType union + CompositeType union | TEnum (id,_) -> let enum = { @@ -290,20 +289,20 @@ let insert_type (ty: typ) = in attr_aux ty -(* Replace the struct information *) -let replace_struct id f = +(* Replace the composite information *) +let replace_composite id f = let str = Hashtbl.find all_types id in match str with - | StructType comp -> let comp' = f comp in - if comp <> comp' then Hashtbl.replace all_types id (StructType comp') + | CompositeType comp -> let comp' = f comp in + if comp <> comp' then Hashtbl.replace all_types id (CompositeType comp') | _ -> assert false (* This should never happen *) -(* Replace the union information *) -let replace_union id f = - let union = Hashtbl.find all_types id in - match union with - | UnionType comp -> let comp' = f comp in - if comp <> comp' then Hashtbl.replace all_types id (UnionType comp') +(* Replace the enum information *) +let replace_enum id f = + let str = Hashtbl.find all_types id in + match str with + | EnumType comp -> let comp' = f comp in + if comp <> comp' then Hashtbl.replace all_types id (EnumType comp') | _ -> assert false (* This should never happen *) (* Replace the typdef information *) @@ -365,6 +364,12 @@ let replace_var id var = let var = GlobalVariable var in Hashtbl.replace definitions id var +let gen_comp_typ sou id at = + if sou = Struct then + TStruct (id,at) + else + TUnion (id,at) + let insert_declaration dec env = let insert d_dec stamp = let id = next_id () in @@ -420,22 +425,53 @@ let insert_declaration dec env = fun_locals = []; } in insert (Function fd) f.fd_name.stamp - | Gcompositedecl (Struct,id,at) -> - ignore (insert_type (TStruct (id,at))); - let id = find_type (TStruct (id,[])) in - replace_struct id (fun comp -> if comp.ct_file_loc = None then + | 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) - | Gcompositedecl (Union,id,at) -> - ignore (insert_type (TUnion (id,at))); - let id = find_type (TUnion (id,[])) in - replace_union id (fun comp -> if comp.ct_file_loc = None then - {comp with ct_file_loc = Some (dec.gloc);} - else comp) - | Gcompositedef _ -> () + | 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 fields = List.map (fun f -> + { + cfd_name = f.fld_name; + cfd_typ = insert_type f.fld_typ; + cfd_bit_size = None; + cfd_bit_offset = f.fld_bitfield; + cfd_byte_offset = None; + cfd_byte_size = None; + cfd_bitfield = None; + }) fi in + 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;}) | Gtypedef (id,t) -> let id = insert_type (TNamed (id,[])) in let tid = insert_type t in replace_typedef id (fun typ -> {typ with typ = Some tid;}); - | Genumdef _ -> () + | 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 + replace_enum id (fun en -> + {en with enum_file_loc = Some dec.gloc; enum_enumerators = enumerator;}) | Gpragma _ -> () + +let set_offset str field (offset,byte_size) = + 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 members = List.map (fun a -> if name a then + {a with cfd_byte_offset = Some offset; cfd_byte_size = Some byte_size;} + else a) comp.ct_members in + {comp with ct_members = members;}) + +let set_size comp sou size = + let id = find_type (gen_comp_typ sou comp []) in + replace_composite id (fun comp -> {comp with ct_sizeof = Some size;}) -- cgit From 3344bcf59acb1ae8d43a0d15acb4b824689e706d Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Wed, 16 Sep 2015 11:10:28 +0200 Subject: Add the debug interface file. The new file Debug.ml contains the interface for generating and printing debug information. In order to generate debug information the init function initializes the necessary functions depending on the -g flag. If the -g is not there all functions are dummy functions which do nothing. --- debug/CtoDwarf.ml | 46 +++++++++++++++++++++++++++++++++-- debug/Debug.ml | 61 +++++++++++++++++++++++++++++++++++++++++++++++ debug/Debug.mli | 23 ++++++++++++++++++ debug/DebugInformation.ml | 58 ++++++++++++++++++++++++++++++++++++-------- 4 files changed, 176 insertions(+), 12 deletions(-) create mode 100644 debug/Debug.ml create mode 100644 debug/Debug.mli (limited to 'debug') diff --git a/debug/CtoDwarf.ml b/debug/CtoDwarf.ml index dce8d81e..3a325665 100644 --- a/debug/CtoDwarf.ml +++ b/debug/CtoDwarf.ml @@ -19,9 +19,8 @@ open DwarfTypes open DwarfUtil open Env open Set -open DebugInformation -(* Functions to translate a C Ast into Dwarf 2 debugging information *) +(* Functions to translate a C Ast into Dwarf 2 debugging information *) (* Hashtable from type name to entry id *) let type_table: (string, int) Hashtbl.t = Hashtbl.create 7 @@ -40,6 +39,49 @@ module IntSet = Set.Make(struct type t = int let compare = compare end) (* Set of all declared composite_types *) let composite_defined: IntSet.t ref = ref IntSet.empty +(* 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) + (* Get the type id of a composite_type *) let get_composite_type (name: int): int = try diff --git a/debug/Debug.ml b/debug/Debug.ml new file mode 100644 index 00000000..eb195b33 --- /dev/null +++ b/debug/Debug.ml @@ -0,0 +1,61 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Bernhard Schommer, AbsInt Angewandte Informatik GmbH *) +(* *) +(* AbsInt Angewandte Informatik GmbH. All rights reserved. This file *) +(* is distributed under the terms of the INRIA Non-Commercial *) +(* License Agreement. *) +(* *) +(* *********************************************************************) + +open C +open Camlcoq + +(* Interface for generating and printing debug information *) + +(* Record used for stroring references to the actual implementation functions *) +type implem = + { + mutable init: string -> unit; + mutable atom_function: ident -> atom -> unit; + mutable atom_global_variable: ident -> atom -> unit; + mutable set_composite_size: ident -> struct_or_union -> int -> unit; + mutable set_member_offset: ident -> string -> int -> int -> unit; + mutable insert_declaration: globdecl -> Env.t -> unit; + } + +let implem = + { + init = (fun _ -> ()); + atom_function = (fun _ _ -> ()); + atom_global_variable = (fun _ _ -> ()); + set_composite_size = (fun _ _ _ -> ()); + set_member_offset = (fun _ _ _ _ -> ()); + insert_declaration = (fun _ _ -> ()); + } + +let init () = + if !Clflags.option_g then begin + implem.init <- DebugInformation.init; + implem.atom_function <- DebugInformation.atom_function; + implem.atom_global_variable <- DebugInformation.atom_global_variable; + implem.set_composite_size <- DebugInformation.set_composite_size; + implem.set_member_offset <- DebugInformation.set_member_offset; + implem.insert_declaration <- DebugInformation.insert_declaration; + end else begin + implem.init <- (fun _ -> ()); + implem.atom_function <- (fun _ _ -> ()); + implem.atom_global_variable <- (fun _ _ -> ()); + implem.set_composite_size <- (fun _ _ _ -> ()); + implem.set_member_offset <- (fun _ _ _ _ -> ()); + implem.insert_declaration <- (fun _ _ -> ()) + end + +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 set_composite_size id sou size = implem.set_composite_size id sou size +let set_member_offset id field off size = implem.set_member_offset id field off size +let insert_declaration dec env = implem.insert_declaration dec env diff --git a/debug/Debug.mli b/debug/Debug.mli new file mode 100644 index 00000000..ea72aeb4 --- /dev/null +++ b/debug/Debug.mli @@ -0,0 +1,23 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Bernhard Schommer, AbsInt Angewandte Informatik GmbH *) +(* *) +(* AbsInt Angewandte Informatik GmbH. All rights reserved. This file *) +(* is distributed under the terms of the INRIA Non-Commercial *) +(* License Agreement. *) +(* *) +(* *********************************************************************) + +open C +open Camlcoq + + +val init: unit -> unit +val init_compile_unit: string -> unit +val atom_function: ident -> atom -> unit +val atom_global_variable: ident -> atom -> unit +val set_composite_size: ident -> struct_or_union -> int -> unit +val set_member_offset: ident -> string -> int -> int -> unit +val insert_declaration: globdecl -> Env.t -> unit diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index 166a81e8..30d026c7 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -27,6 +27,9 @@ let next_id () = let reset_id () = id := 0 +(* The name of the current compilation unit *) +let file_name: string ref = ref "" + (* Types for the information of type info *) type composite_field = @@ -117,7 +120,7 @@ type debug_types = | Void (* All types encountered *) -let all_types: (int,debug_types) Hashtbl.t = Hashtbl.create 7 +let types: (int,debug_types) Hashtbl.t = Hashtbl.create 7 (* Lookup table for types *) let lookup_types: (string, int) Hashtbl.t = Hashtbl.create 7 @@ -193,7 +196,7 @@ let insert_type (ty: typ) = let insert d_ty ty = let id = next_id () and name = typ_to_string ty in - Hashtbl.add all_types id d_ty; + Hashtbl.add types id d_ty; Hashtbl.add lookup_types name id; id in (* We are only interrested in Const and Volatile *) @@ -291,26 +294,26 @@ let insert_type (ty: typ) = (* Replace the composite information *) let replace_composite id f = - let str = Hashtbl.find all_types id in + let str = Hashtbl.find types id in match str with | CompositeType comp -> let comp' = f comp in - if comp <> comp' then Hashtbl.replace all_types id (CompositeType comp') + if comp <> comp' then Hashtbl.replace types id (CompositeType comp') | _ -> assert false (* This should never happen *) (* Replace the enum information *) let replace_enum id f = - let str = Hashtbl.find all_types id in + let str = Hashtbl.find types id in match str with | EnumType comp -> let comp' = f comp in - if comp <> comp' then Hashtbl.replace all_types id (EnumType comp') + if comp <> comp' then Hashtbl.replace types id (EnumType comp') | _ -> assert false (* This should never happen *) (* Replace the typdef information *) let replace_typedef id f = - let typdef = Hashtbl.find all_types id in + let typdef = Hashtbl.find types id in match typdef with | Typedef typ -> let typ' = f typ in - if typ <> typ' then Hashtbl.replace all_types id (Typedef typ') + if typ <> typ' then Hashtbl.replace types id (Typedef typ') | _ -> assert false (* This should never happen *) (* Types for global definitions *) @@ -353,6 +356,9 @@ let definitions: (int,definition_type) Hashtbl.t = Hashtbl.create 7 (* Mapping from stamp to debug id *) let stamp_to_definition: (int,int) Hashtbl.t = Hashtbl.create 7 +(* Mapping from atom to debug id *) +let atom_to_definition: (atom, int) Hashtbl.t = Hashtbl.create 7 + let find_var_stamp id = let id = (Hashtbl.find stamp_to_definition id) in let var = Hashtbl.find definitions id in @@ -360,10 +366,22 @@ let find_var_stamp id = | GlobalVariable var -> id,var | _ -> assert false +let find_fun_stamp id = + let id = (Hashtbl.find stamp_to_definition id) in + let f = Hashtbl.find definitions id in + match f with + | Function f -> id,f + | _ -> assert false + + let replace_var id var = let var = GlobalVariable var in Hashtbl.replace definitions id var +let replace_fun id f = + let f = Function f in + Hashtbl.replace definitions id f + let gen_comp_typ sou id at = if sou = Struct then TStruct (id,at) @@ -463,7 +481,7 @@ let insert_declaration dec env = {en with enum_file_loc = Some dec.gloc; enum_enumerators = enumerator;}) | Gpragma _ -> () -let set_offset str field (offset,byte_size) = +let set_member_offset str field offset byte_size = 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 @@ -472,6 +490,26 @@ let set_offset str field (offset,byte_size) = else a) comp.ct_members in {comp with ct_members = members;}) -let set_size comp sou size = +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 = Some size;}) + +let atom_global_variable id atom = + let id,var = find_var_stamp id.stamp in + replace_var id ({var with gvar_atom = Some atom;}); + Hashtbl.add atom_to_definition atom id + +let atom_function id atom = + 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 + +let init name = + id := 0; + file_name := name; + Hashtbl.reset types; + Hashtbl.reset lookup_types; + Hashtbl.reset definitions; + Hashtbl.reset stamp_to_definition; + Hashtbl.reset atom_to_definition + -- cgit From 98cddc7ba45b34fbd71d9a80c27a8e5ec6b311b0 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Wed, 16 Sep 2015 19:43:35 +0200 Subject: Move more functionality in the new interface. Added functions to add more information to the debuging interface, like the struct layout with offsets, bitifiled layout and removed the no longer needed mapping from stamp to atom. --- debug/Debug.ml | 38 ++++++++++++++++++++++++-------------- debug/Debug.mli | 8 +++++--- debug/DebugInformation.ml | 35 ++++++++++++++++++++++++++++++----- debug/DwarfPrinter.ml | 4 ---- debug/DwarfTypes.mli | 1 - 5 files changed, 59 insertions(+), 27 deletions(-) (limited to 'debug') diff --git a/debug/Debug.ml b/debug/Debug.ml index eb195b33..ab20f630 100644 --- a/debug/Debug.ml +++ b/debug/Debug.ml @@ -21,9 +21,11 @@ type implem = mutable init: string -> unit; mutable atom_function: ident -> atom -> unit; mutable atom_global_variable: ident -> atom -> unit; - mutable set_composite_size: ident -> struct_or_union -> int -> unit; - mutable set_member_offset: ident -> string -> int -> int -> unit; - mutable insert_declaration: globdecl -> Env.t -> 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 } let implem = @@ -32,8 +34,10 @@ let implem = atom_function = (fun _ _ -> ()); atom_global_variable = (fun _ _ -> ()); set_composite_size = (fun _ _ _ -> ()); - set_member_offset = (fun _ _ _ _ -> ()); - insert_declaration = (fun _ _ -> ()); + set_member_offset = (fun _ _ _ -> ()); + set_bitfield_offset = (fun _ _ _ _ _ -> ()); + insert_global_declaration = (fun _ _ -> ()); + add_fun_addr = (fun _ _ -> ()); } let init () = @@ -43,19 +47,25 @@ let init () = implem.atom_global_variable <- DebugInformation.atom_global_variable; implem.set_composite_size <- DebugInformation.set_composite_size; implem.set_member_offset <- DebugInformation.set_member_offset; - implem.insert_declaration <- DebugInformation.insert_declaration; + implem.set_bitfield_offset <- DebugInformation.set_bitfield_offset; + implem.insert_global_declaration <- DebugInformation.insert_global_declaration; + implem.add_fun_addr <- DebugInformation.add_fun_addr; end else begin - implem.init <- (fun _ -> ()); - implem.atom_function <- (fun _ _ -> ()); - implem.atom_global_variable <- (fun _ _ -> ()); - implem.set_composite_size <- (fun _ _ _ -> ()); - implem.set_member_offset <- (fun _ _ _ _ -> ()); - implem.insert_declaration <- (fun _ _ -> ()) + implem.init <- (fun _ -> ()); + implem.atom_function <- (fun _ _ -> ()); + implem.atom_global_variable <- (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 _ _ -> ()) end 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 set_composite_size id sou size = implem.set_composite_size id sou size -let set_member_offset id field off size = implem.set_member_offset id field off size -let insert_declaration dec env = implem.insert_declaration dec env +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 diff --git a/debug/Debug.mli b/debug/Debug.mli index ea72aeb4..ae32af5b 100644 --- a/debug/Debug.mli +++ b/debug/Debug.mli @@ -18,6 +18,8 @@ val init: unit -> unit val init_compile_unit: string -> unit val atom_function: ident -> atom -> unit val atom_global_variable: ident -> atom -> unit -val set_composite_size: ident -> struct_or_union -> int -> unit -val set_member_offset: ident -> string -> int -> int -> unit -val insert_declaration: globdecl -> Env.t -> 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 +val insert_global_declaration: Env.t -> globdecl -> unit +val add_fun_addr: atom -> (int * int) -> unit diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index 30d026c7..53f73115 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -343,7 +343,9 @@ type function_information = { fun_return_type: int option; (* Again the special case of void functions *) fun_vararg: bool; fun_parameter: parameter_information list; - fun_locals: int list; + fun_locals: int list; + fun_low_pc: int option; + fun_high_pc: int option; } type definition_type = @@ -373,6 +375,13 @@ let find_fun_stamp id = | Function f -> id,f | _ -> assert false +let find_fun_atom id = + let id = (Hashtbl.find atom_to_definition id) in + let f = Hashtbl.find definitions id in + match f with + | Function f -> id,f + | _ -> assert false + let replace_var id var = let var = GlobalVariable var in @@ -388,7 +397,7 @@ let gen_comp_typ sou id at = else TUnion (id,at) -let insert_declaration dec env = +let insert_global_declaration env dec= let insert d_dec stamp = let id = next_id () in Hashtbl.add definitions id d_dec; @@ -441,6 +450,8 @@ let insert_declaration dec env = fun_vararg = f.fd_vararg; fun_parameter = params; fun_locals = []; + fun_low_pc = None; + fun_high_pc = None; } in insert (Function fd) f.fd_name.stamp | Gcompositedecl (sou,id,at) -> @@ -481,18 +492,28 @@ let insert_declaration dec env = {en with enum_file_loc = Some dec.gloc; enum_enumerators = enumerator;}) | Gpragma _ -> () -let set_member_offset str field offset byte_size = +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 members = List.map (fun a -> if name a then - {a with cfd_byte_offset = Some offset; cfd_byte_size = Some byte_size;} + {a with cfd_byte_offset = Some offset;} else a) 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 = Some 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.map (fun a -> if name a then + {a with cfd_bit_offset = Some offset; cfd_bitfield = Some underlying; cfd_byte_size = Some size} + else + a) comp.ct_members in + {comp with ct_members = members;}) let atom_global_variable id atom = let id,var = find_var_stamp id.stamp in @@ -504,6 +525,10 @@ let atom_function id atom = replace_fun id ({f with fun_atom = Some atom;}); Hashtbl.add atom_to_definition atom id +let add_fun_addr atom (high,low) = + let id,f = find_fun_atom atom in + replace_fun id ({f with fun_high_pc = Some high; fun_low_pc = Some low;}) + let init name = id := 0; file_name := name; diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index c85a9efc..09cf72eb 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -130,7 +130,6 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): add_attr_some e.formal_parameter_artificial (add_abbr_entry (0x34,artificial_type_abbr)); add_location (get_location e.formal_parameter_id) buf; add_attr_some e.formal_parameter_name add_name; - add_location (get_segment_location e.formal_parameter_id) buf; add_type buf; add_attr_some e.formal_parameter_variable_parameter (add_abbr_entry (0x4b,variable_parameter_type_abbr)) | DW_TAG_label _ -> @@ -205,7 +204,6 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): add_attr_some e.variable_external (add_abbr_entry (0x3f,external_type_abbr)); add_location (get_location e.variable_id) buf; add_name buf; - add_location (get_segment_location e.variable_id) buf; add_type buf | DW_TAG_volatile_type _ -> prologue 0x35; @@ -367,7 +365,6 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): print_opt_value oc fp.formal_parameter_artificial print_flag; print_opt_value oc (get_location fp.formal_parameter_id) print_loc; print_opt_value oc fp.formal_parameter_name print_string; - print_opt_value oc (get_segment_location fp.formal_parameter_id) print_loc; print_ref oc fp.formal_parameter_type; print_opt_value oc fp.formal_parameter_variable_parameter print_flag @@ -441,7 +438,6 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): print_opt_value oc var.variable_external print_flag; print_opt_value oc (get_location var.variable_id) print_loc; print_string oc var.variable_name; - print_opt_value oc (get_segment_location var.variable_id) print_loc; print_ref oc var.variable_type let print_volatile_type oc vt = diff --git a/debug/DwarfTypes.mli b/debug/DwarfTypes.mli index 174f2403..b852d1f4 100644 --- a/debug/DwarfTypes.mli +++ b/debug/DwarfTypes.mli @@ -270,7 +270,6 @@ module type DWARF_TARGET= val name_of_section: section_name -> string val get_fun_addr: string -> (int * int) option val get_location: int -> location_value option - val get_segment_location: int -> location_value option val get_frame_base: int -> location_value option val symbol: out_channel -> atom -> unit end -- cgit From c8a0b76c6b9c3eb004a7fccdd2ad15cc8615ef93 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Thu, 17 Sep 2015 18:19:37 +0200 Subject: First version with computation of dwarf info from debug info. Introduced a new dwarf generation from the information collected in the DebugInformation and removed the old CtODwarf translation. --- debug/CtoDwarf.ml | 540 ---------------------------------------------- debug/Debug.ml | 18 +- debug/Debug.mli | 3 + debug/DebugInformation.ml | 80 ++++--- debug/DwarfPrinter.ml | 52 +++-- debug/DwarfTypes.mli | 22 +- debug/DwarfUtil.ml | 12 +- debug/Dwarfgen.ml | 247 +++++++++++++++++++++ 8 files changed, 357 insertions(+), 617 deletions(-) delete mode 100644 debug/CtoDwarf.ml create mode 100644 debug/Dwarfgen.ml (limited to 'debug') diff --git a/debug/CtoDwarf.ml b/debug/CtoDwarf.ml deleted file mode 100644 index 3a325665..00000000 --- a/debug/CtoDwarf.ml +++ /dev/null @@ -1,540 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Bernhard Schommer, AbsInt Angewandte Informatik GmbH *) -(* *) -(* AbsInt Angewandte Informatik GmbH. All rights reserved. This file *) -(* is distributed under the terms of the INRIA Non-Commercial *) -(* License Agreement. *) -(* *) -(* *********************************************************************) - -open Builtins -open C -open Cprint -open Cutil -open C2C -open DwarfTypes -open DwarfUtil -open Env -open Set - -(* Functions to translate a C Ast into Dwarf 2 debugging information *) - -(* Hashtable from type name to entry id *) -let type_table: (string, int) Hashtbl.t = Hashtbl.create 7 - -(* Hashtable for typedefname to entry id *) -let typedef_table: (string, int) Hashtbl.t = Hashtbl.create 7 - -(* Hashtable from composite table to entry id *) -let composite_types_table: (int, int) Hashtbl.t = Hashtbl.create 7 - -(* Hashtable from id of a defined composite types to minimal type info *) -let composite_declarations: (int, (struct_or_union * string * location)) Hashtbl.t = Hashtbl.create 7 - -module IntSet = Set.Make(struct type t = int let compare = compare end) - -(* Set of all declared composite_types *) -let composite_defined: IntSet.t ref = ref IntSet.empty - -(* 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) - -(* Get the type id of a composite_type *) -let get_composite_type (name: int): int = - try - Hashtbl.find composite_types_table name - with Not_found -> - let id = next_id () in - Hashtbl.add composite_types_table name id; - id - -(* Translate a C.typ to a string needed for hashing *) -let typ_to_string (ty: typ) = - let buf = Buffer.create 7 in - let chan = Format.formatter_of_buffer buf in - typ chan ty; - Format.pp_print_flush chan (); - Buffer.contents buf - -let rec mmap f env = function - | [] -> ([],env) - | hd :: tl -> - let (hd',env1) = f env hd in - let (tl', env2) = mmap f env1 tl in - (hd' :: tl', env2) - - -(* Dwarf tag for the void type*) -let rec void_dwarf_tag = - let void = { - base_type_byte_size = 0; - base_type_encoding = None; - base_type_name = "void"; - } in - DW_TAG_base_type void - -(* Generate a dwarf tag for the given integer type *) -and int_to_dwarf_tag k = - let encoding = - (match k with - | IBool -> DW_ATE_boolean - | IChar -> - if !Machine.config.Machine.char_signed then - DW_ATE_signed_char - else - DW_ATE_unsigned_char - | ILong | ILongLong | IShort | ISChar -> DW_ATE_signed_char - | _ -> DW_ATE_unsigned)in - let int = { - base_type_byte_size = sizeof_ikind k; - base_type_encoding = Some encoding; - base_type_name = typ_to_string (TInt (k,[]));} in - DW_TAG_base_type int - -(* Generate a dwarf tag for the given floating point type *) -and float_to_dwarf_tag k = - let byte_size = sizeof_fkind k in - let float = { - base_type_byte_size = byte_size; - base_type_encoding = Some DW_ATE_float; - base_type_name = typ_to_string (TFloat (k,[])); - } in - DW_TAG_base_type float - -(* Generate a dwarf tag for the given function type *) -and fun_to_dwarf_tag rt args = - let ret,et = (match rt with - | TVoid _ -> None,[] - | _ -> let ret,et = type_to_dwarf rt in - Some ret,et) in - let prototyped,children,others = - (match args with - | None -> - let u = { - unspecified_parameter_file_loc = None; - unspecified_parameter_artificial = None; - } in - let u = new_entry (DW_TAG_unspecified_parameter u) in - false,[u],[] - | Some [] -> true,[],[] - | Some l -> - let c,e = mmap (fun acc (i,t) -> - let t,e = type_to_dwarf t in - let fp = - { - formal_parameter_id = i.stamp; - formal_parameter_file_loc = None; - formal_parameter_artificial = None; - formal_parameter_name = None; - formal_parameter_type = t; - formal_parameter_variable_parameter = None; - } in - let entry = new_entry (DW_TAG_formal_parameter fp) in - entry,(e@acc)) [] l in - true,c,e) in - let s = { - subroutine_type = ret; - subroutine_prototyped = prototyped; - } in - let s = new_entry (DW_TAG_subroutine_type s) in - let s = add_children s children in - s.id,((s::others)@et) - -(* Generate a dwarf tag for the given array type *) -and array_to_dwarf_tag child size = - let append_opt a b = - match a with - | None -> b - | Some a -> a::b in - let size_to_subrange s = - match s with - | None -> None - | Some i -> - let i = Int64.to_int (Int64.sub i Int64.one) in - let s = - { - subrange_type = None; - subrange_upper_bound = Some (BoundConst i); - } in - Some (new_entry (DW_TAG_subrange_type s)) in - let rec aux t = - (match t with - | TArray (child,size,_) -> - let sub = size_to_subrange size in - let t,c,e = aux child in - t,append_opt sub c,e - | _ -> let t,e = type_to_dwarf t in - t,[],e) in - let t,children,e = aux child in - let sub = size_to_subrange size in - let children = List.rev (append_opt sub children) in - let arr = { - array_type_file_loc = None; - array_type = t; - } in - let arr = new_entry (DW_TAG_array_type arr) in - let arr = add_children arr children in - arr.id,(arr::e) - -(* Translate a typ without attributes to a dwarf_tag *) -and type_to_dwarf_entry typ typ_string= - let id,entries = - (match typ with - | TVoid _ -> - let e = new_entry void_dwarf_tag in - e.id,[e] - | TInt (k,_) -> - let e = new_entry (int_to_dwarf_tag k) in - e.id,[e] - | TFloat (k,_) -> - let e = new_entry (float_to_dwarf_tag k) in - e.id,[e] - | TPtr (t,_) -> - let t,e = type_to_dwarf t in - let pointer = {pointer_type = t;} in - let t = new_entry (DW_TAG_pointer_type pointer) in - t.id,t::e - | TFun (rt,args,_,_) -> fun_to_dwarf_tag rt args - | TStruct (i,_) - | TUnion (i,_) - | TEnum (i,_) -> - let t = get_composite_type i.stamp in - t,[] - | TNamed (i,at) -> - let t = Hashtbl.find typedef_table i.name in - t,[] - | TArray (child,size,_) -> array_to_dwarf_tag child size) - in - Hashtbl.add type_table typ_string id; - id,entries - -(* Tranlate type with attributes to their corresponding dwarf represenation *) -and attr_type_to_dwarf typ typ_string = - let l,t = strip_last_attribute typ in - match l with - | Some AConst -> let id,t = type_to_dwarf t in - let const_tag = DW_TAG_const_type ({const_type = id;}) in - let const_entry = new_entry const_tag in - let id = const_entry.id in - Hashtbl.add type_table typ_string id; - id,const_entry::t - | Some AVolatile -> let id,t = type_to_dwarf t in - let volatile_tag = DW_TAG_volatile_type ({volatile_type = id;}) in - let volatile_entry = new_entry volatile_tag in - let id = volatile_entry.id in - Hashtbl.add type_table typ_string id; - id,volatile_entry::t - | Some (ARestrict|AAlignas _| Attr(_,_)) -> type_to_dwarf t (* This should not happen *) - | None -> type_to_dwarf_entry typ typ_string - -(* Translate a given type to its dwarf representation *) -and type_to_dwarf (typ: typ): int * dw_entry list = - match typ with - | TStruct (i,_) - | TUnion (i,_) - | TEnum (i,_) -> - let t = get_composite_type i.stamp in - t,[] - | _ -> - let typ = strip_attributes typ in - let typ_string = typ_to_string typ in - try - Hashtbl.find type_table typ_string,[] - with Not_found -> - attr_type_to_dwarf typ typ_string - -(* Translate a typedef to its corresponding dwarf representation *) -let typedef_to_dwarf gloc (name,t) = - let i,t = type_to_dwarf t in - let td = { - typedef_file_loc = gloc; - typedef_name = name; - typedef_type = i; - } in - let td = new_entry (DW_TAG_typedef td) in - Hashtbl.add typedef_table name td.id; - td::t - -(* Translate a global var to its corresponding dwarf representation *) -let glob_var_to_dwarf (s,n,t,_) gloc = - let i,t = type_to_dwarf t in - let at_decl = (match s with - | Storage_extern -> true - | _ -> false) in - let ext = (match s with - | Storage_static -> false - | _ -> true) in - let decl = { - variable_id = n.stamp; - variable_file_loc = (Some gloc); - variable_declaration = Some at_decl; - variable_external = Some ext; - variable_name = n.name; - variable_type = i; - } in - let decl = new_entry (DW_TAG_variable decl) in - t,decl - -(* Translate a function definition to its corresponding dwarf representation *) -let fundef_to_dwarf f gloc = - let ret,e = (match f.fd_ret with - | TVoid _ -> None,[] - | _ -> let i,t = type_to_dwarf f.fd_ret in - Some i,t) in - let ext = (match f.fd_storage with - | Storage_static -> false - | _ -> true) in - let fdef = { - subprogram_id = f.fd_name.stamp; - subprogram_file_loc = (Some gloc); - subprogram_external = Some ext; - subprogram_name = f.fd_name.name; - subprogram_prototyped = true; - subprogram_type = ret; - } in - let fp,e = mmap (fun acc (p,t) -> - let t,e = type_to_dwarf t in - let fp = - { - formal_parameter_id = p.stamp; - formal_parameter_file_loc = None; - formal_parameter_artificial = None; - formal_parameter_name = (Some p.name); - formal_parameter_type = t; - formal_parameter_variable_parameter = None; - } in - let entry = new_entry (DW_TAG_formal_parameter fp) in - entry,(e@acc)) e f.fd_params in - let fdef = new_entry (DW_TAG_subprogram fdef) in - let fdef = add_children fdef fp in - e,fdef - -(* Translate a enum definition to its corresponding dwarf representation *) -let enum_to_dwarf (n,at,e) gloc = - let enumerator_to_dwarf (i,c,_)= - let tag = - { - enumerator_file_loc = None; - enumerator_value = Int64.to_int c; - enumerator_name = i.name; - } in - new_entry (DW_TAG_enumerator tag) in - let bs = sizeof_ikind enum_ikind in - let enum = { - enumeration_file_loc = Some gloc; - enumeration_byte_size = bs; - enumeration_declaration = Some false; - enumeration_name = if n.name <> "" then Some n.name else None; - } in - let id = get_composite_type n.stamp in - let child = List.map enumerator_to_dwarf e in - let enum = - { - tag = DW_TAG_enumeration_type enum; - children = child; - id = id; - } in - [enum] - -(* Translate a struct definition to its corresponding dwarf representation *) -let struct_to_dwarf (n,at,m) env gloc = - let info = Env.find_struct env n in - let tag =DW_TAG_structure_type { - structure_file_loc = Some gloc; - structure_byte_size = info.ci_sizeof; - structure_declaration = Some false; - structure_name = if n.name <> "" then Some n.name else None; - } in - let id = get_composite_type n.stamp in - let rec pack acc bcc l m = - match m with - | [] -> acc,bcc,[] - | m::ms as ml -> - (match m.fld_bitfield with - | None -> acc,bcc,ml - | Some n -> - if n = 0 then - acc,bcc,ms (* bit width 0 means end of pack *) - else if l + n > 8 * !Machine.config.Machine.sizeof_int then - acc,bcc,ml (* doesn't fit in current word *) - else - let t,e = type_to_dwarf m.fld_typ in - let um = { - member_file_loc = None; - member_byte_size = Some !Machine.config.Machine.sizeof_int; - member_bit_offset = Some l; - member_bit_size = Some n; - member_data_member_location = None; - member_declaration = None; - member_name = if m.fld_name <> "" then Some m.fld_name else None; - member_type = t; - } in - pack ((new_entry (DW_TAG_member um))::acc) (e@bcc) (l + n) ms) - and translate acc bcc m = - match m with - [] -> acc,bcc - | m::ms as ml -> - (match m.fld_bitfield with - | None -> - let t,e = type_to_dwarf m.fld_typ in - let um = { - member_file_loc = None; - member_byte_size = None; - member_bit_offset = None; - member_bit_size = None; - member_data_member_location = None; - member_declaration = None; - member_name = if m.fld_name <> "" then Some m.fld_name else None; - member_type = t; - } in - translate ((new_entry (DW_TAG_member um))::acc) (e@bcc) ms - | Some _ -> let acc,bcc,rest = pack acc bcc 0 ml in - translate acc bcc rest) - in - let children,e = translate [] [] m in - let children,e = List.rev children,e in - let sou = { - tag = tag; - children = children; - id = id;} in - sou::e - -(* Translate a union definition to its corresponding dwarf representation *) -let union_to_dwarf (n,at,m) env gloc = - let info = Env.find_union env n in - let tag = DW_TAG_union_type { - union_file_loc = Some gloc; - union_byte_size = info.ci_sizeof; - union_declaration = Some false; - union_name = if n.name <> "" then Some n.name else None; - } in - let id = get_composite_type n.stamp in - let children,e = mmap - (fun acc f -> - let t,e = type_to_dwarf f.fld_typ in - let um = { - member_file_loc = None; - member_byte_size = None; - member_bit_offset = None; - member_bit_size = None; - member_data_member_location = None; - member_declaration = None; - member_name = if f.fld_name <> "" then Some f.fld_name else None; - member_type = t; - } in - new_entry (DW_TAG_member um),e@acc)[] m in - let sou = { - tag = tag; - children = children; - id = id;} in - sou::e - -(* Translate global declarations to there dwarf representation *) -let globdecl_to_dwarf env (typs,decls) decl = - PrintAsmaux.add_file (fst decl.gloc); - match decl.gdesc with - | Gtypedef (n,t) -> let ret = typedef_to_dwarf (Some decl.gloc) (n.name,t) in - typs@ret,decls - | Gdecl d -> let t,d = glob_var_to_dwarf d decl.gloc in - typs@t,d::decls - | Gfundef f -> let t,d = fundef_to_dwarf f decl.gloc in - typs@t,d::decls - | Genumdef (n,at,e) -> - composite_defined:= IntSet.add n.stamp !composite_defined; - let ret = enum_to_dwarf (n,at,e) decl.gloc in - typs@ret,decls - | Gcompositedef (Struct,n,at,m) -> - composite_defined:= IntSet.add n.stamp !composite_defined; - let ret = struct_to_dwarf (n,at,m) env decl.gloc in - typs@ret,decls - | Gcompositedef (Union,n,at,m) -> - composite_defined:= IntSet.add n.stamp !composite_defined; - let ret = union_to_dwarf (n,at,m) env decl.gloc in - typs@ret,decls - | Gcompositedecl (sou,i,_) -> Hashtbl.add composite_declarations i.stamp (sou,i.name,decl.gloc); - typs,decls - | Gpragma _ -> typs,decls - -let forward_declaration_to_dwarf sou name loc stamp = - let id = get_composite_type stamp in - let tag = match sou with - | Struct -> - DW_TAG_structure_type{ - structure_file_loc = Some loc; - structure_byte_size = None; - structure_declaration = Some true; - structure_name = if name <> "" then Some name else None; - } - | Union -> - DW_TAG_union_type { - union_file_loc = Some loc; - union_byte_size = None; - union_declaration = Some true; - union_name = if name <> "" then Some name else None; - } in - {tag = tag; children = []; id = id} - - -(* Compute the dwarf representations of global declarations. The second program argument is the - program after the bitfield and packed struct transformation *) -let program_to_dwarf prog prog1 name = - Hashtbl.reset type_table; - Hashtbl.reset composite_types_table; - Hashtbl.reset typedef_table; - let prog = cleanupGlobals (prog) in - let env = translEnv Env.empty prog1 in - reset_id (); - let typs = List.map (typedef_to_dwarf None) C2C.builtins.typedefs in - let typs = List.concat typs in - let typs,defs = List.fold_left (globdecl_to_dwarf env) (typs,[]) prog in - let typs = Hashtbl.fold (fun i (sou,name,loc) typs -> if not (IntSet.mem i !composite_defined) then - (forward_declaration_to_dwarf sou name loc i)::typs else typs) composite_declarations typs in - let defs = typs @ defs in - let cp = { - compile_unit_name = name; - } in - let cp = new_entry (DW_TAG_compile_unit cp) in - add_children cp defs diff --git a/debug/Debug.ml b/debug/Debug.ml index ab20f630..c45fd074 100644 --- a/debug/Debug.ml +++ b/debug/Debug.ml @@ -12,6 +12,8 @@ open C open Camlcoq +open Dwarfgen +open DwarfTypes (* Interface for generating and printing debug information *) @@ -25,7 +27,9 @@ type implem = 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 add_fun_addr: atom -> (int * int) -> unit; + mutable generate_debug_info: unit -> dw_entry option; + mutable all_files_iter: (string -> unit) -> unit; } let implem = @@ -38,7 +42,9 @@ let implem = set_bitfield_offset = (fun _ _ _ _ _ -> ()); insert_global_declaration = (fun _ _ -> ()); add_fun_addr = (fun _ _ -> ()); - } + generate_debug_info = (fun _ -> None); + all_files_iter = (fun _ -> ()); +} let init () = if !Clflags.option_g then begin @@ -50,6 +56,8 @@ let init () = 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 <- (fun () -> Some (Dwarfgen.gen_debug_info ())); + implem.all_files_iter <- (fun f -> DebugInformation.StringSet.iter f !DebugInformation.all_files); end else begin implem.init <- (fun _ -> ()); implem.atom_function <- (fun _ _ -> ()); @@ -58,7 +66,9 @@ let init () = implem.set_member_offset <- (fun _ _ _ -> ()); implem.set_bitfield_offset <- (fun _ _ _ _ _ -> ()); implem.insert_global_declaration <- (fun _ _ -> ()); - implem.add_fun_addr <- (fun _ _ -> ()) + implem.add_fun_addr <- (fun _ _ -> ()); + implem.generate_debug_info <- (fun _ -> None); + implem.all_files_iter <- (fun _ -> ()); end let init_compile_unit name = implem.init name @@ -69,3 +79,5 @@ 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 () = implem.generate_debug_info () +let all_files_iter f = implem.all_files_iter f diff --git a/debug/Debug.mli b/debug/Debug.mli index ae32af5b..e712874c 100644 --- a/debug/Debug.mli +++ b/debug/Debug.mli @@ -12,6 +12,7 @@ open C open Camlcoq +open DwarfTypes val init: unit -> unit @@ -23,3 +24,5 @@ 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 generate_debug_info: unit -> dw_entry option +val all_files_iter: (string -> unit) -> unit diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index 53f73115..100f37e2 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -30,6 +30,11 @@ let reset_id () = (* The name of the current compilation unit *) let file_name: string ref = ref "" +(** All files used in the debug entries *) +module StringSet = Set.Make(String) +let all_files : StringSet.t ref = ref StringSet.empty +let add_file file = + all_files := StringSet.add file !all_files (* Types for the information of type info *) type composite_field = @@ -45,11 +50,12 @@ type composite_field = type composite_type = { - ct_name: string; - ct_sou: struct_or_union; - ct_file_loc: location option; - ct_members: composite_field list; - ct_sizeof: int option; + ct_name: string; + ct_sou: struct_or_union; + ct_file_loc: location option; + ct_members: composite_field list; + ct_sizeof: int option; + ct_declaration: bool; } type ptr_type = { @@ -57,22 +63,23 @@ type ptr_type = { } type const_type = { - const_type: int + cst_type: int } type volatile_type = { - volatile_type: int + vol_type: int } type array_type = { arr_type: int; - arr_size: int64 option; + arr_size: int64 option list; } type typedef = { - typedef_name: string; - typ: int option; + typedef_file_loc: location option; + typedef_name: string; + typ: int option; } type enumerator = { @@ -101,7 +108,7 @@ type parameter_type = { } type function_type = { - fun_return_type: int; + fun_return_type: int option; fun_prototyped: bool; fun_params: parameter_type list; } @@ -215,6 +222,11 @@ let insert_type (ty: typ) = let id = attr_aux t in PointerType ({pts = id}) | TArray (t,s,_) -> + let rec size acc t = (match t with + | TArray (child,s,_) -> + size (s::acc) child + | _ -> t,List.rev acc) in + let t,s = size [s] t in let id = attr_aux t in let arr = { arr_type = id; @@ -229,7 +241,9 @@ let insert_type (ty: typ) = param_type = t; param_name = i.name; }) p,true) in - let ret = attr_aux t in + let ret = (match t with + | TVoid _ -> None + | _ -> Some (attr_aux t)) in let ftype = { fun_return_type = ret; fun_prototyped = prot; @@ -238,6 +252,7 @@ let insert_type (ty: typ) = FunctionType ftype | TNamed (id,_) -> let t = { + typedef_file_loc = None; typedef_name = id.name; typ = None; } in @@ -249,6 +264,7 @@ let insert_type (ty: typ) = ct_sou = Struct; ct_file_loc = None; ct_members = []; + ct_declaration = false; ct_sizeof = None; } in CompositeType str @@ -259,6 +275,7 @@ let insert_type (ty: typ) = ct_sou = Union; ct_file_loc = None; ct_members = []; + ct_declaration = false; ct_sizeof = None; } in CompositeType union @@ -280,11 +297,11 @@ let insert_type (ty: typ) = match strip_last_attribute ty with | Some AConst,t -> let id = attr_aux t in - let const = { const_type = id} in + let const = { cst_type = id} in insert (ConstType const) ty | Some AVolatile,t -> let id = attr_aux t in - let volatile = {volatile_type = id} in + let volatile = {vol_type = id} in insert (VolatileType volatile) ty | Some (ARestrict|AAlignas _| Attr(_,_)),t -> attr_aux t @@ -398,6 +415,7 @@ let gen_comp_typ sou id at = TUnion (id,at) let insert_global_declaration env dec= + add_file (fst dec.gloc); let insert d_dec stamp = let id = next_id () in Hashtbl.add definitions id d_dec; @@ -463,23 +481,24 @@ let insert_global_declaration env dec= | 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 *) let fields = List.map (fun f -> { cfd_name = f.fld_name; cfd_typ = insert_type f.fld_typ; - cfd_bit_size = None; - cfd_bit_offset = f.fld_bitfield; + cfd_bit_size = f.fld_bitfield; + cfd_bit_offset = None; cfd_byte_offset = None; cfd_byte_size = None; cfd_bitfield = None; }) fi in 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;}) + {comp with ct_file_loc = loc; ct_members = fields; ct_declaration = true;}) | Gtypedef (id,t) -> let id = insert_type (TNamed (id,[])) in let tid = insert_type t in - replace_typedef id (fun typ -> {typ with typ = Some tid;}); + replace_typedef id (fun typ -> {typ with typedef_file_loc = Some dec.gloc; typ = Some tid;}); | Genumdef (n,at,e) -> ignore(insert_type (TEnum (n,at))); let id = find_type (TEnum (n,[])) in @@ -516,18 +535,25 @@ let set_bitfield_offset str field offset underlying size = {comp with ct_members = members;}) let atom_global_variable id atom = - let id,var = find_var_stamp id.stamp in - replace_var id ({var with gvar_atom = Some atom;}); - Hashtbl.add atom_to_definition atom id + try + let id,var = find_var_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 = - 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 - + try + Printf.printf "Trying to add atom of function %s\n" id.name; + 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 + with Not_found -> () + let add_fun_addr atom (high,low) = - let id,f = find_fun_atom atom in - replace_fun id ({f with fun_high_pc = Some high; fun_low_pc = Some low;}) + try + let id,f = find_fun_atom atom in + replace_fun id ({f with fun_high_pc = Some high; fun_low_pc = Some low;}) + with Not_found -> Printf.printf "Could not find function %s\n" (extern_atom atom); () let init name = id := 0; diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index 09cf72eb..a0b16463 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -62,11 +62,6 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): let add_low_pc = add_abbr_entry (0x11,low_pc_type_abbr) - let add_fun_pc sp buf = - match get_fun_addr sp.subprogram_name with - | None ->() - | Some (a,b) -> add_high_pc buf; add_low_pc buf - let add_declaration = add_abbr_entry (0x3c,declaration_type_abbr) let add_location loc buf = @@ -128,7 +123,6 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): 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_location (get_location e.formal_parameter_id) buf; add_attr_some e.formal_parameter_name add_name; add_type buf; add_attr_some e.formal_parameter_variable_parameter (add_abbr_entry (0x4b,variable_parameter_type_abbr)) @@ -144,15 +138,15 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): 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 (0xd,bit_offset_type_abbr)); - add_attr_some e.member_bit_size (add_abbr_entry (0xc,bit_size_type_abbr)); + 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_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); - add_attr_some e.member_declaration add_declaration; - add_attr_some e.member_name add_name; - add_type buf + | Some (DataLocRef _) -> add_abbr_entry (0x38,data_location_ref_type_abbr) buf) | DW_TAG_pointer_type _ -> prologue 0xf; add_type buf @@ -164,10 +158,10 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): add_attr_some e.structure_name add_name | DW_TAG_subprogram e -> prologue 0x2e; - add_attr_some e.subprogram_file_loc add_file_loc; + add_file_loc buf; add_attr_some e.subprogram_external (add_abbr_entry (0x3f,external_type_abbr)); - add_high_pc buf; - add_low_pc buf; + add_attr_some e.subprogram_high_pc add_high_pc; + add_attr_some e.subprogram_low_pc add_low_pc; add_name buf; add_abbr_entry (0x27,prototyped_type_abbr) buf; add_attr_some e.subprogram_type add_type; @@ -199,10 +193,10 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): add_attr_some e.unspecified_parameter_artificial (add_abbr_entry (0x34,artificial_type_abbr)) | DW_TAG_variable e -> prologue 0x34; - add_attr_some e.variable_file_loc add_file_loc; + 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 (get_location e.variable_id) buf; + add_location e.variable_location buf; add_name buf; add_type buf | DW_TAG_volatile_type _ -> @@ -301,7 +295,12 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): | _ -> () let print_data_location oc dl = - () + match dl with + | DataLocBlock [DW_OP_plus_uconst i] -> + fprintf oc " .sleb128 2\n"; + fprintf oc " .byte 0x23\n"; + fprintf oc " .byte %d\n" i + | _ -> () let print_ref oc r = let ref = entry_to_label r in @@ -363,7 +362,6 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): 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 (get_location fp.formal_parameter_id) print_loc; 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 @@ -381,10 +379,11 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): 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_data_member_location print_data_location; print_opt_value oc mb.member_declaration print_flag; print_opt_value oc mb.member_name print_string; - print_ref oc mb.member_type + print_ref oc mb.member_type; + print_opt_value oc mb.member_data_member_location print_data_location + let print_pointer oc pt = print_ref oc pt.pointer_type @@ -400,11 +399,10 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): fprintf oc " .4byte %a\n" label s let print_subprogram oc sp = - let addr = get_fun_addr sp.subprogram_name in - print_file_loc oc sp.subprogram_file_loc; + print_file_loc oc (Some sp.subprogram_file_loc); print_opt_value oc sp.subprogram_external print_flag; - print_opt_value oc (get_frame_base sp.subprogram_id) print_loc; - print_opt_value oc addr print_subprogram_addr; + 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 @@ -433,10 +431,10 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): print_opt_value oc up.unspecified_parameter_artificial print_flag let print_variable oc var = - print_file_loc oc var.variable_file_loc; + 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 (get_location var.variable_id) print_loc; + print_opt_value oc var.variable_location print_loc; print_string oc var.variable_name; print_ref oc var.variable_type diff --git a/debug/DwarfTypes.mli b/debug/DwarfTypes.mli index b852d1f4..eb7d4060 100644 --- a/debug/DwarfTypes.mli +++ b/debug/DwarfTypes.mli @@ -37,13 +37,18 @@ type address = int type block = string +type location_expression = + | DW_OP_plus_uconst of constant + | DW_OP + + type location_value = | LocSymbol of atom | LocConst of constant | LocBlock of block type data_location_value = - | DataLocBlock of block + | DataLocBlock of location_expression list | DataLocRef of reference type bound_value = @@ -94,7 +99,6 @@ type dw_tag_enumerator = type dw_tag_formal_parameter = { - formal_parameter_id: int; formal_parameter_file_loc: file_loc option; formal_parameter_artificial: flag option; formal_parameter_name: string option; @@ -141,12 +145,13 @@ type dw_tag_structure_type = type dw_tag_subprogram = { - subprogram_id: int; - subprogram_file_loc: file_loc option; - subprogram_external: flag option; + subprogram_file_loc: file_loc; + subprogram_external: flag option; subprogram_name: string; subprogram_prototyped: flag; - subprogram_type: reference option; + subprogram_type: reference option; + subprogram_high_pc: reference option; + subprogram_low_pc: reference option; } type dw_tag_subrange_type = @@ -184,12 +189,12 @@ type dw_tag_unspecified_parameter = type dw_tag_variable = { - variable_id: int; - variable_file_loc: file_loc option; + variable_file_loc: file_loc; variable_declaration: flag option; variable_external: flag option; variable_name: string; variable_type: reference; + variable_location: location_value option; } type dw_tag_volatile_type = @@ -268,7 +273,6 @@ module type DWARF_TARGET= val get_end_addr: unit -> int val get_stmt_list_addr: unit -> int val name_of_section: section_name -> string - val get_fun_addr: string -> (int * int) option val get_location: int -> location_value option val get_frame_base: int -> location_value option val symbol: out_channel -> atom -> unit diff --git a/debug/DwarfUtil.ml b/debug/DwarfUtil.ml index e2c87a9d..d5e72adb 100644 --- a/debug/DwarfUtil.ml +++ b/debug/DwarfUtil.ml @@ -14,18 +14,8 @@ open DwarfTypes -let id = ref 0 - -let next_id () = - let nid = !id in - incr id; nid - -let reset_id () = - id := 0 - (* Generate a new entry from a given tag *) -let new_entry tag = - let id = next_id () in +let new_entry id tag = { tag = tag; children = []; diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml new file mode 100644 index 00000000..0acab05a --- /dev/null +++ b/debug/Dwarfgen.ml @@ -0,0 +1,247 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Bernhard Schommer, AbsInt Angewandte Informatik GmbH *) +(* *) +(* AbsInt Angewandte Informatik GmbH. All rights reserved. This file *) +(* is distributed under the terms of the INRIA Non-Commercial *) +(* License Agreement. *) +(* *) +(* *********************************************************************) + +open C +open Cutil +open DebugInformation +open DwarfTypes +open DwarfUtil +(* Generate the dwarf DIE's from the information collected in DebugInformation *) + +(* Helper function to get values that must be set. *) +let get_opt_val = function + | Some a -> a + | None -> assert false + +(* 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) + +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 typedef_to_entry id t = + let i = get_opt_val t.typ in + let td = { + typedef_file_loc = t.typedef_file_loc; + typedef_name = t.typedef_name; + typedef_type = i; + } in + new_entry id (DW_TAG_typedef td) + +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_file_loc = None; + 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 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 + new_entry (next_id ()) (DW_TAG_enumerator tag) in + let bs = sizeof_ikind enum_ikind in + let enum = { + enumeration_file_loc = 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_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; + formal_parameter_variable_parameter = 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_file_loc = None; + 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 = Some (DataLocBlock [DW_OP_plus_uconst (get_opt_val mem.cfd_byte_offset)]); + 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 id s = + let tag = { + structure_file_loc = s.ct_file_loc; + structure_byte_size = s.ct_sizeof; + structure_declaration = Some s.ct_declaration; + 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 id s = + let tag = { + union_file_loc = s.ct_file_loc; + union_byte_size = s.ct_sizeof; + union_declaration = Some s.ct_declaration; + 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 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 gen_types () = + List.rev (Hashtbl.fold (fun id t acc -> (infotype_to_entry id t)::acc) types []) + +let global_variable_to_entry id v = + let var = { + variable_file_loc = 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 = match v.gvar_atom with Some a -> Some (LocSymbol a) | None -> None; + } in + new_entry id (DW_TAG_variable var) + +let function_parameter_to_entry p = + let p = { + formal_parameter_file_loc = None; + formal_parameter_artificial = None; + formal_parameter_name = Some p.parameter_name; + formal_parameter_type = p.parameter_type; + formal_parameter_variable_parameter = None; + } in + new_entry (next_id ()) (DW_TAG_formal_parameter p) + +let function_to_entry id f = + let f_tag = { + subprogram_file_loc = 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_entry = new_entry id (DW_TAG_subprogram f_tag) in + let child = List.map function_parameter_to_entry f.fun_parameter in + add_children f_entry child + +let definition_to_entry id t = + match t with + | GlobalVariable g -> global_variable_to_entry id g + | Function f -> function_to_entry id f + +let gen_defs () = + List.rev (Hashtbl.fold (fun id t acc -> (definition_to_entry id t)::acc) definitions []) + +let gen_debug_info () = + let cp = { + compile_unit_name = !file_name; + } in + let cp = new_entry (next_id ()) (DW_TAG_compile_unit cp) in + add_children cp ((gen_types ()) @ (gen_defs ())) -- cgit From 31aceeb1be64d529432f35bbea16ebafc3a21df0 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Fri, 18 Sep 2015 16:42:05 +0200 Subject: Started implementing the scope for the Debug Informations. Scopes will be handled by a stack of all open scopes. This stack then can also be used to generate the debug directives to track the scopes through the rest of the passes. --- debug/Debug.ml | 10 ++++++ debug/Debug.mli | 2 ++ debug/DebugInformation.ml | 89 +++++++++++++++++++++++++++++++++++++++++------ debug/Dwarfgen.ml | 16 +++++++-- 4 files changed, 105 insertions(+), 12 deletions(-) (limited to 'debug') diff --git a/debug/Debug.ml b/debug/Debug.ml index c45fd074..bf3892d2 100644 --- a/debug/Debug.ml +++ b/debug/Debug.ml @@ -30,6 +30,8 @@ type implem = mutable add_fun_addr: atom -> (int * int) -> unit; mutable generate_debug_info: unit -> dw_entry option; mutable all_files_iter: (string -> unit) -> unit; + mutable insert_local_declaration: storage -> ident -> typ -> location -> unit; + mutable atom_local_variable: ident -> atom -> unit; } let implem = @@ -44,6 +46,8 @@ let implem = add_fun_addr = (fun _ _ -> ()); generate_debug_info = (fun _ -> None); all_files_iter = (fun _ -> ()); + insert_local_declaration = (fun _ _ _ _ -> ()); + atom_local_variable = (fun _ _ -> ()); } let init () = @@ -58,6 +62,8 @@ let init () = implem.add_fun_addr <- DebugInformation.add_fun_addr; implem.generate_debug_info <- (fun () -> Some (Dwarfgen.gen_debug_info ())); 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; end else begin implem.init <- (fun _ -> ()); implem.atom_function <- (fun _ _ -> ()); @@ -69,6 +75,8 @@ let init () = 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 _ _ -> ()); end let init_compile_unit name = implem.init name @@ -81,3 +89,5 @@ 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 () = implem.generate_debug_info () 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 diff --git a/debug/Debug.mli b/debug/Debug.mli index e712874c..69894ba7 100644 --- a/debug/Debug.mli +++ b/debug/Debug.mli @@ -26,3 +26,5 @@ val insert_global_declaration: Env.t -> globdecl -> unit val add_fun_addr: atom -> (int * int) -> unit val generate_debug_info: unit -> dw_entry option val all_files_iter: (string -> unit) -> unit +val insert_local_declaration: storage -> ident -> typ -> location -> unit +val atom_local_variable: ident -> atom -> unit diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index 100f37e2..38ce6e64 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -360,7 +360,6 @@ type function_information = { fun_return_type: int option; (* Again the special case of void functions *) fun_vararg: bool; fun_parameter: parameter_information list; - fun_locals: int list; fun_low_pc: int option; fun_high_pc: int option; } @@ -369,7 +368,8 @@ type definition_type = | GlobalVariable of global_variable_information | Function of function_information -(* All definitions encountered *) + +(* All global definitions encountered *) let definitions: (int,definition_type) Hashtbl.t = Hashtbl.create 7 (* Mapping from stamp to debug id *) @@ -378,7 +378,7 @@ let stamp_to_definition: (int,int) Hashtbl.t = Hashtbl.create 7 (* Mapping from atom to debug id *) let atom_to_definition: (atom, int) Hashtbl.t = Hashtbl.create 7 -let find_var_stamp id = +let find_gvar_stamp id = let id = (Hashtbl.find stamp_to_definition id) in let var = Hashtbl.find definitions id in match var with @@ -399,7 +399,6 @@ let find_fun_atom id = | Function f -> id,f | _ -> assert false - let replace_var id var = let var = GlobalVariable var in Hashtbl.replace definitions id var @@ -408,6 +407,45 @@ let replace_fun id f = let f = Function f in Hashtbl.replace definitions id f + +(* Information for local variables *) +type local_variable_information = { + lvar_name: string; + lvar_atom: atom option; + lvar_file_loc:location; + lvar_type: int; + lvar_static: bool; (* Static variable are mapped to symbols *) + } + +type scope_information = + { + scope_variables: int list; (* Variable and Scope ids *) + } + +type local_information = + | LocalVariable of local_variable_information + | Scope of scope_information + +(* All local variables *) +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 + +let find_lvar_stamp id = + let id = (Hashtbl.find stamp_to_local id) in + let v = Hashtbl.find local_variables id in + match v with + | LocalVariable v -> id,v + | _ -> assert false + +let replace_lvar id var = + let var = LocalVariable var in + Hashtbl.replace local_variables id var + let gen_comp_typ sou id at = if sou = Struct then TStruct (id,at) @@ -440,7 +478,7 @@ let insert_global_declaration env dec= } in insert (GlobalVariable decl) id.stamp end else if init <> None || sto <> Storage_extern then begin (* It is a definition *) - let id,var = find_var_stamp id.stamp in + let id,var = find_gvar_stamp id.stamp in replace_var id ({var with gvar_declaration = false;}) end end @@ -467,7 +505,6 @@ let insert_global_declaration env dec= fun_return_type = ret; fun_vararg = f.fd_vararg; fun_parameter = params; - fun_locals = []; fun_low_pc = None; fun_high_pc = None; } in @@ -536,14 +573,13 @@ let set_bitfield_offset str field offset underlying size = let atom_global_variable id atom = try - let id,var = find_var_stamp id.stamp in + 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 - Printf.printf "Trying to add atom of function %s\n" id.name; 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 @@ -553,7 +589,37 @@ let add_fun_addr atom (high,low) = try let id,f = find_fun_atom atom in replace_fun id ({f with fun_high_pc = Some high; fun_low_pc = Some low;}) - with Not_found -> Printf.printf "Could not find function %s\n" (extern_atom atom); () + with Not_found -> () + +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 + with Not_found -> () + +let insert_local_declaration sto id ty loc = + let ty = find_type ty in + let var = { + lvar_name = id.name; + lvar_atom = None; + lvar_file_loc = loc; + lvar_type = ty; + lvar_static = sto = Storage_static; + } in + let id' = next_id () in + Hashtbl.add local_variables id' (LocalVariable var); + Hashtbl.add stamp_to_local id.stamp id' + +let scopes: (int * scope_information) Stack.t = Stack.create () + +let enter_scope id = + let empty_scope = {scope_variables = [];} in + Stack.push (id,empty_scope) scopes + +let enter_function_scope id = + Stack.clear scopes; + enter_scope id let init name = id := 0; @@ -562,5 +628,8 @@ let init name = Hashtbl.reset lookup_types; Hashtbl.reset definitions; Hashtbl.reset stamp_to_definition; - Hashtbl.reset atom_to_definition + Hashtbl.reset atom_to_definition; + Hashtbl.reset local_variables; + Hashtbl.reset stamp_to_local; + Hashtbl.reset atom_to_local diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml index 0acab05a..bb0ab5f2 100644 --- a/debug/Dwarfgen.ml +++ b/debug/Dwarfgen.ml @@ -217,6 +217,17 @@ let function_parameter_to_entry p = } in new_entry (next_id ()) (DW_TAG_formal_parameter p) +let local_variable_to_entry v id = + let var = { + variable_file_loc = v.lvar_file_loc; + variable_declaration = None; + variable_external = None; + variable_name = v.lvar_name; + variable_type = v.lvar_type; + variable_location = None; + } in + new_entry id (DW_TAG_variable var) + let function_to_entry id f = let f_tag = { subprogram_file_loc = f.fun_file_loc; @@ -228,8 +239,9 @@ let function_to_entry id f = subprogram_low_pc = f.fun_low_pc; } in let f_entry = new_entry id (DW_TAG_subprogram f_tag) in - let child = List.map function_parameter_to_entry f.fun_parameter in - add_children f_entry child + let params = List.map function_parameter_to_entry f.fun_parameter in +(* let vars = List.map local_variable_to_entry f.fun_locals in*) + add_children f_entry params let definition_to_entry id t = match t with -- cgit From a34b64ee2e7a535ebc0fc731243ab520c4ba430f Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Sun, 20 Sep 2015 15:36:42 +0200 Subject: New version of adding scopes etc. Instead of reimplementing the whole scope handling in the debug information use the existing functionality and fill the scopes explicitly in the functions. --- debug/Debug.ml | 18 ++++++++++++---- debug/Debug.mli | 4 +++- debug/DebugInformation.ml | 55 ++++++++++++++++++++++++++++++++++++++--------- 3 files changed, 62 insertions(+), 15 deletions(-) (limited to 'debug') diff --git a/debug/Debug.ml b/debug/Debug.ml index bf3892d2..10b4e68f 100644 --- a/debug/Debug.ml +++ b/debug/Debug.ml @@ -30,8 +30,10 @@ type implem = mutable add_fun_addr: atom -> (int * int) -> unit; mutable generate_debug_info: unit -> dw_entry option; mutable all_files_iter: (string -> unit) -> unit; - mutable insert_local_declaration: storage -> ident -> typ -> location -> unit; + mutable insert_local_declaration: int -> storage -> ident -> typ -> location -> unit; mutable atom_local_variable: ident -> atom -> unit; + mutable enter_scope: int -> int -> unit; + mutable enter_function_scope: ident -> int -> unit; } let implem = @@ -46,8 +48,10 @@ let implem = add_fun_addr = (fun _ _ -> ()); generate_debug_info = (fun _ -> None); all_files_iter = (fun _ -> ()); - insert_local_declaration = (fun _ _ _ _ -> ()); + insert_local_declaration = (fun _ _ _ _ _ -> ()); atom_local_variable = (fun _ _ -> ()); + enter_scope = (fun _ _ -> ()); + enter_function_scope = (fun _ _ -> ()); } let init () = @@ -64,6 +68,8 @@ let init () = 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; end else begin implem.init <- (fun _ -> ()); implem.atom_function <- (fun _ _ -> ()); @@ -75,8 +81,10 @@ let init () = implem.add_fun_addr <- (fun _ _ -> ()); implem.generate_debug_info <- (fun _ -> None); implem.all_files_iter <- (fun _ -> ()); - implem.insert_local_declaration <- (fun _ _ _ _ -> ()); + implem.insert_local_declaration <- (fun _ _ _ _ _ -> ()); implem.atom_local_variable <- (fun _ _ -> ()); + implem.enter_scope <- (fun _ _ -> ()); + implem.enter_function_scope <- (fun _ _ -> ()); end let init_compile_unit name = implem.init name @@ -89,5 +97,7 @@ 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 () = implem.generate_debug_info () 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 insert_local_declaration scope sto id ty loc = implem.insert_local_declaration scope 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 diff --git a/debug/Debug.mli b/debug/Debug.mli index 69894ba7..087f073f 100644 --- a/debug/Debug.mli +++ b/debug/Debug.mli @@ -26,5 +26,7 @@ val insert_global_declaration: Env.t -> globdecl -> unit val add_fun_addr: atom -> (int * int) -> unit val generate_debug_info: unit -> dw_entry option val all_files_iter: (string -> unit) -> unit -val insert_local_declaration: storage -> ident -> typ -> location -> unit +val insert_local_declaration: int -> storage -> ident -> typ -> location -> unit val atom_local_variable: ident -> atom -> unit +val enter_scope: int -> int -> unit +val enter_function_scope: ident -> int -> unit diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index 38ce6e64..a85f2081 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -362,6 +362,7 @@ type function_information = { fun_parameter: parameter_information list; fun_low_pc: int option; fun_high_pc: int option; + fun_scope: int option; } type definition_type = @@ -435,6 +436,9 @@ 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 to debug id *) +let scope_to_local: (int,int) Hashtbl.t = Hashtbl.create 7 + let find_lvar_stamp id = let id = (Hashtbl.find stamp_to_local id) in let v = Hashtbl.find local_variables id in @@ -446,6 +450,17 @@ let replace_lvar id var = let var = LocalVariable var in Hashtbl.replace local_variables id var +let find_scope_id id = + let id = (Hashtbl.find scope_to_local id) in + let v = Hashtbl.find local_variables id in + match v with + | Scope v -> id,v + | _ -> assert false + +let replace_scope id var = + let var = Scope var in + Hashtbl.replace local_variables id var + let gen_comp_typ sou id at = if sou = Struct then TStruct (id,at) @@ -507,6 +522,7 @@ let insert_global_declaration env dec= fun_parameter = params; fun_low_pc = None; fun_high_pc = None; + fun_scope = None; } in insert (Function fd) f.fd_name.stamp | Gcompositedecl (sou,id,at) -> @@ -598,7 +614,13 @@ let atom_local_variable id atom = Hashtbl.add atom_to_local atom id with Not_found -> () -let insert_local_declaration sto id ty loc = +let add_lvar_scope var_id s_id = + try + let s_id',scope = find_scope_id s_id in + replace_scope s_id' ({scope_variables = var_id::scope.scope_variables;}) + with Not_found -> () + +let insert_local_declaration scope sto id ty loc = let ty = find_type ty in let var = { lvar_name = id.name; @@ -609,17 +631,29 @@ let insert_local_declaration sto id ty loc = } in let id' = next_id () in Hashtbl.add local_variables id' (LocalVariable var); - Hashtbl.add stamp_to_local id.stamp id' + Hashtbl.add stamp_to_local id.stamp id'; + add_lvar_scope id' scope -let scopes: (int * scope_information) Stack.t = Stack.create () +let new_scope sc_id = + let scope = {scope_variables = [];} in + let id = next_id () in + Hashtbl.add local_variables id (Scope scope); + Hashtbl.add scope_to_local sc_id id; + id -let enter_scope id = - let empty_scope = {scope_variables = [];} in - Stack.push (id,empty_scope) scopes +let enter_function_scope fun_id sc_id = + try + let id = new_scope sc_id in + let fun_id,f = find_fun_stamp fun_id.stamp in + replace_fun id ({f with fun_scope = Some id}) + with Not_found -> () -let enter_function_scope id = - Stack.clear scopes; - enter_scope id +let enter_scope p_id id = + try + let id' = new_scope id in + let p_id',scope = find_scope_id p_id in + replace_scope p_id' ({scope_variables = id'::scope.scope_variables;}) + with Not_found -> () let init name = id := 0; @@ -631,5 +665,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 atom_to_local; + Hashtbl.reset scope_to_local; -- cgit From d7f75509c290d871cb8cd8aa11a0be2923c9ef17 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Tue, 22 Sep 2015 19:44:47 +0200 Subject: Record the scope structure during unblocking. Instead of creating separate annotations for the local variables we call the Debug.add_lvar_scope and we construct a mapping from function id + scope id to scope information. --- debug/Debug.ml | 19 +++++--- debug/Debug.mli | 5 +- debug/DebugInformation.ml | 39 ++++++++-------- debug/DwarfPrinter.ml | 12 ++--- debug/DwarfTypes.mli | 4 +- debug/Dwarfgen.ml | 117 +++++++++++++++++++++++++++++++++++++++------- 6 files changed, 142 insertions(+), 54 deletions(-) (limited to 'debug') diff --git a/debug/Debug.ml b/debug/Debug.ml index 10b4e68f..eb616dab 100644 --- a/debug/Debug.ml +++ b/debug/Debug.ml @@ -30,10 +30,11 @@ type implem = mutable add_fun_addr: atom -> (int * int) -> unit; mutable generate_debug_info: unit -> dw_entry option; mutable all_files_iter: (string -> unit) -> unit; - mutable insert_local_declaration: int -> storage -> ident -> typ -> location -> unit; + mutable insert_local_declaration: storage -> ident -> typ -> location -> unit; mutable atom_local_variable: ident -> atom -> unit; - mutable enter_scope: int -> int -> unit; + mutable enter_scope: int -> int -> int -> unit; mutable enter_function_scope: ident -> int -> unit; + mutable add_lvar_scope: int -> ident -> int -> unit; } let implem = @@ -48,10 +49,11 @@ let implem = add_fun_addr = (fun _ _ -> ()); generate_debug_info = (fun _ -> None); all_files_iter = (fun _ -> ()); - insert_local_declaration = (fun _ _ _ _ _ -> ()); + insert_local_declaration = (fun _ _ _ _ -> ()); atom_local_variable = (fun _ _ -> ()); - enter_scope = (fun _ _ -> ()); + enter_scope = (fun _ _ _ -> ()); enter_function_scope = (fun _ _ -> ()); + add_lvar_scope = (fun _ _ _ -> ()); } let init () = @@ -70,6 +72,7 @@ let init () = 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; end else begin implem.init <- (fun _ -> ()); implem.atom_function <- (fun _ _ -> ()); @@ -81,10 +84,11 @@ let init () = implem.add_fun_addr <- (fun _ _ -> ()); implem.generate_debug_info <- (fun _ -> None); implem.all_files_iter <- (fun _ -> ()); - implem.insert_local_declaration <- (fun _ _ _ _ _ -> ()); + implem.insert_local_declaration <- (fun _ _ _ _ -> ()); implem.atom_local_variable <- (fun _ _ -> ()); - implem.enter_scope <- (fun _ _ -> ()); + implem.enter_scope <- (fun _ _ _ -> ()); implem.enter_function_scope <- (fun _ _ -> ()); + implem.add_lvar_scope <- (fun _ _ _ -> ()); end let init_compile_unit name = implem.init name @@ -97,7 +101,8 @@ 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 () = implem.generate_debug_info () let all_files_iter f = implem.all_files_iter f -let insert_local_declaration scope sto id ty loc = implem.insert_local_declaration scope sto id ty loc +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 diff --git a/debug/Debug.mli b/debug/Debug.mli index 087f073f..a7d40382 100644 --- a/debug/Debug.mli +++ b/debug/Debug.mli @@ -26,7 +26,8 @@ val insert_global_declaration: Env.t -> globdecl -> unit val add_fun_addr: atom -> (int * int) -> unit val generate_debug_info: unit -> dw_entry option val all_files_iter: (string -> unit) -> unit -val insert_local_declaration: int -> storage -> ident -> typ -> location -> unit +val insert_local_declaration: storage -> ident -> typ -> location -> unit val atom_local_variable: ident -> atom -> unit -val enter_scope: int -> int -> unit +val enter_scope: int -> int -> int -> unit val enter_function_scope: ident -> int -> unit +val add_lvar_scope: int -> ident -> int -> unit diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index a85f2081..d8d608af 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -136,10 +136,9 @@ let lookup_types: (string, int) Hashtbl.t = Hashtbl.create 7 let typ_to_string (ty: typ) = let buf = Buffer.create 7 in let chan = Format.formatter_of_buffer buf in - let old = !Cprint.print_idents_in_full in - Cprint.print_idents_in_full := true; + Cprint.print_debug_idents := true; Cprint.typ chan ty; - Cprint.print_idents_in_full := old; + Cprint.print_debug_idents := false; Format.pp_print_flush chan (); Buffer.contents buf @@ -436,8 +435,10 @@ 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 to debug id *) -let scope_to_local: (int,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 + +(* Map from scope id + function atom to debug id *) let find_lvar_stamp id = let id = (Hashtbl.find stamp_to_local id) in @@ -450,8 +451,8 @@ let replace_lvar id var = let var = LocalVariable var in Hashtbl.replace local_variables id var -let find_scope_id id = - let id = (Hashtbl.find scope_to_local id) in +let find_scope_id fid id = + let id = Hashtbl.find scope_to_local (fid,id) in let v = Hashtbl.find local_variables id in match v with | Scope v -> id,v @@ -614,14 +615,15 @@ let atom_local_variable id atom = Hashtbl.add atom_to_local atom id with Not_found -> () -let add_lvar_scope var_id s_id = +let add_lvar_scope f_id var_id s_id = try - let s_id',scope = find_scope_id s_id in + let s_id',scope = find_scope_id f_id s_id 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 -> () -let insert_local_declaration scope sto id ty loc = - let ty = find_type ty in +let insert_local_declaration sto id ty loc = + let ty = insert_type ty in let var = { lvar_name = id.name; lvar_atom = None; @@ -631,27 +633,26 @@ let insert_local_declaration scope sto id ty loc = } in let id' = next_id () in Hashtbl.add local_variables id' (LocalVariable var); - Hashtbl.add stamp_to_local id.stamp id'; - add_lvar_scope id' scope + Hashtbl.add stamp_to_local id.stamp id' -let new_scope sc_id = +let new_scope f_id sc_id = let scope = {scope_variables = [];} in let id = next_id () in Hashtbl.add local_variables id (Scope scope); - Hashtbl.add scope_to_local sc_id id; + Hashtbl.add scope_to_local (f_id,sc_id) id; id let enter_function_scope fun_id sc_id = try - let id = new_scope sc_id in + let id = new_scope fun_id.stamp sc_id in let fun_id,f = find_fun_stamp fun_id.stamp in replace_fun id ({f with fun_scope = Some id}) with Not_found -> () -let enter_scope p_id id = +let enter_scope f_id p_id id = try - let id' = new_scope id in - let p_id',scope = find_scope_id p_id in + let id' = new_scope f_id id in + let p_id',scope = find_scope_id f_id p_id in replace_scope p_id' ({scope_variables = id'::scope.scope_variables;}) with Not_found -> () diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index 5e58e365..f3cfdc6e 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -132,10 +132,10 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): prologue 0xa; add_low_pc buf; add_name buf; - | DW_TAG_lexical_block _ -> + | DW_TAG_lexical_block a -> prologue 0xb; - add_high_pc buf; - add_low_pc buf + 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; add_attr_some e.member_file_loc add_file_loc; @@ -373,8 +373,8 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): print_string oc tl.label_name let print_lexical_block oc lb = - print_ref oc lb.lexical_block_high_pc; - print_ref oc lb.lexical_block_low_pc + print_opt_value oc lb.lexical_block_high_pc print_ref; + print_opt_value oc lb.lexical_block_low_pc print_ref let print_member oc mb = print_file_loc oc mb.member_file_loc; @@ -488,7 +488,7 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): print_abbrev oc (* Print the debug info section *) - let print_debug_info oc entry = + let print_debug_info oc entry = let debug_start = new_label () in debug_start_addr:= debug_start; fprintf oc" .section %s\n" (name_of_section Section_debug_info); diff --git a/debug/DwarfTypes.mli b/debug/DwarfTypes.mli index b5be3121..1d41403b 100644 --- a/debug/DwarfTypes.mli +++ b/debug/DwarfTypes.mli @@ -114,8 +114,8 @@ type dw_tag_label = type dw_tag_lexical_block = { - lexical_block_high_pc: address; - lexical_block_low_pc: address; + lexical_block_high_pc: address option; + lexical_block_low_pc: address option; } type dw_tag_member = diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml index bb0ab5f2..8e29fcaf 100644 --- a/debug/Dwarfgen.ml +++ b/debug/Dwarfgen.ml @@ -22,6 +22,19 @@ let get_opt_val = function | Some a -> a | None -> assert false +(* Auxiliary data structures and functions *) +module IntSet = Set.Make(struct + type t = int + let compare (x:int) (y:int) = compare x y +end) + +let rec mmap f env = function + | [] -> ([],env) + | hd :: tl -> + let (hd',env1) = f env hd in + let (tl', env2) = mmap f env1 tl in + (hd' :: tl', env2) + (* Functions to translate the basetypes. *) let int_type_to_entry id i = let encoding = @@ -146,7 +159,10 @@ let member_to_entry 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 = Some (DataLocBlock [DW_OP_plus_uconst (get_opt_val mem.cfd_byte_offset)]); + 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; @@ -193,10 +209,57 @@ let infotype_to_entry id = function | VolatileType v -> volatile_to_entry id v | Void -> void_to_entry id -let gen_types () = - List.rev (Hashtbl.fold (fun id t acc -> (infotype_to_entry id t)::acc) types []) +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 global_variable_to_entry id v = +let global_variable_to_entry acc id v = let var = { variable_file_loc = v.gvar_file_loc; variable_declaration = Some v.gvar_declaration; @@ -205,9 +268,9 @@ let global_variable_to_entry id v = variable_type = v.gvar_type; variable_location = match v.gvar_atom with Some a -> Some (LocSymbol a) | None -> None; } in - new_entry id (DW_TAG_variable var) + new_entry id (DW_TAG_variable var),IntSet.add v.gvar_type acc -let function_parameter_to_entry p = +let function_parameter_to_entry acc p = let p = { formal_parameter_file_loc = None; formal_parameter_artificial = None; @@ -215,9 +278,9 @@ let function_parameter_to_entry p = formal_parameter_type = p.parameter_type; formal_parameter_variable_parameter = None; } in - new_entry (next_id ()) (DW_TAG_formal_parameter p) + new_entry (next_id ()) (DW_TAG_formal_parameter p),IntSet.add p.formal_parameter_type acc -let local_variable_to_entry v id = +let rec local_variable_to_entry acc v id = let var = { variable_file_loc = v.lvar_file_loc; variable_declaration = None; @@ -226,9 +289,23 @@ let local_variable_to_entry v id = variable_type = v.lvar_type; variable_location = None; } in - new_entry id (DW_TAG_variable var) + new_entry id (DW_TAG_variable var),IntSet.add v.lvar_type acc + +and scope_to_entry acc sc id = + let scope = { + lexical_block_high_pc = None; + lexical_block_low_pc = None; + } in + let vars,acc = mmap local_to_entry 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 acc id = + match Hashtbl.find local_variables id with + | LocalVariable v -> local_variable_to_entry acc v id + | Scope v -> scope_to_entry acc v id -let function_to_entry id f = +let function_to_entry acc id f = let f_tag = { subprogram_file_loc = f.fun_file_loc; subprogram_external = Some f.fun_external; @@ -238,22 +315,26 @@ let function_to_entry id f = subprogram_high_pc = f.fun_high_pc; subprogram_low_pc = f.fun_low_pc; } in - let f_entry = new_entry id (DW_TAG_subprogram f_tag) in - let params = List.map function_parameter_to_entry f.fun_parameter 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 = mmap function_parameter_to_entry acc f.fun_parameter in (* let vars = List.map local_variable_to_entry f.fun_locals in*) - add_children f_entry params + add_children f_entry params,acc -let definition_to_entry id t = +let definition_to_entry acc id t = match t with - | GlobalVariable g -> global_variable_to_entry id g - | Function f -> function_to_entry id f + | GlobalVariable g -> global_variable_to_entry acc id g + | Function f -> function_to_entry acc id f let gen_defs () = - List.rev (Hashtbl.fold (fun id t acc -> (definition_to_entry id t)::acc) definitions []) + let defs,typ = Hashtbl.fold (fun id t (acc,bcc) -> let t,bcc = definition_to_entry bcc id t in + t::acc,bcc) definitions ([],IntSet.empty) in + List.rev defs,typ let gen_debug_info () = let cp = { compile_unit_name = !file_name; } in let cp = new_entry (next_id ()) (DW_TAG_compile_unit cp) in - add_children cp ((gen_types ()) @ (gen_defs ())) + let defs,ty = gen_defs () in + add_children cp ((gen_types ty) @ defs) -- cgit From b448fbba97c1008599610d0c9bc834881b9dc219 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Wed, 23 Sep 2015 16:49:13 +0200 Subject: Added support for printing local variables and fixed issue with .text Local variables are now added with bogus lexical scopes to reflect the actually lexical scopes. Also this commit fixes assembler problems of the das when a user section with the name ".text" is defined. --- debug/Debug.ml | 2 +- debug/Debug.mli | 2 +- debug/DebugInformation.ml | 8 +++++--- debug/Dwarfgen.ml | 16 +++++++++++++--- 4 files changed, 20 insertions(+), 8 deletions(-) (limited to 'debug') diff --git a/debug/Debug.ml b/debug/Debug.ml index eb616dab..c2b48618 100644 --- a/debug/Debug.ml +++ b/debug/Debug.ml @@ -33,7 +33,7 @@ type implem = 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: ident -> int -> unit; + mutable enter_function_scope: int -> int -> unit; mutable add_lvar_scope: int -> ident -> int -> unit; } diff --git a/debug/Debug.mli b/debug/Debug.mli index a7d40382..1fabb943 100644 --- a/debug/Debug.mli +++ b/debug/Debug.mli @@ -29,5 +29,5 @@ val all_files_iter: (string -> unit) -> unit val insert_local_declaration: storage -> ident -> typ -> location -> unit val atom_local_variable: ident -> atom -> unit val enter_scope: int -> int -> int -> unit -val enter_function_scope: ident -> int -> unit +val enter_function_scope: int -> int -> unit val add_lvar_scope: int -> ident -> int -> unit diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index d8d608af..ef8993ea 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -439,6 +439,7 @@ let atom_to_local: (atom, int) Hashtbl.t = Hashtbl.create 7 let scope_to_local: (int * int,int) Hashtbl.t = Hashtbl.create 7 (* Map from scope id + function atom to debug id *) +let atom_to_scope: (atom, int) Hashtbl.t = Hashtbl.create 7 let find_lvar_stamp id = let id = (Hashtbl.find stamp_to_local id) in @@ -477,6 +478,7 @@ let insert_global_declaration env dec= in match dec.gdesc with | Gdecl (sto,id,ty,init) -> + Printf.printf "Entering information for %s\n" id.name; if not (is_function_type env ty) then begin if not (Hashtbl.mem stamp_to_definition id.stamp) then begin let at_decl,ext = (match sto with @@ -644,9 +646,9 @@ let new_scope f_id sc_id = let enter_function_scope fun_id sc_id = try - let id = new_scope fun_id.stamp sc_id in - let fun_id,f = find_fun_stamp fun_id.stamp in - replace_fun id ({f with fun_scope = Some id}) + let id = new_scope fun_id sc_id in + let fun_id,f = find_fun_stamp fun_id in + replace_fun fun_id ({f with fun_scope = Some id}) with Not_found -> () let enter_scope f_id p_id id = diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml index 8e29fcaf..15c63b66 100644 --- a/debug/Dwarfgen.ml +++ b/debug/Dwarfgen.ml @@ -305,7 +305,17 @@ and local_to_entry acc id = | LocalVariable v -> local_variable_to_entry acc v id | Scope v -> scope_to_entry acc v id +let fun_scope_to_entries acc id = + match id with + | None -> [],acc + | Some id -> + let sc = Hashtbl.find local_variables id in + (match sc with + | Scope sc ->mmap local_to_entry acc sc.scope_variables + | _ -> assert false) + let function_to_entry acc id f = + Printf.printf "Generating information for %s with id %d\n" f.fun_name id; let f_tag = { subprogram_file_loc = f.fun_file_loc; subprogram_external = Some f.fun_external; @@ -318,8 +328,8 @@ let function_to_entry acc id f = 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 = mmap function_parameter_to_entry acc f.fun_parameter in -(* let vars = List.map local_variable_to_entry f.fun_locals in*) - add_children f_entry params,acc + let vars,acc = fun_scope_to_entries acc f.fun_scope in + add_children f_entry (params@vars),acc let definition_to_entry acc id t = match t with @@ -327,7 +337,7 @@ let definition_to_entry acc id t = | Function f -> function_to_entry acc id f let gen_defs () = - let defs,typ = Hashtbl.fold (fun id t (acc,bcc) -> let t,bcc = definition_to_entry bcc id t in + let defs,typ = Hashtbl.fold (fun id t (acc,bcc) -> let t,bcc = definition_to_entry bcc id t in t::acc,bcc) definitions ([],IntSet.empty) in List.rev defs,typ -- cgit From dccd211b1be1fd80f3804b0586286566c874d523 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Wed, 23 Sep 2015 19:45:44 +0200 Subject: Also convert the fun stamp + scope id to debug id Hashtable in an atom + scope id Hashtable. --- debug/DebugInformation.ml | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) (limited to 'debug') diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index ef8993ea..80d71dfd 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -439,7 +439,7 @@ let atom_to_local: (atom, int) Hashtbl.t = Hashtbl.create 7 let scope_to_local: (int * int,int) Hashtbl.t = Hashtbl.create 7 (* Map from scope id + function atom to debug id *) -let atom_to_scope: (atom, int) Hashtbl.t = Hashtbl.create 7 +let atom_to_scope: (atom * int, int) Hashtbl.t = Hashtbl.create 7 let find_lvar_stamp id = let id = (Hashtbl.find stamp_to_local id) in @@ -599,9 +599,11 @@ let atom_global_variable id atom = 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 + 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 add_fun_addr atom (high,low) = -- cgit From fc8afb9287ab7b1607e5a7d2a03b0078fd9867d0 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Thu, 24 Sep 2015 20:11:48 +0200 Subject: Added placing labels for live ranges etc. In order to avoid the usage of too many labels we replace the debug statements during the Asmexpand phase. --- debug/Debug.ml | 27 +++++++++++++++++++++++++++ debug/Debug.mli | 7 +++++++ debug/DebugInformation.ml | 17 +++++++++++++++-- debug/Dwarfgen.ml | 1 - 4 files changed, 49 insertions(+), 3 deletions(-) (limited to 'debug') diff --git a/debug/Debug.ml b/debug/Debug.ml index c2b48618..fba921e1 100644 --- a/debug/Debug.ml +++ b/debug/Debug.ml @@ -10,6 +10,8 @@ (* *) (* *********************************************************************) +open AST +open BinNums open C open Camlcoq open Dwarfgen @@ -35,6 +37,11 @@ type implem = 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 -> positive -> string builtin_arg -> unit; + mutable end_live_range: atom -> positive -> unit; + mutable stack_variable: atom -> string builtin_arg -> unit } let implem = @@ -54,6 +61,11 @@ let implem = enter_scope = (fun _ _ _ -> ()); enter_function_scope = (fun _ _ -> ()); add_lvar_scope = (fun _ _ _ -> ()); + open_scope = (fun _ _ _ -> ()); + close_scope = (fun _ _ _ -> ()); + start_live_range = (fun _ _ _ -> ()); + end_live_range = (fun _ _ -> ()); + stack_variable = (fun _ _ -> ()); } let init () = @@ -73,6 +85,11 @@ let init () = 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; end else begin implem.init <- (fun _ -> ()); implem.atom_function <- (fun _ _ -> ()); @@ -89,6 +106,11 @@ let init () = 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 _ _ -> ()); end let init_compile_unit name = implem.init name @@ -106,3 +128,8 @@ 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 diff --git a/debug/Debug.mli b/debug/Debug.mli index 1fabb943..42a0cee7 100644 --- a/debug/Debug.mli +++ b/debug/Debug.mli @@ -10,9 +10,11 @@ (* *) (* *********************************************************************) +open AST open C open Camlcoq open DwarfTypes +open BinNums val init: unit -> unit @@ -31,3 +33,8 @@ val atom_local_variable: ident -> atom -> unit val enter_scope: int -> int -> int -> unit val enter_function_scope: int -> int -> unit val add_lvar_scope: int -> ident -> int -> unit +val open_scope: atom -> int -> positive -> unit +val close_scope: atom -> int -> positive -> unit +val start_live_range: atom -> positive -> string builtin_arg -> unit +val end_live_range: atom -> positive -> unit +val stack_variable: atom -> string builtin_arg -> unit diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index 80d71dfd..f12853c9 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -478,7 +478,6 @@ let insert_global_declaration env dec= in match dec.gdesc with | Gdecl (sto,id,ty,init) -> - Printf.printf "Entering information for %s\n" id.name; if not (is_function_type env ty) then begin if not (Hashtbl.mem stamp_to_definition id.stamp) then begin let at_decl,ext = (match sto with @@ -660,6 +659,21 @@ let enter_scope f_id p_id id = replace_scope p_id' ({scope_variables = id'::scope.scope_variables;}) with Not_found -> () +let open_scope atom s_id lbl = + () + +let close_scope atom s_id lbl = + () + +let start_live_range atom lbl loc = + () + +let end_live_range atom lbl = + () + +let stack_variable atom loc = + () + let init name = id := 0; file_name := name; @@ -672,4 +686,3 @@ let init name = Hashtbl.reset stamp_to_local; Hashtbl.reset atom_to_local; Hashtbl.reset scope_to_local; - diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml index 15c63b66..6c10b362 100644 --- a/debug/Dwarfgen.ml +++ b/debug/Dwarfgen.ml @@ -315,7 +315,6 @@ let fun_scope_to_entries acc id = | _ -> assert false) let function_to_entry acc id f = - Printf.printf "Generating information for %s with id %d\n" f.fun_name id; let f_tag = { subprogram_file_loc = f.fun_file_loc; subprogram_external = Some f.fun_external; -- cgit From aff813685455559f6d6a88158dd3d605893ba3a3 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Fri, 25 Sep 2015 16:43:18 +0200 Subject: Added support for the locations of stack allocated local variables. This commit adds furher support for location information for local variables and starts with the implementation of the debug_loc section. --- debug/Debug.ml | 16 +++++++-- debug/Debug.mli | 8 +++-- debug/DebugInformation.ml | 88 +++++++++++++++++++++++++++++++++++++++++++---- debug/DwarfPrinter.ml | 75 +++++++++++++++++++++++++++++++--------- debug/DwarfPrinter.mli | 2 +- debug/DwarfTypes.mli | 26 +++++++++----- debug/DwarfUtil.ml | 9 ++++- debug/Dwarfgen.ml | 61 ++++++++++++++++++++++++-------- 8 files changed, 232 insertions(+), 53 deletions(-) (limited to 'debug') diff --git a/debug/Debug.ml b/debug/Debug.ml index fba921e1..7155ae0f 100644 --- a/debug/Debug.ml +++ b/debug/Debug.ml @@ -30,7 +30,7 @@ type implem = 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: unit -> dw_entry option; + mutable generate_debug_info: unit -> (dw_entry * dw_locations) option; mutable all_files_iter: (string -> unit) -> unit; mutable insert_local_declaration: storage -> ident -> typ -> location -> unit; mutable atom_local_variable: ident -> atom -> unit; @@ -39,9 +39,11 @@ type implem = 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 -> positive -> string builtin_arg -> unit; + mutable start_live_range: atom -> positive -> int * int builtin_arg -> unit; mutable end_live_range: atom -> positive -> unit; - mutable stack_variable: atom -> string builtin_arg -> unit + mutable stack_variable: atom -> int * int builtin_arg -> unit; + mutable function_end: atom -> positive -> unit; + mutable add_label: atom -> positive -> int -> unit; } let implem = @@ -66,6 +68,8 @@ let implem = start_live_range = (fun _ _ _ -> ()); end_live_range = (fun _ _ -> ()); stack_variable = (fun _ _ -> ()); + function_end = (fun _ _ -> ()); + add_label = (fun _ _ _ -> ()); } let init () = @@ -90,6 +94,8 @@ let init () = 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; end else begin implem.init <- (fun _ -> ()); implem.atom_function <- (fun _ _ -> ()); @@ -111,6 +117,8 @@ let init () = implem.start_live_range <- (fun _ _ _ -> ()); implem.end_live_range <- (fun _ _ -> ()); implem.stack_variable <- (fun _ _ -> ()); + implem.function_end <- (fun _ _ -> ()); + implem.add_label <- (fun _ _ _ -> ()); end let init_compile_unit name = implem.init name @@ -133,3 +141,5 @@ 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 diff --git a/debug/Debug.mli b/debug/Debug.mli index 42a0cee7..2954c300 100644 --- a/debug/Debug.mli +++ b/debug/Debug.mli @@ -26,7 +26,6 @@ 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 generate_debug_info: unit -> dw_entry option val all_files_iter: (string -> unit) -> unit val insert_local_declaration: storage -> ident -> typ -> location -> unit val atom_local_variable: ident -> atom -> unit @@ -35,6 +34,9 @@ val enter_function_scope: int -> int -> unit val add_lvar_scope: int -> ident -> int -> unit val open_scope: atom -> int -> positive -> unit val close_scope: atom -> int -> positive -> unit -val start_live_range: atom -> positive -> string builtin_arg -> unit +val start_live_range: atom -> positive -> (int * int builtin_arg) -> unit val end_live_range: atom -> positive -> unit -val stack_variable: atom -> string builtin_arg -> unit +val stack_variable: atom -> int * int builtin_arg -> unit +val function_end: atom -> positive -> unit +val add_label: atom -> positive -> int -> unit +val generate_debug_info: unit -> (dw_entry * dw_locations) option diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index f12853c9..459c4e9d 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -10,6 +10,8 @@ (* *) (* *********************************************************************) +open AST +open BinNums open C open Camlcoq open Cutil @@ -659,20 +661,94 @@ let enter_scope f_id p_id id = replace_scope p_id' ({scope_variables = id'::scope.scope_variables;}) with Not_found -> () + +type scope_range = + { + start_addr: positive option; + end_addr: positive option; + } + +type var_range = + { + range_start: positive option; + range_end: positive option; + var_loc: int * int builtin_arg; + } + +type var_location = + | RangeLoc of var_range list + | FunctionLoc of int * int builtin_arg (* Stack allocated variables *) + +let var_locations: (atom,var_location) Hashtbl.t = Hashtbl.create 7 + +let scope_ranges: (int,scope_range list) Hashtbl.t = Hashtbl.create 7 + +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 -> () 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 = + begin + match old_r with + | a::rest -> a,rest + | _ -> 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 -> () let start_live_range atom lbl loc = - () + try + let old_r = Hashtbl.find var_locations atom in + match old_r with + | RangeLoc old_r -> + let n_r = { range_start = Some lbl; range_end = None; var_loc = loc } in + Hashtbl.replace var_locations atom (RangeLoc (n_r::old_r)) + | _ -> assert false + with Not_found -> () + let end_live_range atom lbl = - () + try + let old_r = Hashtbl.find var_locations atom in + match old_r with + | RangeLoc (n_r::old_r) -> + let n_r = {n_r with range_end = Some lbl} in + Hashtbl.replace var_locations atom (RangeLoc (n_r::old_r)) + | _ -> assert false + with Not_found -> () + + +let stack_variable atom (sp,loc) = + Hashtbl.add var_locations atom (FunctionLoc (sp,loc)) + +let function_end atom loc = + IntSet.iter (fun id -> close_scope atom id loc) !open_scopes; + open_scopes := IntSet.empty -let stack_variable atom loc = - () let init name = id := 0; diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index f3cfdc6e..5f459a57 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -21,7 +21,7 @@ open Sections (* The printer is parameterized over target specific functions and a set of dwarf type constants *) module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): sig - val print_debug: out_channel -> dw_entry -> unit + val print_debug: out_channel -> dw_entry -> dw_locations -> unit end = struct @@ -36,6 +36,10 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): 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) @@ -69,9 +73,10 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): let add_location loc buf = match loc with | None -> () - | Some (LocSymbol _) ->add_abbr_entry (0x2,location_block_type_abbr) buf - | Some (LocConst _) -> add_abbr_entry (0x2,location_const_type_abbr) buf - | Some (LocBlock _) -> add_abbr_entry (0x2,location_block_type_abbr) buf + | Some (LocRef _) -> add_abbr_entry (0x2,location_ref_type_abbr) buf + | Some (LocList _ ) + | 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 = @@ -101,8 +106,8 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): | DW_TAG_compile_unit e -> prologue 0x11; add_abbr_entry (0x1b,comp_dir_type_abbr) buf; - add_high_pc buf; 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; @@ -288,20 +293,43 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): let print_byte oc b = fprintf oc " .byte 0x%X\n" b + + let size_of_loc_expr = function + | DW_OP_bregx _ -> 3 + | DW_OP_plus_uconst _ -> 2 + | DW_OP_piece _ -> 2 + + 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 + | DW_OP_plus_uconst i -> + print_byte oc dw_op_plus_uconst; + print_byte oc i + | DW_OP_piece i -> + print_byte oc dw_op_piece; + print_uleb128 oc i + let print_loc oc loc = match loc with | LocSymbol s -> - fprintf oc " .sleb128 5\n"; - fprintf oc " .byte 3\n"; + print_sleb128 oc 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_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; + List.iter (print_loc_expr oc) e | _ -> () let print_data_location oc dl = match dl with - | DataLocBlock [DW_OP_plus_uconst i] -> - fprintf oc " .sleb128 2\n"; - fprintf oc " .byte 0x23\n"; - fprintf oc " .byte %d\n" i + | DataLocBlock e -> + print_loc_expr oc e | _ -> () let print_ref oc r = @@ -340,8 +368,8 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): let print_compilation_unit oc tag = let prod_name = sprintf "AbsInt Angewandte Informatik GmbH:CompCert Version %s:%s" Version.version Configuration.arch in print_string oc (Sys.getcwd ()); - print_addr oc (get_end_addr ()); print_addr oc (get_start_addr ()); + print_addr oc (get_end_addr ()); print_uleb128 oc 1; print_string oc tag.compile_unit_name; print_string oc prod_name; @@ -372,9 +400,10 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): print_ref oc tl.label_low_pc; print_string oc tl.label_name + let print_lexical_block oc lb = - print_opt_value oc lb.lexical_block_high_pc print_ref; - print_opt_value oc lb.lexical_block_low_pc print_ref + print_opt_value oc lb.lexical_block_high_pc print_addr; + print_opt_value oc lb.lexical_block_low_pc print_addr let print_member oc mb = print_file_loc oc mb.member_file_loc; @@ -504,10 +533,24 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): print_sleb128 oc 0; print_label oc debug_end (* End of the debug section *) + let print_location_entry oc l = + let c_low = get_start_addr () in + print_label oc (entry_to_label l.loc_id); + List.iter (fun (b,e,loc) -> + fprintf oc " .4byte %a-%a\n" label b label c_low; + fprintf oc " .4byte %a-%a\n" label e label c_low; + print_loc oc loc) l.loc; + fprintf oc " .4byte 0\n"; + fprintf oc " .4byte 0\n" + + let print_location_list oc l = + List.iter (print_location_entry oc) l (* Print the debug info and abbrev section *) - let print_debug oc entry = + let print_debug oc entry loc = print_debug_abbrev oc entry; - print_debug_info oc entry + print_debug_info oc entry; + print_location_list oc loc + end diff --git a/debug/DwarfPrinter.mli b/debug/DwarfPrinter.mli index 9e0e6693..ab9ab264 100644 --- a/debug/DwarfPrinter.mli +++ b/debug/DwarfPrinter.mli @@ -14,5 +14,5 @@ open DwarfTypes module DwarfPrinter: functor (Target: DWARF_TARGET) -> functor (DwarfAbbrevs: DWARF_ABBREVS) -> sig - val print_debug: out_channel -> dw_entry -> unit + val print_debug: out_channel -> dw_entry -> dw_locations -> unit end diff --git a/debug/DwarfTypes.mli b/debug/DwarfTypes.mli index 1d41403b..f01e550a 100644 --- a/debug/DwarfTypes.mli +++ b/debug/DwarfTypes.mli @@ -12,8 +12,9 @@ (* Types used for writing dwarf debug information *) -open Sections +open BinNums open Camlcoq +open Sections (* Basic types for the value of attributes *) @@ -39,16 +40,17 @@ type block = string type location_expression = | DW_OP_plus_uconst of constant - | DW_OP - + | DW_OP_bregx of int * int32 + | DW_OP_piece of int type location_value = | LocSymbol of atom - | LocConst of constant - | LocBlock of block - + | LocRef of address + | LocSimple of location_expression + | LocList of location_expression list + type data_location_value = - | DataLocBlock of location_expression list + | DataLocBlock of location_expression | DataLocRef of reference type bound_value = @@ -233,6 +235,14 @@ type dw_entry = id: reference; } +(* The type for the location list. *) +type location_entry = + { + loc: (int * int * location_value) list; + loc_id: reference; + } +type dw_locations = location_entry list + (* Module type for a matching from type to dwarf encoding *) module type DWARF_ABBREVS = sig @@ -257,7 +267,7 @@ module type DWARF_ABBREVS = val artificial_type_abbr: int val variable_parameter_type_abbr: int val bit_size_type_abbr: int - val location_const_type_abbr: int + val location_ref_type_abbr: int val location_block_type_abbr: int val data_location_block_type_abbr: int val data_location_ref_type_abbr: int diff --git a/debug/DwarfUtil.ml b/debug/DwarfUtil.ml index 4cd838b6..954324f1 100644 --- a/debug/DwarfUtil.ml +++ b/debug/DwarfUtil.ml @@ -76,6 +76,13 @@ let dw_form_ref8 = 0x14 let dw_ref_udata = 0x15 let dw_ref_indirect = 0x16 +(* Operation encoding *) +let dw_op_addr = 0x3 +let dw_op_plus_uconst = 0x23 +let dw_op_bregx = 0x92 +let dw_op_piece = 0x93 + + (* Default corresponding encoding for the different abbreviations *) module DefaultAbbrevs = struct @@ -100,7 +107,7 @@ module DefaultAbbrevs = 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_const_type_abbr = dw_form_data4 + 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 diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml index 6c10b362..7b155419 100644 --- a/debug/Dwarfgen.ml +++ b/debug/Dwarfgen.ml @@ -10,7 +10,9 @@ (* *) (* *********************************************************************) +open AST open C +open Camlcoq open Cutil open DebugInformation open DwarfTypes @@ -162,7 +164,7 @@ let member_to_entry mem = member_data_member_location = (match mem.cfd_byte_offset with | None -> None - | Some s -> Some (DataLocBlock [DW_OP_plus_uconst s])); + | Some s -> Some (DataLocBlock (DW_OP_plus_uconst s))); member_declaration = None; member_name = Some (mem.cfd_name); member_type = mem.cfd_typ; @@ -280,38 +282,66 @@ let function_parameter_to_entry acc p = } in new_entry (next_id ()) (DW_TAG_formal_parameter p),IntSet.add p.formal_parameter_type acc -let rec local_variable_to_entry acc v id = +let rec local_variable_to_entry f_id acc v id = + let loc = try + begin + match (Hashtbl.find var_locations (get_opt_val v.lvar_atom)) with + | FunctionLoc (a,BA_addrstack (ofs)) -> + let ofs = camlint_of_coqint ofs in + Some (LocSimple (DW_OP_bregx (a,ofs))) + | FunctionLoc (a,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 + Some (LocList [DW_OP_bregx (a,hi);DW_OP_piece 4;DW_OP_bregx (a,lo);DW_OP_piece 4]) + | _ -> None + end + with Not_found -> None in let var = { variable_file_loc = v.lvar_file_loc; variable_declaration = None; variable_external = None; variable_name = v.lvar_name; variable_type = v.lvar_type; - variable_location = None; + variable_location = loc; } in new_entry id (DW_TAG_variable var),IntSet.add v.lvar_type acc -and scope_to_entry acc sc id = +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 = None; - lexical_block_low_pc = None; + lexical_block_high_pc = h_pc; + lexical_block_low_pc = l_pc; } in - let vars,acc = mmap local_to_entry acc sc.scope_variables in + let vars,acc = mmap (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 acc id = +and local_to_entry f_id acc id = match Hashtbl.find local_variables id with - | LocalVariable v -> local_variable_to_entry acc v id - | Scope v -> scope_to_entry acc v id + | LocalVariable v -> local_variable_to_entry f_id acc v id + | Scope v -> scope_to_entry f_id acc v id -let fun_scope_to_entries acc id = +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 local_to_entry acc sc.scope_variables + | Scope sc ->mmap (local_to_entry f_id) acc sc.scope_variables | _ -> assert false) let function_to_entry acc id f = @@ -324,10 +354,11 @@ let function_to_entry acc id f = 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 = mmap function_parameter_to_entry acc f.fun_parameter in - let vars,acc = fun_scope_to_entries acc f.fun_scope 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 id t = @@ -340,10 +371,10 @@ let gen_defs () = t::acc,bcc) definitions ([],IntSet.empty) in List.rev defs,typ -let gen_debug_info () = +let gen_debug_info () : dw_entry * dw_locations= let cp = { compile_unit_name = !file_name; } in let cp = new_entry (next_id ()) (DW_TAG_compile_unit cp) in let defs,ty = gen_defs () in - add_children cp ((gen_types ty) @ defs) + add_children cp ((gen_types ty) @ defs),[] -- cgit From 3e070cae6a316b7e3363c8159096c3bbc4bf21b2 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Fri, 25 Sep 2015 21:12:48 +0200 Subject: Added translation of the range lists to location entries. --- debug/DebugInformation.ml | 32 ++++++++++++----- debug/DwarfPrinter.ml | 11 +++++- debug/DwarfTypes.mli | 1 + debug/DwarfUtil.ml | 2 ++ debug/Dwarfgen.ml | 88 +++++++++++++++++++++++++++++++++-------------- 5 files changed, 98 insertions(+), 36 deletions(-) (limited to 'debug') diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index 459c4e9d..ec16f64e 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -695,6 +695,7 @@ 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 @@ -721,33 +722,46 @@ let close_scope atom s_id lbl = with Not_found -> () let start_live_range atom lbl loc = + let old_r = try + begin + match Hashtbl.find var_locations atom with + | RangeLoc old_r -> old_r + | _ -> assert false + end + with Not_found -> [] in + let n_r = { range_start = Some lbl; range_end = None; var_loc = loc } in + open_vars := atom::!open_vars; + Hashtbl.replace var_locations atom (RangeLoc (n_r::old_r)) + +let end_live_range atom lbl = try let old_r = Hashtbl.find var_locations atom in match old_r with - | RangeLoc old_r -> - let n_r = { range_start = Some lbl; range_end = None; var_loc = loc } in + | RangeLoc (n_r::old_r) -> + let n_r = {n_r with range_end = Some lbl} in Hashtbl.replace var_locations atom (RangeLoc (n_r::old_r)) | _ -> assert false with Not_found -> () - - -let end_live_range atom lbl = + +let close_range lbl atom = try let old_r = Hashtbl.find var_locations atom in match old_r with | RangeLoc (n_r::old_r) -> - let n_r = {n_r with range_end = Some lbl} in - Hashtbl.replace var_locations atom (RangeLoc (n_r::old_r)) + if n_r.range_end = None then + let n_r = {n_r with range_end = Some lbl} in + Hashtbl.replace var_locations atom (RangeLoc (n_r::old_r)) | _ -> assert false with Not_found -> () - let stack_variable atom (sp,loc) = Hashtbl.add var_locations atom (FunctionLoc (sp,loc)) let function_end atom loc = IntSet.iter (fun id -> close_scope atom id loc) !open_scopes; - open_scopes := IntSet.empty + open_scopes := IntSet.empty; + List.iter (close_range loc) !open_vars; + open_vars:= [] let init name = diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index 5f459a57..3e98f0dd 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -298,7 +298,8 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): | DW_OP_bregx _ -> 3 | DW_OP_plus_uconst _ -> 2 | DW_OP_piece _ -> 2 - + | DW_OP_reg i -> if i < 32 then 1 else 2 + let print_loc_expr oc = function | DW_OP_bregx (a,b) -> print_byte oc dw_op_bregx; @@ -310,6 +311,13 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): | DW_OP_piece 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) + else begin + print_byte oc dw_op_regx; + print_uleb128 oc i + end let print_loc oc loc = match loc with @@ -544,6 +552,7 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): fprintf oc " .4byte 0\n" let print_location_list oc l = + fprintf oc" .section %s\n" (name_of_section Section_debug_loc); List.iter (print_location_entry oc) l (* Print the debug info and abbrev section *) diff --git a/debug/DwarfTypes.mli b/debug/DwarfTypes.mli index f01e550a..ce00474a 100644 --- a/debug/DwarfTypes.mli +++ b/debug/DwarfTypes.mli @@ -42,6 +42,7 @@ 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 type location_value = | LocSymbol of atom diff --git a/debug/DwarfUtil.ml b/debug/DwarfUtil.ml index 954324f1..b0b80924 100644 --- a/debug/DwarfUtil.ml +++ b/debug/DwarfUtil.ml @@ -79,6 +79,8 @@ let dw_ref_indirect = 0x16 (* Operation encoding *) let dw_op_addr = 0x3 let dw_op_plus_uconst = 0x23 +let dw_op_reg0 = 0x50 +let dw_op_regx = 0x90 let dw_op_bregx = 0x92 let dw_op_piece = 0x93 diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml index 7b155419..4e531ca9 100644 --- a/debug/Dwarfgen.ml +++ b/debug/Dwarfgen.ml @@ -282,23 +282,58 @@ let function_parameter_to_entry acc p = } in new_entry (next_id ()) (DW_TAG_formal_parameter p),IntSet.add p.formal_parameter_type acc -let rec local_variable_to_entry f_id acc v id = - let loc = try +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 rec local_variable_to_entry f_id (acc,bcc) v id = + let loc,loc_list = try begin match (Hashtbl.find var_locations (get_opt_val v.lvar_atom)) with - | FunctionLoc (a,BA_addrstack (ofs)) -> - let ofs = camlint_of_coqint ofs in - Some (LocSimple (DW_OP_bregx (a,ofs))) - | FunctionLoc (a,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 - Some (LocList [DW_OP_bregx (a,hi);DW_OP_piece 4;DW_OP_bregx (a,lo);DW_OP_piece 4]) - | _ -> None + | FunctionLoc (a,r) -> + translate_function_loc a r + | RangeLoc l -> + let l = List.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 in + with Not_found -> None,[] in let var = { variable_file_loc = v.lvar_file_loc; variable_declaration = None; @@ -307,7 +342,7 @@ let rec local_variable_to_entry f_id acc v id = variable_type = v.lvar_type; variable_location = loc; } in - new_entry id (DW_TAG_variable var),IntSet.add v.lvar_type acc + 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 @@ -344,7 +379,7 @@ let fun_scope_to_entries f_id acc id = | Scope sc ->mmap (local_to_entry f_id) acc sc.scope_variables | _ -> assert false) -let function_to_entry acc id f = +let function_to_entry (acc,bcc) id f = let f_tag = { subprogram_file_loc = f.fun_file_loc; subprogram_external = Some f.fun_external; @@ -358,23 +393,24 @@ let function_to_entry acc id f = 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 = mmap function_parameter_to_entry 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 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 id t = +let definition_to_entry (acc,bcc) id t = match t with - | GlobalVariable g -> global_variable_to_entry acc id g - | Function f -> function_to_entry acc id f + | 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 let gen_defs () = - let defs,typ = Hashtbl.fold (fun id t (acc,bcc) -> let t,bcc = definition_to_entry bcc id t in - t::acc,bcc) definitions ([],IntSet.empty) in - List.rev defs,typ + let defs,(typ,locs) = Hashtbl.fold (fun id t (acc,bcc) -> let t,bcc = definition_to_entry bcc id t in + t::acc,bcc) definitions ([],(IntSet.empty,[])) in + List.rev defs,typ,locs let gen_debug_info () : dw_entry * dw_locations= let cp = { compile_unit_name = !file_name; } in let cp = new_entry (next_id ()) (DW_TAG_compile_unit cp) in - let defs,ty = gen_defs () in - add_children cp ((gen_types ty) @ defs),[] + let defs,ty,locs = gen_defs () in + add_children cp ((gen_types ty) @ defs),locs -- cgit From 91ed1b752d2661478840e40a0d977b068d99490d Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Sun, 27 Sep 2015 20:13:19 +0200 Subject: Added printing the reference address for the LocRef and started refactoring old Debuging code. The old functions to store the symbol for the Global variables and retrive this is no longer needed since the atom is stored in DebugInformation. Also the Debug.Abbrev module is no longer needed. --- debug/DwarfPrinter.ml | 14 ++++++------- debug/DwarfPrinter.mli | 2 +- debug/DwarfTypes.mli | 34 ------------------------------ debug/DwarfUtil.ml | 57 ++++++++++++++++++++++++-------------------------- 4 files changed, 35 insertions(+), 72 deletions(-) (limited to 'debug') diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index 3e98f0dd..13c0640d 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -19,14 +19,13 @@ open PrintAsmaux open Sections (* The printer is parameterized over target specific functions and a set of dwarf type constants *) -module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): +module DwarfPrinter(Target: DWARF_TARGET): sig val print_debug: out_channel -> dw_entry -> dw_locations -> unit end = struct open Target - open DwarfAbbrevs (* Byte value to string *) let string_of_byte value = @@ -318,6 +317,11 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): print_byte oc dw_op_regx; print_uleb128 oc i end + + + let print_ref oc r = + let ref = entry_to_label r in + fprintf oc " .4byte %a\n" label ref let print_loc oc loc = match loc with @@ -332,7 +336,7 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): let size = List.fold_left (fun acc a -> acc + size_of_loc_expr a) 0 e in print_sleb128 oc size; List.iter (print_loc_expr oc) e - | _ -> () + | LocRef f -> print_ref oc f let print_data_location oc dl = match dl with @@ -340,10 +344,6 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): print_loc_expr oc e | _ -> () - let print_ref oc r = - let ref = entry_to_label r in - fprintf oc " .4byte %a\n" label ref - let print_addr oc a = fprintf oc " .4byte %a\n" label a diff --git a/debug/DwarfPrinter.mli b/debug/DwarfPrinter.mli index ab9ab264..8b206a00 100644 --- a/debug/DwarfPrinter.mli +++ b/debug/DwarfPrinter.mli @@ -12,7 +12,7 @@ open DwarfTypes -module DwarfPrinter: functor (Target: DWARF_TARGET) -> functor (DwarfAbbrevs: DWARF_ABBREVS) -> +module DwarfPrinter: functor (Target: DWARF_TARGET) -> sig val print_debug: out_channel -> dw_entry -> dw_locations -> unit end diff --git a/debug/DwarfTypes.mli b/debug/DwarfTypes.mli index ce00474a..86a14163 100644 --- a/debug/DwarfTypes.mli +++ b/debug/DwarfTypes.mli @@ -244,38 +244,6 @@ type location_entry = } type dw_locations = location_entry list -(* Module type for a matching from type to dwarf encoding *) -module type DWARF_ABBREVS = - sig - val sibling_type_abbr: int - val file_loc_type_abbr: int * int - val type_abbr: int - val name_type_abbr: int - val encoding_type_abbr: int - val byte_size_type_abbr: int - val member_size_abbr: int - val high_pc_type_abbr: int - val low_pc_type_abbr: int - val stmt_list_type_abbr: int - val declaration_type_abbr: int - val external_type_abbr: int - val prototyped_type_abbr: int - val bit_offset_type_abbr: int - val comp_dir_type_abbr: int - val language_type_abbr: int - val producer_type_abbr: int - val value_type_abbr: int - val artificial_type_abbr: int - val variable_parameter_type_abbr: int - val bit_size_type_abbr: int - val location_ref_type_abbr: int - val location_block_type_abbr: int - val data_location_block_type_abbr: int - val data_location_ref_type_abbr: int - val bound_const_type_abbr: int - val bound_ref_type_abbr: int - end - (* The target specific functions for printing the debug information *) module type DWARF_TARGET= sig @@ -285,7 +253,5 @@ module type DWARF_TARGET= val get_end_addr: unit -> int val get_stmt_list_addr: unit -> int val name_of_section: section_name -> string - val get_location: int -> location_value option - val get_frame_base: int -> location_value option val symbol: out_channel -> atom -> unit end diff --git a/debug/DwarfUtil.ml b/debug/DwarfUtil.ml index b0b80924..e1869281 100644 --- a/debug/DwarfUtil.ml +++ b/debug/DwarfUtil.ml @@ -86,33 +86,30 @@ let dw_op_piece = 0x93 (* Default corresponding encoding for the different abbreviations *) -module DefaultAbbrevs = - struct - 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 - end +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 -- cgit From 78df4fe4fad46fee83f5044525fd8e530d8da6ff Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Sun, 27 Sep 2015 20:25:21 +0200 Subject: More refactoring of the Debug Information. In order to remove unnecessary dependecies the implemenation type is made and the DebugInit file initializes the fields in the record. This allows it to move more functions behind the Debug interface without introducing circular dependencies. --- debug/Debug.ml | 49 ------------------------------------ debug/Debug.mli | 30 +++++++++++++++++++++- debug/DebugInit.ml | 73 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 102 insertions(+), 50 deletions(-) create mode 100644 debug/DebugInit.ml (limited to 'debug') diff --git a/debug/Debug.ml b/debug/Debug.ml index 7155ae0f..a496b610 100644 --- a/debug/Debug.ml +++ b/debug/Debug.ml @@ -72,55 +72,6 @@ let implem = add_label = (fun _ _ _ -> ()); } -let init () = - if !Clflags.option_g then begin - implem.init <- DebugInformation.init; - implem.atom_function <- DebugInformation.atom_function; - implem.atom_global_variable <- DebugInformation.atom_global_variable; - 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 <- (fun () -> Some (Dwarfgen.gen_debug_info ())); - 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.function_end <- DebugInformation.function_end; - implem.add_label <- DebugInformation.add_label; - end else begin - implem.init <- (fun _ -> ()); - implem.atom_function <- (fun _ _ -> ()); - implem.atom_global_variable <- (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.function_end <- (fun _ _ -> ()); - implem.add_label <- (fun _ _ _ -> ()); - end - 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 diff --git a/debug/Debug.mli b/debug/Debug.mli index 2954c300..5ef1e7f5 100644 --- a/debug/Debug.mli +++ b/debug/Debug.mli @@ -17,7 +17,35 @@ open DwarfTypes open BinNums -val init: unit -> unit +(* Record used for stroring references to the actual implementation functions *) +type implem = + { + mutable init: string -> unit; + mutable atom_function: ident -> atom -> unit; + mutable atom_global_variable: 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: unit -> (dw_entry * dw_locations) 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 -> positive -> int * int builtin_arg -> unit; + mutable end_live_range: atom -> positive -> unit; + mutable stack_variable: atom -> int * int builtin_arg -> unit; + mutable function_end: atom -> positive -> unit; + mutable add_label: atom -> positive -> int -> unit; + } + +val implem: implem + val init_compile_unit: string -> unit val atom_function: ident -> atom -> unit val atom_global_variable: ident -> atom -> unit diff --git a/debug/DebugInit.ml b/debug/DebugInit.ml new file mode 100644 index 00000000..40be9f42 --- /dev/null +++ b/debug/DebugInit.ml @@ -0,0 +1,73 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Bernhard Schommer, AbsInt Angewandte Informatik GmbH *) +(* *) +(* AbsInt Angewandte Informatik GmbH. All rights reserved. This file *) +(* is distributed under the terms of the INRIA Non-Commercial *) +(* License Agreement. *) +(* *) +(* *********************************************************************) + +open AST +open BinNums +open C +open Camlcoq +open Dwarfgen +open DwarfTypes +open Debug + +let init_debug () = + implem.init <- DebugInformation.init; + implem.atom_function <- DebugInformation.atom_function; + implem.atom_global_variable <- DebugInformation.atom_global_variable; + 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 <- (fun () -> Some (Dwarfgen.gen_debug_info ())); + 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.function_end <- DebugInformation.function_end; + implem.add_label <- DebugInformation.add_label + +let init_none () = + implem.init <- (fun _ -> ()); + implem.atom_function <- (fun _ _ -> ()); + implem.atom_global_variable <- (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.function_end <- (fun _ _ -> ()); + implem.add_label <- (fun _ _ _ -> ()) + +let init () = + if !Clflags.option_g then + init_debug () + else + init_none () -- cgit From 89476ea80ecfc7af02ef5026d0f45b61d243e3b0 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Mon, 28 Sep 2015 09:48:07 +0200 Subject: Changed the size expression to 2byte for debug_loc entries. --- debug/DwarfPrinter.ml | 19 ++++++++++++++++++- 1 file changed, 18 insertions(+), 1 deletion(-) (limited to 'debug') diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index 13c0640d..63ba4cd0 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -292,6 +292,9 @@ module DwarfPrinter(Target: DWARF_TARGET): let print_byte oc b = fprintf oc " .byte 0x%X\n" b + let print_2byte oc b = + fprintf oc " .2byte 0x%X\n" b + let size_of_loc_expr = function | DW_OP_bregx _ -> 3 @@ -338,6 +341,20 @@ module DwarfPrinter(Target: DWARF_TARGET): List.iter (print_loc_expr oc) e | LocRef f -> print_ref oc f + let print_list_loc oc = function + | LocSymbol s -> + 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_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; + List.iter (print_loc_expr oc) e + | LocRef f -> print_ref oc f + let print_data_location oc dl = match dl with | DataLocBlock e -> @@ -547,7 +564,7 @@ module DwarfPrinter(Target: DWARF_TARGET): List.iter (fun (b,e,loc) -> fprintf oc " .4byte %a-%a\n" label b label c_low; fprintf oc " .4byte %a-%a\n" label e label c_low; - print_loc oc loc) l.loc; + print_list_loc oc loc) l.loc; fprintf oc " .4byte 0\n"; fprintf oc " .4byte 0\n" -- cgit From 5492b5b55afa68e3d628da07ff583a0cac79b7e3 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Mon, 28 Sep 2015 13:36:53 +0200 Subject: Added location for the formal parameters and move the end of all scopes before the last statement. --- debug/Debug.ml | 3 +++ debug/Debug.mli | 2 ++ debug/DebugInformation.ml | 29 ++++++++++++++++++++++------- debug/DebugInit.ml | 7 +++++-- debug/DwarfPrinter.ml | 6 ++++-- debug/DwarfTypes.mli | 1 + debug/Dwarfgen.ml | 38 ++++++++++++++++++++++---------------- 7 files changed, 59 insertions(+), 27 deletions(-) (limited to 'debug') diff --git a/debug/Debug.ml b/debug/Debug.ml index a496b610..d0de9e98 100644 --- a/debug/Debug.ml +++ b/debug/Debug.ml @@ -44,6 +44,7 @@ type implem = mutable stack_variable: 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; } let implem = @@ -70,6 +71,7 @@ let implem = stack_variable = (fun _ _ -> ()); function_end = (fun _ _ -> ()); add_label = (fun _ _ _ -> ()); + atom_parameter = (fun _ _ _ -> ()); } let init_compile_unit name = implem.init name @@ -94,3 +96,4 @@ 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 diff --git a/debug/Debug.mli b/debug/Debug.mli index 5ef1e7f5..c5fcddb3 100644 --- a/debug/Debug.mli +++ b/debug/Debug.mli @@ -42,6 +42,7 @@ type implem = mutable stack_variable: 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; } val implem: implem @@ -68,3 +69,4 @@ val stack_variable: atom -> int * int builtin_arg -> unit val function_end: atom -> positive -> unit val add_label: atom -> positive -> int -> unit val generate_debug_info: unit -> (dw_entry * dw_locations) option +val atom_parameter: ident -> ident -> atom -> unit diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index ec16f64e..8b6ec1ad 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -29,6 +29,10 @@ let next_id () = let reset_id () = id := 0 +(* Auximilary functions *) +let list_replace c f l = + List.map (fun a -> if c a then f a else a) l + (* The name of the current compilation unit *) let file_name: string ref = ref "" @@ -349,6 +353,7 @@ type global_variable_information = { type parameter_information = { parameter_name: string; + parameter_ident: int; parameter_atom: atom option; parameter_type: int; } @@ -512,6 +517,7 @@ let insert_global_declaration env dec= let ty = insert_type ty in { parameter_name = p.name; + parameter_ident = p.stamp; parameter_atom = None; parameter_type = ty; }) f.fd_params in @@ -572,9 +578,7 @@ 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 members = List.map (fun a -> if name a then - {a with cfd_byte_offset = Some offset;} - else a) comp.ct_members 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 = @@ -585,10 +589,9 @@ 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.map (fun a -> if name a then - {a with cfd_bit_offset = Some offset; cfd_bitfield = Some underlying; cfd_byte_size = Some size} - else - a) comp.ct_members in + 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;}) let atom_global_variable id atom = @@ -606,6 +609,14 @@ let atom_function id atom = 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_parameter fid id atom = + try + let fid',f = find_fun_stamp fid.stamp in + let name p = p.parameter_ident = id.stamp in + 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 @@ -763,6 +774,8 @@ let function_end atom loc = List.iter (close_range loc) !open_vars; open_vars:= [] +let compilation_section_start: (string,int) Hashtbl.t = Hashtbl.create 7 +let compilation_section_end: (string,int) Hashtbl.t = Hashtbl.create 7 let init name = id := 0; @@ -776,3 +789,5 @@ let init name = Hashtbl.reset stamp_to_local; Hashtbl.reset atom_to_local; Hashtbl.reset scope_to_local; + Hashtbl.reset compilation_section_start; + Hashtbl.reset compilation_section_end diff --git a/debug/DebugInit.ml b/debug/DebugInit.ml index 40be9f42..17db4354 100644 --- a/debug/DebugInit.ml +++ b/debug/DebugInit.ml @@ -40,7 +40,8 @@ let init_debug () = 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.add_label <- DebugInformation.add_label; + implem.atom_parameter <- DebugInformation.atom_parameter let init_none () = implem.init <- (fun _ -> ()); @@ -64,7 +65,9 @@ let init_none () = implem.end_live_range <- (fun _ _ -> ()); implem.stack_variable <- (fun _ _ -> ()); implem.function_end <- (fun _ _ -> ()); - implem.add_label <- (fun _ _ _ -> ()) + implem.add_label <- (fun _ _ _ -> ()); + implem.atom_parameter <- (fun _ _ _ -> ()) + let init () = if !Clflags.option_g then diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index 63ba4cd0..32c15dfd 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -131,7 +131,8 @@ module DwarfPrinter(Target: DWARF_TARGET): 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; - 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,variable_parameter_type_abbr)); + add_location e.formal_parameter_location buf | DW_TAG_label _ -> prologue 0xa; add_low_pc buf; @@ -419,7 +420,8 @@ module DwarfPrinter(Target: DWARF_TARGET): 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_variable_parameter print_flag; + print_opt_value oc fp.formal_parameter_location print_loc let print_tag_label oc tl = print_ref oc tl.label_low_pc; diff --git a/debug/DwarfTypes.mli b/debug/DwarfTypes.mli index 86a14163..8c2a7d56 100644 --- a/debug/DwarfTypes.mli +++ b/debug/DwarfTypes.mli @@ -107,6 +107,7 @@ type dw_tag_formal_parameter = formal_parameter_name: string option; formal_parameter_type: reference; formal_parameter_variable_parameter: flag option; + formal_parameter_location: location_value option; } type dw_tag_label = diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml index 4e531ca9..7fce22a7 100644 --- a/debug/Dwarfgen.ml +++ b/debug/Dwarfgen.ml @@ -145,6 +145,7 @@ let fun_type_to_entry id f = 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; } in new_entry (next_id ()) (DW_TAG_formal_parameter fp)) f.fun_params; in @@ -272,16 +273,6 @@ let global_variable_to_entry acc id v = } in new_entry id (DW_TAG_variable var),IntSet.add v.gvar_type acc -let function_parameter_to_entry acc p = - let p = { - formal_parameter_file_loc = None; - formal_parameter_artificial = None; - formal_parameter_name = Some p.parameter_name; - formal_parameter_type = p.parameter_type; - formal_parameter_variable_parameter = None; - } in - new_entry (next_id ()) (DW_TAG_formal_parameter p),IntSet.add p.formal_parameter_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) @@ -317,10 +308,10 @@ let range_entry_loc (sp,l) = | [a] -> LocSimple a | a::rest -> LocList (a::rest) -let rec local_variable_to_entry f_id (acc,bcc) v id = - let loc,loc_list = try +let location_entry f_id atom = + try begin - match (Hashtbl.find var_locations (get_opt_val v.lvar_atom)) with + match (Hashtbl.find var_locations atom) with | FunctionLoc (a,r) -> translate_function_loc a r | RangeLoc l -> @@ -331,9 +322,24 @@ let rec local_variable_to_entry f_id (acc,bcc) v id = 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;}] + Some (LocRef id),[{loc = l;loc_id = id;}] end - with Not_found -> None,[] in + 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_file_loc = None; + 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) + +let rec local_variable_to_entry f_id (acc,bcc) v id = + let loc,loc_list = location_entry f_id (get_opt_val v.lvar_atom) in let var = { variable_file_loc = v.lvar_file_loc; variable_declaration = None; @@ -392,7 +398,7 @@ let function_to_entry (acc,bcc) id f = 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 = mmap function_parameter_to_entry acc f.fun_parameter 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) -- cgit From 68ad5472a78d12e0e4fd4eae422122185403d678 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Mon, 28 Sep 2015 18:39:43 +0200 Subject: Change the way the debug sections are printed. If a user uses the #pragma use_section for functions the diab linker requires a separate debug_info section for each entry. This commit adds functionality to emulate this behavior. --- debug/Debug.ml | 15 ++++-- debug/Debug.mli | 10 +++- debug/DebugInformation.ml | 25 +++++++++- debug/DebugInit.ml | 14 ++++-- debug/DwarfPrinter.ml | 57 +++++++++++------------ debug/DwarfPrinter.mli | 2 +- debug/DwarfTypes.mli | 16 ++++--- debug/Dwarfgen.ml | 116 +++++++++++++++++++++++++++------------------- 8 files changed, 159 insertions(+), 96 deletions(-) (limited to 'debug') diff --git a/debug/Debug.ml b/debug/Debug.ml index d0de9e98..1d3b260e 100644 --- a/debug/Debug.ml +++ b/debug/Debug.ml @@ -30,7 +30,7 @@ type implem = 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: unit -> (dw_entry * dw_locations) option; + 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; @@ -45,6 +45,9 @@ type implem = 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 * int * int * string) -> unit; + mutable compute_file_enum: (string -> int) -> (string-> int) -> (unit -> unit) -> unit; + mutable exists_section: string -> bool; } let implem = @@ -57,7 +60,7 @@ let implem = set_bitfield_offset = (fun _ _ _ _ _ -> ()); insert_global_declaration = (fun _ _ -> ()); add_fun_addr = (fun _ _ -> ()); - generate_debug_info = (fun _ -> None); + generate_debug_info = (fun _ _ -> None); all_files_iter = (fun _ -> ()); insert_local_declaration = (fun _ _ _ _ -> ()); atom_local_variable = (fun _ _ -> ()); @@ -72,6 +75,9 @@ let implem = function_end = (fun _ _ -> ()); add_label = (fun _ _ _ -> ()); atom_parameter = (fun _ _ _ -> ()); + add_compilation_section_start = (fun _ _ -> ()); + compute_file_enum = (fun _ _ _ -> ()); + exists_section = (fun _ -> true); } let init_compile_unit name = implem.init name @@ -82,7 +88,7 @@ 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 () = implem.generate_debug_info () +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 @@ -97,3 +103,6 @@ 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 exists_section sec = implem.exists_section sec +let compute_file_enum end_l entry_l line_e = implem.compute_file_enum end_l entry_l line_e diff --git a/debug/Debug.mli b/debug/Debug.mli index c5fcddb3..166a6759 100644 --- a/debug/Debug.mli +++ b/debug/Debug.mli @@ -28,7 +28,7 @@ type implem = 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: unit -> (dw_entry * dw_locations) option; + 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; @@ -43,6 +43,9 @@ type implem = 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 * int * int * string) -> unit; + mutable compute_file_enum: (string -> int) -> (string-> int) -> (unit -> unit) -> unit; + mutable exists_section: string -> bool; } val implem: implem @@ -68,5 +71,8 @@ val end_live_range: atom -> positive -> unit val stack_variable: atom -> int * int builtin_arg -> unit val function_end: atom -> positive -> unit val add_label: atom -> positive -> int -> unit -val generate_debug_info: unit -> (dw_entry * dw_locations) option +val generate_debug_info: (atom -> string) -> string -> debug_entries option val atom_parameter: ident -> ident -> atom -> unit +val add_compilation_section_start: string -> (int * int * int * string) -> unit +val compute_file_enum: (string -> int) -> (string-> int) -> (unit -> unit) -> unit +val exists_section: string -> bool diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index 8b6ec1ad..7866c339 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -774,9 +774,28 @@ let function_end atom loc = List.iter (close_range loc) !open_vars; open_vars:= [] -let compilation_section_start: (string,int) Hashtbl.t = Hashtbl.create 7 +let compilation_section_start: (string,int * int * int * string) Hashtbl.t = Hashtbl.create 7 let compilation_section_end: (string,int) Hashtbl.t = Hashtbl.create 7 +let add_compilation_section_start sec addr = + Hashtbl.add compilation_section_start sec addr + +let add_compilation_section_end sec addr = + Hashtbl.add compilation_section_end sec addr + +let exists_section sec = + Hashtbl.mem compilation_section_start sec + +let filenum: (string * string,int) Hashtbl.t = Hashtbl.create 7 + +let compute_file_enum end_label entry_label line_end = + Hashtbl.iter (fun sec (_,_,_,secname) -> + Hashtbl.add compilation_section_end sec (end_label secname); + StringSet.iter (fun file -> + let lbl = entry_label file in + Hashtbl.add filenum (sec,file) lbl) !all_files; + line_end ()) compilation_section_start + let init name = id := 0; file_name := name; @@ -790,4 +809,6 @@ let init name = Hashtbl.reset atom_to_local; Hashtbl.reset scope_to_local; Hashtbl.reset compilation_section_start; - Hashtbl.reset compilation_section_end + Hashtbl.reset compilation_section_end; + Hashtbl.reset filenum; + all_files := StringSet.empty diff --git a/debug/DebugInit.ml b/debug/DebugInit.ml index 17db4354..e0c435cd 100644 --- a/debug/DebugInit.ml +++ b/debug/DebugInit.ml @@ -27,7 +27,7 @@ let init_debug () = 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 <- (fun () -> Some (Dwarfgen.gen_debug_info ())); + implem.generate_debug_info <- (fun a b -> Some (Dwarfgen.gen_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; @@ -41,7 +41,10 @@ let init_debug () = 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.atom_parameter <- DebugInformation.atom_parameter; + implem.add_compilation_section_start <- DebugInformation.add_compilation_section_start; + implem.compute_file_enum <- DebugInformation.compute_file_enum; + implem.exists_section <- DebugInformation.exists_section let init_none () = implem.init <- (fun _ -> ()); @@ -52,7 +55,7 @@ let init_none () = implem.set_bitfield_offset <- (fun _ _ _ _ _ -> ()); implem.insert_global_declaration <- (fun _ _ -> ()); implem.add_fun_addr <- (fun _ _ -> ()); - implem.generate_debug_info <- (fun _ -> None); + implem.generate_debug_info <- (fun _ _ -> None); implem.all_files_iter <- (fun _ -> ()); implem.insert_local_declaration <- (fun _ _ _ _ -> ()); implem.atom_local_variable <- (fun _ _ -> ()); @@ -66,8 +69,9 @@ let init_none () = implem.stack_variable <- (fun _ _ -> ()); implem.function_end <- (fun _ _ -> ()); implem.add_label <- (fun _ _ _ -> ()); - implem.atom_parameter <- (fun _ _ _ -> ()) - + implem.atom_parameter <- (fun _ _ _ -> ()); + implem.add_compilation_section_start <- (fun _ _ -> ()); + implem.exists_section <- (fun _ -> true) let init () = if !Clflags.option_g then diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index 32c15dfd..aa1c187f 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -21,7 +21,7 @@ open Sections (* The printer is parameterized over target specific functions and a set of dwarf type constants *) module DwarfPrinter(Target: DWARF_TARGET): sig - val print_debug: out_channel -> dw_entry -> dw_locations -> unit + val print_debug: out_channel -> debug_entries -> unit end = struct @@ -245,7 +245,7 @@ module DwarfPrinter(Target: DWARF_TARGET): let print_abbrev oc = let abbrevs = Hashtbl.fold (fun s i acc -> (s,i)::acc) abbrev_mapping [] in let abbrevs = List.sort (fun (_,a) (_,b) -> Pervasives.compare a b) abbrevs in - fprintf oc " .section %s\n" (name_of_section Section_debug_abbrev); + section oc Section_debug_abbrev; let lbl = new_label () in abbrev_start_addr := lbl; print_label oc lbl; @@ -275,9 +275,6 @@ module DwarfPrinter(Target: DWARF_TARGET): | None -> () | Some o -> f oc o - let print_file_loc oc f = - print_opt_value oc f print_file_loc - let print_flag oc b = output_string oc (string_of_byte b) @@ -296,6 +293,15 @@ module DwarfPrinter(Target: DWARF_TARGET): let print_2byte oc b = fprintf oc " .2byte 0x%X\n" b + let print_ref oc r = + let ref = entry_to_label r in + fprintf oc " .4byte %a\n" label ref + + let print_file_loc oc = function + | Some (file,col) -> + fprintf oc " .4byte %a\n" label file; + print_uleb128 oc col + | None -> () let size_of_loc_expr = function | DW_OP_bregx _ -> 3 @@ -322,11 +328,6 @@ module DwarfPrinter(Target: DWARF_TARGET): print_uleb128 oc i end - - let print_ref oc r = - let ref = entry_to_label r in - fprintf oc " .4byte %a\n" label ref - let print_loc oc loc = match loc with | LocSymbol s -> @@ -394,12 +395,12 @@ module DwarfPrinter(Target: DWARF_TARGET): let print_compilation_unit oc tag = let prod_name = sprintf "AbsInt Angewandte Informatik GmbH:CompCert Version %s:%s" Version.version Configuration.arch in print_string oc (Sys.getcwd ()); - print_addr oc (get_start_addr ()); - print_addr oc (get_end_addr ()); + 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_addr oc (get_stmt_list_addr ()) + print_addr oc tag.compile_unit_stmt_list let print_const_type oc ct = print_ref oc ct.const_type @@ -539,16 +540,15 @@ module DwarfPrinter(Target: DWARF_TARGET): print_sleb128 oc 0) entry (* Print the debug abbrev section *) - let print_debug_abbrev oc entry = - compute_abbrev entry; + 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 entry = - let debug_start = new_label () in - debug_start_addr:= debug_start; - fprintf oc" .section %s\n" (name_of_section Section_debug_info); - print_label oc debug_start; + let print_debug_info oc sec start entry = + debug_start_addr:= start; + section oc (Section_debug_info sec); + 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; @@ -560,8 +560,7 @@ module DwarfPrinter(Target: DWARF_TARGET): print_sleb128 oc 0; print_label oc debug_end (* End of the debug section *) - let print_location_entry oc l = - let c_low = get_start_addr () in + let print_location_entry oc c_low l = print_label oc (entry_to_label l.loc_id); List.iter (fun (b,e,loc) -> fprintf oc " .4byte %a-%a\n" label b label c_low; @@ -570,15 +569,15 @@ module DwarfPrinter(Target: DWARF_TARGET): fprintf oc " .4byte 0\n"; fprintf oc " .4byte 0\n" - let print_location_list oc l = - fprintf oc" .section %s\n" (name_of_section Section_debug_loc); - List.iter (print_location_entry oc) l + let print_location_list oc (c_low,l) = + List.iter (print_location_entry oc c_low) l (* Print the debug info and abbrev section *) - let print_debug oc entry loc = - print_debug_abbrev oc entry; - print_debug_info oc entry; - print_location_list oc loc + let print_debug oc entries = + print_debug_abbrev oc entries; + List.iter (fun (s,d,e,_) -> print_debug_info oc s d e) entries; + section oc Section_debug_loc; + List.iter (fun (_,_,_,l) -> print_location_list oc l) entries end diff --git a/debug/DwarfPrinter.mli b/debug/DwarfPrinter.mli index 8b206a00..e1e10601 100644 --- a/debug/DwarfPrinter.mli +++ b/debug/DwarfPrinter.mli @@ -14,5 +14,5 @@ open DwarfTypes module DwarfPrinter: functor (Target: DWARF_TARGET) -> sig - val print_debug: out_channel -> dw_entry -> dw_locations -> unit + val print_debug: out_channel -> debug_entries -> unit end diff --git a/debug/DwarfTypes.mli b/debug/DwarfTypes.mli index 8c2a7d56..906b7cba 100644 --- a/debug/DwarfTypes.mli +++ b/debug/DwarfTypes.mli @@ -60,7 +60,7 @@ type bound_value = (* Types representing the attribute information per tag value *) -type file_loc = string * constant +type file_loc = int * constant type dw_tag_array_type = { @@ -77,7 +77,10 @@ type dw_tag_base_type = type dw_tag_compile_unit = { - compile_unit_name: string; + compile_unit_name: string; + compile_unit_low_pc: int; + compile_unit_high_pc: int; + compile_unit_stmt_list: int; } type dw_tag_const_type = @@ -243,16 +246,15 @@ type location_entry = loc: (int * int * location_value) list; loc_id: reference; } -type dw_locations = location_entry list +type dw_locations = int * location_entry list + +type debug_entries = (string * int * dw_entry * dw_locations) list (* The target specific functions for printing the debug information *) module type DWARF_TARGET= sig val label: out_channel -> int -> unit val print_file_loc: out_channel -> file_loc -> unit - val get_start_addr: unit -> int - val get_end_addr: unit -> int - val get_stmt_list_addr: unit -> int - val name_of_section: section_name -> string + val section: out_channel -> section_name -> unit val symbol: out_channel -> atom -> unit end diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml index 7fce22a7..3239ceb6 100644 --- a/debug/Dwarfgen.ml +++ b/debug/Dwarfgen.ml @@ -72,10 +72,20 @@ let void_to_entry id = } in new_entry id (DW_TAG_base_type void) -let typedef_to_entry id t = +let translate_file_loc sec (f,l) = + Hashtbl.find filenum (sec,f),l + +let translate_file_loc_opt sec = function + | None -> None + | Some (f,l) -> + try + Some (translate_file_loc sec (f,l)) + with Not_found -> None + +let typedef_to_entry sec id t = let i = get_opt_val t.typ in let td = { - typedef_file_loc = t.typedef_file_loc; + typedef_file_loc = translate_file_loc_opt sec t.typedef_file_loc; typedef_name = t.typedef_name; typedef_type = i; } in @@ -110,7 +120,7 @@ let const_to_entry id c = 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 enum_to_entry sec id e = let enumerator_to_entry e = let tag = { @@ -121,7 +131,7 @@ let enum_to_entry id e = new_entry (next_id ()) (DW_TAG_enumerator tag) in let bs = sizeof_ikind enum_ikind in let enum = { - enumeration_file_loc = e.enum_file_loc; + enumeration_file_loc = translate_file_loc_opt sec e.enum_file_loc; enumeration_byte_size = bs; enumeration_declaration = Some false; enumeration_name = Some e.enum_name; @@ -172,9 +182,9 @@ let member_to_entry mem = } in new_entry (next_id ()) (DW_TAG_member mem) -let struct_to_entry id s = +let struct_to_entry sec id s = let tag = { - structure_file_loc = s.ct_file_loc; + structure_file_loc = translate_file_loc_opt sec s.ct_file_loc; structure_byte_size = s.ct_sizeof; structure_declaration = Some s.ct_declaration; structure_name = if s.ct_name <> "" then Some s.ct_name else None; @@ -183,9 +193,9 @@ let struct_to_entry id s = let child = List.map member_to_entry s.ct_members in add_children entry child -let union_to_entry id s = +let union_to_entry sec id s = let tag = { - union_file_loc = s.ct_file_loc; + union_file_loc = translate_file_loc_opt sec s.ct_file_loc; union_byte_size = s.ct_sizeof; union_declaration = Some s.ct_declaration; union_name = if s.ct_name <> "" then Some s.ct_name else None; @@ -194,20 +204,20 @@ let union_to_entry id s = let child = List.map member_to_entry s.ct_members in add_children entry child -let composite_to_entry id s = +let composite_to_entry sec id s = match s.ct_sou with - | Struct -> struct_to_entry id s - | Union -> union_to_entry id s + | Struct -> struct_to_entry sec id s + | Union -> union_to_entry sec id s -let infotype_to_entry id = function +let infotype_to_entry sec 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 + | CompositeType c -> composite_to_entry sec id c + | EnumType e -> enum_to_entry sec id e | FunctionType f -> fun_type_to_entry id f - | Typedef t -> typedef_to_entry id t + | Typedef t -> typedef_to_entry sec id t | ConstType c -> const_to_entry id c | VolatileType v -> volatile_to_entry id v | Void -> void_to_entry id @@ -246,7 +256,7 @@ let needs_types id d = let d,c' = add_type f.cfd_typ d in d,c||c') (d,false) c.ct_members -let gen_types needed = +let gen_types sec needed = let rec aux d = let d,c = IntSet.fold (fun id (d,c) -> let d,c' = needs_types id d in @@ -258,13 +268,13 @@ let gen_types needed = 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 + (infotype_to_entry sec id t)::acc else acc) types []) -let global_variable_to_entry acc id v = +let global_variable_to_entry sec acc id v = let var = { - variable_file_loc = v.gvar_file_loc; + variable_file_loc = translate_file_loc sec v.gvar_file_loc; variable_declaration = Some v.gvar_declaration; variable_external = Some v.gvar_external; variable_name = v.gvar_name; @@ -338,10 +348,10 @@ let function_parameter_to_entry f_id (acc,bcc) p = } 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 = +let rec local_variable_to_entry sec f_id (acc,bcc) v id = let loc,loc_list = location_entry f_id (get_opt_val v.lvar_atom) in let var = { - variable_file_loc = v.lvar_file_loc; + variable_file_loc = translate_file_loc sec v.lvar_file_loc; variable_declaration = None; variable_external = None; variable_name = v.lvar_name; @@ -350,7 +360,7 @@ let rec local_variable_to_entry f_id (acc,bcc) v id = } in 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 = +and scope_to_entry sec 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 @@ -367,27 +377,27 @@ and scope_to_entry f_id acc sc id = lexical_block_high_pc = h_pc; lexical_block_low_pc = l_pc; } in - let vars,acc = mmap (local_to_entry f_id) acc sc.scope_variables in + let vars,acc = mmap (local_to_entry sec 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 = +and local_to_entry sec f_id acc id = match Hashtbl.find local_variables id with - | LocalVariable v -> local_variable_to_entry f_id acc v id - | Scope v -> scope_to_entry f_id acc v id + | LocalVariable v -> local_variable_to_entry sec f_id acc v id + | Scope v -> scope_to_entry sec f_id acc v id -let fun_scope_to_entries f_id acc id = +let fun_scope_to_entries sec 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 (local_to_entry f_id) acc sc.scope_variables + | Scope sc ->mmap (local_to_entry sec f_id) acc sc.scope_variables | _ -> assert false) -let function_to_entry (acc,bcc) id f = +let function_to_entry sec (acc,bcc) id f = let f_tag = { - subprogram_file_loc = f.fun_file_loc; + subprogram_file_loc = translate_file_loc sec f.fun_file_loc; subprogram_external = Some f.fun_external; subprogram_name = f.fun_name; subprogram_prototyped = true; @@ -399,24 +409,36 @@ let function_to_entry (acc,bcc) id f = 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 + let vars,(acc,bcc) = fun_scope_to_entries sec f_id (acc,bcc) f.fun_scope in add_children f_entry (params@vars),(acc,bcc) -let definition_to_entry (acc,bcc) id t = +let definition_to_entry sec (acc,bcc) id t = match t with - | GlobalVariable g -> let e,acc = global_variable_to_entry acc id g in + | GlobalVariable g -> let e,acc = global_variable_to_entry sec acc id g in e,(acc,bcc) - | Function f -> function_to_entry (acc,bcc) id f - -let gen_defs () = - let defs,(typ,locs) = Hashtbl.fold (fun id t (acc,bcc) -> let t,bcc = definition_to_entry bcc id t in - t::acc,bcc) definitions ([],(IntSet.empty,[])) in - List.rev defs,typ,locs - -let gen_debug_info () : dw_entry * dw_locations= - let cp = { - compile_unit_name = !file_name; - } in - let cp = new_entry (next_id ()) (DW_TAG_compile_unit cp) in - let defs,ty,locs = gen_defs () in - add_children cp ((gen_types ty) @ defs),locs + | Function f -> function_to_entry sec (acc,bcc) id f + +module StringMap = Map.Make(String) + +let gen_debug_info sec_name var_section : debug_entries = + let defs = Hashtbl.fold (fun id t acc -> + let s = match t with + | GlobalVariable _ -> var_section + | 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 + StringMap.fold (fun s defs acc -> + let defs,(ty,locs) = List.fold_left (fun (acc,bcc) (id,t) -> + let t,bcc = definition_to_entry s bcc id t in + t::acc,bcc) ([],(IntSet.empty,[])) defs in + let line_start,low_pc,debug_start,_ = Hashtbl.find compilation_section_start 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; + compile_unit_stmt_list = line_start; + } in + let cp = new_entry (next_id ()) (DW_TAG_compile_unit cp) in + let cp = add_children cp ((gen_types s ty) @ defs) in + (s,debug_start,cp,(low_pc,locs))::acc) defs [] -- cgit From 4e0ffb627524e3a251ee9e82ed88e1ed45e26b16 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Tue, 29 Sep 2015 16:02:56 +0200 Subject: Deactivate the debug functions for none advanced targets. --- debug/DebugInit.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'debug') diff --git a/debug/DebugInit.ml b/debug/DebugInit.ml index e0c435cd..6a50b020 100644 --- a/debug/DebugInit.ml +++ b/debug/DebugInit.ml @@ -74,7 +74,7 @@ let init_none () = implem.exists_section <- (fun _ -> true) let init () = - if !Clflags.option_g then + if !Clflags.option_g && Configuration.advanced_debug then init_debug () else init_none () -- cgit From 05acff8bcb4f127a6f0ff6c587ba38d1c8cbe2fc Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Tue, 29 Sep 2015 18:35:36 +0200 Subject: More fixes for the DebugInformation. Changed the sizeof function to take into account the bytes needed for the sleb128/uleb128 encoding of the DW_OP_* arguments and changed the end_live_range function to only close functions where the live range is currently open. --- debug/DebugInformation.ml | 21 ++++++++------------- debug/DwarfPrinter.ml | 9 ++------- debug/DwarfUtil.ml | 27 +++++++++++++++++++++++++++ debug/Dwarfgen.ml | 1 + 4 files changed, 38 insertions(+), 20 deletions(-) (limited to 'debug') diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index 7866c339..73f9163a 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -256,10 +256,15 @@ let insert_type (ty: typ) = } in FunctionType ftype | TNamed (id,_) -> + let typ = try + let _,t = + List.find (fun a -> fst a = id.name) CBuiltins.builtins.Builtins.typedefs in + Some (attr_aux t) + with Not_found -> None in let t = { typedef_file_loc = None; typedef_name = id.name; - typ = None; + typ = typ; } in Typedef t | TStruct (id,_) -> @@ -749,17 +754,7 @@ let end_live_range atom lbl = let old_r = Hashtbl.find var_locations atom in match old_r with | RangeLoc (n_r::old_r) -> - let n_r = {n_r with range_end = Some lbl} in - Hashtbl.replace var_locations atom (RangeLoc (n_r::old_r)) - | _ -> assert false - with Not_found -> () - -let close_range lbl atom = - try - let old_r = Hashtbl.find var_locations atom in - match old_r with - | RangeLoc (n_r::old_r) -> - if n_r.range_end = None then + if n_r.range_end = None then (* We can skip non open locations *) let n_r = {n_r with range_end = Some lbl} in Hashtbl.replace var_locations atom (RangeLoc (n_r::old_r)) | _ -> assert false @@ -771,7 +766,7 @@ let stack_variable atom (sp,loc) = let function_end atom loc = IntSet.iter (fun id -> close_scope atom id loc) !open_scopes; open_scopes := IntSet.empty; - List.iter (close_range loc) !open_vars; + List.iter (fun atom -> end_live_range atom loc) !open_vars; open_vars:= [] let compilation_section_start: (string,int * int * int * string) Hashtbl.t = Hashtbl.create 7 diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index aa1c187f..a95c71a1 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -303,12 +303,6 @@ module DwarfPrinter(Target: DWARF_TARGET): print_uleb128 oc col | None -> () - let size_of_loc_expr = function - | DW_OP_bregx _ -> 3 - | DW_OP_plus_uconst _ -> 2 - | DW_OP_piece _ -> 2 - | DW_OP_reg i -> if i < 32 then 1 else 2 - let print_loc_expr oc = function | DW_OP_bregx (a,b) -> print_byte oc dw_op_bregx; @@ -316,7 +310,7 @@ module DwarfPrinter(Target: DWARF_TARGET): fprintf oc " .sleb128 %ld\n" b | DW_OP_plus_uconst i -> print_byte oc dw_op_plus_uconst; - print_byte oc i + print_uleb128 oc i | DW_OP_piece i -> print_byte oc dw_op_piece; print_uleb128 oc i @@ -360,6 +354,7 @@ module DwarfPrinter(Target: DWARF_TARGET): let print_data_location oc dl = match dl with | DataLocBlock e -> + print_sleb128 oc (size_of_loc_expr e); print_loc_expr oc e | _ -> () diff --git a/debug/DwarfUtil.ml b/debug/DwarfUtil.ml index e1869281..16e446ee 100644 --- a/debug/DwarfUtil.ml +++ b/debug/DwarfUtil.ml @@ -113,3 +113,30 @@ 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 + +(* Sizeof functions for the encoding of uleb128 and sleb128 *) +let sizeof_uleb128 value = + let size = ref 1 in + let value = ref (value lsr 7) in + while !value <> 0 do + value := !value lsr 7; + incr size; + done; + !size + +let sizeof_sleb128 value = + let size = ref 1 in + let byte = ref (value land 0x7f) in + let value = ref (value lsr 7) in + while not ((!value = 0 && (!byte land 0x40) = 0) || (!value = -1 && ((!byte land 0x40) <> 0))) do + byte := !value land 0x7f; + value := !value lsr 7; + incr size; + done; + !size + +let size_of_loc_expr = function + | DW_OP_bregx (a,b) -> 1 + (sizeof_uleb128 a) + (sizeof_sleb128 (Int32.to_int b)) + | DW_OP_plus_uconst a + | DW_OP_piece a -> 1 + (sizeof_uleb128 a) + | DW_OP_reg i -> if i < 32 then 1 else 2 diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml index 3239ceb6..ac32f9f1 100644 --- a/debug/Dwarfgen.ml +++ b/debug/Dwarfgen.ml @@ -235,6 +235,7 @@ let needs_types id d = | Void | EnumType _ -> d,false | Typedef t -> + Printf.printf "Typedef %s\n" t.typedef_name; add_type (get_opt_val t.typ) d | PointerType p -> add_type p.pts d -- cgit From c0757aa180c54ff61093e8079ef58b77775ba28e Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Wed, 30 Sep 2015 11:13:34 +0200 Subject: Avoid problem with implict declarations. In order to avoid the problem that the stamp is not correct for implict declarations I insert all possible stamps of a function into my mapping and assign them one debug id. --- debug/DebugInformation.ml | 21 ++++++++++++++++++--- debug/Dwarfgen.ml | 1 - 2 files changed, 18 insertions(+), 4 deletions(-) (limited to 'debug') diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index 73f9163a..3bf26e53 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -387,6 +387,9 @@ let definitions: (int,definition_type) Hashtbl.t = Hashtbl.create 7 (* Mapping from stamp to debug id *) let stamp_to_definition: (int,int) Hashtbl.t = Hashtbl.create 7 +(* Mapping from name to debug id *) +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 @@ -510,8 +513,13 @@ let insert_global_declaration env dec= let id,var = find_gvar_stamp id.stamp in replace_var id ({var with gvar_declaration = false;}) end - end - | Gfundef f -> + end else if not (Hashtbl.mem name_to_definition id.name) then begin + (* Implict declarations need special handling *) + let id' = next_id () in + Hashtbl.add stamp_to_definition id.stamp id'; + Hashtbl.add name_to_definition id.name id' + end + | Gfundef f -> let ret = (match f.fd_ret with | TVoid _ -> None | _ -> Some (insert_type f.fd_ret)) in @@ -539,7 +547,13 @@ let insert_global_declaration env dec= fun_high_pc = None; fun_scope = None; } in - insert (Function fd) f.fd_name.stamp + begin try + let id' = Hashtbl.find name_to_definition f.fd_name.name in + Hashtbl.add stamp_to_definition f.fd_name.stamp id'; + Hashtbl.add definitions id' (Function fd) + with Not_found -> + insert (Function fd) f.fd_name.stamp + end | Gcompositedecl (sou,id,at) -> ignore (insert_type (gen_comp_typ sou id at)); let id = find_type (gen_comp_typ sou id []) in @@ -798,6 +812,7 @@ let init name = Hashtbl.reset lookup_types; Hashtbl.reset definitions; Hashtbl.reset stamp_to_definition; + Hashtbl.reset name_to_definition; Hashtbl.reset atom_to_definition; Hashtbl.reset local_variables; Hashtbl.reset stamp_to_local; diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml index ac32f9f1..3239ceb6 100644 --- a/debug/Dwarfgen.ml +++ b/debug/Dwarfgen.ml @@ -235,7 +235,6 @@ let needs_types id d = | Void | EnumType _ -> d,false | Typedef t -> - Printf.printf "Typedef %s\n" t.typedef_name; add_type (get_opt_val t.typ) d | PointerType p -> add_type p.pts d -- cgit From ee76d81e0e7d8a76cd31bf0d01a532d248dca45a Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Wed, 30 Sep 2015 12:43:49 +0200 Subject: Fixed minor issue with parameters that get put on the stack, made the code more robust and added indentation for convertCompositeDef --- debug/DebugInformation.ml | 19 ++++++++----------- 1 file changed, 8 insertions(+), 11 deletions(-) (limited to 'debug') diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index 3bf26e53..382845a4 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -752,16 +752,13 @@ let close_scope atom s_id lbl = with Not_found -> () let start_live_range atom lbl loc = - let old_r = try - begin - match Hashtbl.find var_locations atom with - | RangeLoc old_r -> old_r - | _ -> assert false - end - with Not_found -> [] in - let n_r = { range_start = Some lbl; range_end = None; var_loc = loc } in - open_vars := atom::!open_vars; - Hashtbl.replace var_locations atom (RangeLoc (n_r::old_r)) + let old_r = begin try Hashtbl.find var_locations atom with Not_found -> (RangeLoc []) end in + match old_r with + | RangeLoc old_r -> + let n_r = { range_start = Some lbl; range_end = None; var_loc = loc } in + open_vars := atom::!open_vars; + Hashtbl.replace var_locations atom (RangeLoc (n_r::old_r)) + | _ -> () (* Parameter that is passed as variable *) let end_live_range atom lbl = try @@ -771,7 +768,7 @@ let end_live_range atom lbl = if n_r.range_end = None then (* We can skip non open locations *) let n_r = {n_r with range_end = Some lbl} in Hashtbl.replace var_locations atom (RangeLoc (n_r::old_r)) - | _ -> assert false + | _ -> () with Not_found -> () let stack_variable atom (sp,loc) = -- cgit