From f750e0ac9ee99072cca8361f591015f1f82681fa Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Wed, 18 Mar 2015 18:36:09 +0100 Subject: Added function to convert C types into their dwarf represnation. --- debug/CtoDwarf.ml | 168 +++++++++++++++++++++++++++++++- debug/DwarfPrinter.ml | 43 +++++---- debug/DwarfTypes.ml | 258 ------------------------------------------------- debug/DwarfTypes.mli | 259 ++++++++++++++++++++++++++++++++++++++++++++++++++ debug/DwarfUtil.ml | 7 +- 5 files changed, 457 insertions(+), 278 deletions(-) delete mode 100644 debug/DwarfTypes.ml create mode 100644 debug/DwarfTypes.mli (limited to 'debug') diff --git a/debug/CtoDwarf.ml b/debug/CtoDwarf.ml index 0ee0842a..b7f417f6 100644 --- a/debug/CtoDwarf.ml +++ b/debug/CtoDwarf.ml @@ -10,9 +10,175 @@ (* *) (* *********************************************************************) +open C +open Cprint +open DwarfTypes +open DwarfUtil +open Machine + (* Functions to translate a C Ast into Dwarf 2 debugging information *) -(* Hashtable to from type name to entry id *) +(* Hashtable from type name to entry id *) let type_table: (string, int) Hashtbl.t = Hashtbl.create 7 +(* Hashtable from typedefname to entry id *) +let defined_types_table: (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 + 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) + +let rec type_to_dwarf (typ: typ): int * dw_entry list = + let typ_string = typ_to_string typ in + try + Hashtbl.find type_table typ_string,[] + with Not_found -> + let attr_to_dw attr_list id entries = + List.fold_left (fun (id,entry) attr -> + match attr with + | AConst -> let const_tag = DW_TAG_const_type ({const_type = id;}) in + let const_entry = new_entry const_tag in + const_entry.id,const_entry::entry + | AVolatile -> let volatile_tag = DW_TAG_volatile_type ({volatile_type = id;}) in + let volatile_entry = new_entry volatile_tag in + volatile_entry.id,volatile_entry::entry + | ARestrict + | AAlignas _ + | Attr _ -> id,entry) (id,entries) (List.rev attr_list) in + let attr_to_dw_tag attr_list tag = + let entry = new_entry tag in + attr_to_dw attr_list entry.id [entry] in + let id,entries = + match typ with + | TVoid at -> let void = { + base_type_byte_size = 0; + base_type_encoding = None; + base_type_name = "void"; + } in + attr_to_dw_tag at (DW_TAG_base_type void) + | TInt (k,at) -> + let byte_size,encoding,name = + (match k with + | IBool -> 1,DW_ATE_boolean,"_Bool" + | IChar -> 1,(if !config.char_signed then DW_ATE_signed_char else DW_ATE_unsigned_char),"char" + | ISChar -> 1,DW_ATE_signed_char,"signed char" + | IUChar -> 1,DW_ATE_unsigned_char,"unsigned char" + | IInt -> !config.sizeof_int,DW_ATE_signed,"signed int" + | IUInt -> !config.sizeof_int,DW_ATE_unsigned,"unsigned int" + | IShort -> !config.sizeof_short,DW_ATE_signed,"signed short" + | IUShort -> !config.sizeof_short,DW_ATE_unsigned,"unsigned short" + | ILong -> !config.sizeof_long, DW_ATE_signed,"long" + | IULong -> !config.sizeof_long, DW_ATE_unsigned,"unsigned long" + | ILongLong -> !config.sizeof_longlong, DW_ATE_signed,"long long" + | IULongLong -> !config.sizeof_longlong, DW_ATE_unsigned,"unsigned long long")in + let int = { + base_type_byte_size = byte_size; + base_type_encoding = Some encoding; + base_type_name = name;} in + attr_to_dw_tag at (DW_TAG_base_type int) + | TFloat (k,at) -> + let byte_size,name = + (match k with + | FFloat -> !config.sizeof_float,"float" + | FDouble -> !config.sizeof_double,"double" + | FLongDouble -> !config.sizeof_longdouble,"long double") in + let float = { + base_type_byte_size = byte_size; + base_type_encoding = Some DW_ATE_float; + base_type_name = name; + } in + attr_to_dw_tag at (DW_TAG_base_type float) + | TPtr (t,at) -> + let t,e = type_to_dwarf t in + let pointer = {pointer_type = t;} in + let t,e2 = attr_to_dw_tag at (DW_TAG_pointer_type pointer) in + t,e2@e + | TFun (rt,args,_,at) -> + let ret,et = (match rt with + | TVoid _ -> None,[] (* Void return *) + | _ -> 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 (_,t) -> + let t,e = type_to_dwarf t in + let fp = + { + 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 + 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 + attr_to_dw at s.id ((s::others)@et) + | TStruct (i,at) + | TUnion (i,at) + | TEnum (i,at) + | TNamed (i,at) -> + let t = Hashtbl.find defined_types_table i.name in + attr_to_dw at t [] + | TArray (child,size,at) -> + let size_to_subrange s = + let b = (match s with + | None -> None + | Some i -> + let i = Int64.to_int i in + Some (BoundConst i)) in + let s = { + subrange_type = None; + subrange_upper_bound = b; + } in + 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,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 (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 + attr_to_dw at arr.id (arr::e) + in + Hashtbl.add type_table typ_string id; + id,entries + diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index 07d62998..0b175563 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -130,9 +130,9 @@ module DwarfPrinter(Target: TARGET) : prologue 0x1; add_attr_some e.array_type_file_loc add_file_loc; add_type buf - | DW_TAG_base_type _ -> + | DW_TAG_base_type b -> prologue 0x24; - add_encoding buf; + add_attr_some b.base_type_encoding add_encoding; add_byte_size buf; add_name buf | DW_TAG_compile_unit e -> @@ -163,7 +163,7 @@ module DwarfPrinter(Target: TARGET) : add_attr_some e.formal_parameter_file_loc add_file_loc; add_attr_some e.formal_parameter_artificial add_artificial; add_location e.formal_parameter_location buf; - add_name buf; + add_attr_some e.formal_parameter_name add_name; add_location e.formal_parameter_segment buf; add_type buf; add_attr_some e.formal_parameter_variable_parameter add_variable_parameter @@ -206,9 +206,12 @@ module DwarfPrinter(Target: TARGET) : | DW_TAG_subrange_type e -> prologue 0x21; add_attr_some e.subrange_type add_type; - add_bound_value e.subrange_upper_bound buf - | DW_TAG_subroutine_type _ -> + (match e.subrange_upper_bound with + | None -> () + | Some b -> add_bound_value b buf) + | DW_TAG_subroutine_type e -> prologue 0x15; + add_attr_some e.subroutine_type add_type; add_prototyped buf | DW_TAG_typedef e -> prologue 0x16; @@ -337,17 +340,20 @@ module DwarfPrinter(Target: TARGET) : let print_base_type oc bt = print_byte oc bt.base_type_byte_size; - let encoding = match bt.base_type_encoding with - | DW_ATE_address -> 0x1 - | DW_ATE_boolean -> 0x2 - | DW_ATE_complex_float -> 0x3 - | DW_ATE_float -> 0x4 - | DW_ATE_signed -> 0x5 - | DW_ATE_signed_char -> 0x6 - | DW_ATE_unsigned -> 0x7 - | DW_ATE_unsigned_char -> 0x8 - in - print_byte oc encoding; + match bt.base_type_encoding with + | Some e -> + let encoding = match e with + | DW_ATE_address -> 0x1 + | DW_ATE_boolean -> 0x2 + | DW_ATE_complex_float -> 0x3 + | DW_ATE_float -> 0x4 + | DW_ATE_signed -> 0x5 + | DW_ATE_signed_char -> 0x6 + | DW_ATE_unsigned -> 0x7 + | DW_ATE_unsigned_char -> 0x8 + in + print_byte oc encoding; + | None -> (); print_string oc bt.base_type_name let print_compilation_unit oc tag = @@ -377,7 +383,7 @@ module DwarfPrinter(Target: TARGET) : 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_string oc fp.formal_parameter_name; + print_opt_value oc fp.formal_parameter_name print_string; print_opt_value oc fp.formal_parameter_segment print_loc; print_ref oc fp.formal_parameter_type; print_opt_value oc fp.formal_parameter_variable_parameter print_flag @@ -421,9 +427,10 @@ module DwarfPrinter(Target: TARGET) : let print_subrange oc sr = print_opt_value oc sr.subrange_type print_ref; - print_bound_value oc sr.subrange_upper_bound + print_opt_value oc sr.subrange_upper_bound print_bound_value let print_subroutine oc st = + print_opt_value oc st.subroutine_type print_ref; print_flag oc st.subroutine_prototyped let print_typedef oc td = diff --git a/debug/DwarfTypes.ml b/debug/DwarfTypes.ml deleted file mode 100644 index 268711b3..00000000 --- a/debug/DwarfTypes.ml +++ /dev/null @@ -1,258 +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. *) -(* *) -(* *********************************************************************) - -(* Types used for writing dwarf debug information *) - -(* Basic types for the value of attributes *) - -type constant = int - -type flag = bool - -type reference = int - -type encoding = - | DW_ATE_address - | DW_ATE_boolean - | DW_ATE_complex_float - | DW_ATE_float - | DW_ATE_signed - | DW_ATE_signed_char - | DW_ATE_unsigned - | DW_ATE_unsigned_char - -type address = int - -type block = string - -type location_value = - | LocConst of constant - | LocBlock of block - -type data_location_value = - | DataLocBlock of block - | DataLocRef of reference - -type bound_value = - | BoundConst of constant - | BoundRef of reference - -(* Types representing the attribute information per tag value *) - -type file_loc = string * constant - -type dw_tag_array_type = - { - array_type_file_loc: file_loc option; - array_type: reference; - } - -type dw_tag_base_type = - { - base_type_byte_size: constant; - base_type_encoding: encoding; - base_type_name: string; - } - -type dw_tag_compile_unit = - { - compile_unit_name: string; - } - -type dw_tag_const_type = - { - const_type: reference; - } - -type dw_tag_enumeration_type = - { - enumeration_file_loc: file_loc option; - enumeration_byte_size: constant; - enumeration_declaration: flag option; - enumeration_name: string; - } - -type dw_tag_enumerator = - { - enumerator_file_loc: file_loc option; - enumerator_value: constant; - enumerator_name: string; - } - -type dw_tag_formal_parameter = - { - formal_parameter_file_loc: file_loc option; - formal_parameter_artificial: flag option; - formal_parameter_location: location_value option; - formal_parameter_name: string; - formal_parameter_segment: location_value option; - formal_parameter_type: reference; - formal_parameter_variable_parameter: flag option; - } - -type dw_tag_label = - { - label_low_pc: address; - label_name: string; - } - -type dw_tag_lexical_block = - { - lexical_block_high_pc: address; - lexical_block_low_pc: address; - } - -type dw_tag_member = - { - member_file_loc: file_loc option; - member_byte_size: constant option; - member_bit_offset: constant option; - member_bit_size: constant option; - member_data_member_location: data_location_value option; - member_declaration: flag option; - member_name: string; - member_type: reference; - } - -type dw_tag_pointer_type = - { - pointer_type: reference; - } - -type dw_tag_structure_type = - { - structure_file_loc: file_loc option; - structure_byte_size: constant; - structure_declaration: flag option; - structure_name: string; - } - -type dw_tag_subprogram = - { - subprogram_file_loc: file_loc option; - subprogram_external: flag option; - subprogram_frame_base: location_value option; - subprogram_high_pc: address; - subprogram_low_pc: address; - subprogram_name: string; - subprogram_prototyped: flag; - subprogram_type: reference; - } - -type dw_tag_subrange_type = - { - subrange_type: reference option; - subrange_upper_bound: bound_value; - } - -type dw_tag_subroutine_type = - { - subroutine_prototyped: flag; - } - -type dw_tag_typedef = - { - typedef_file_loc: file_loc option; - typedef_name: string; - typedef_type: reference; - } - -type dw_tag_union_type = - { - union_file_loc: file_loc option; - union_byte_size: constant; - union_name: string; - } - -type dw_tag_unspecified_parameter = - { - unspecified_parameter_file_loc: file_loc option; - unspecified_parameter_artificial: flag option; - } - -type dw_tag_variable = - { - 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; - } - -type dw_tag_volatile_type = - { - volatile_type: reference; - } - -type dw_tag = - | DW_TAG_array_type of dw_tag_array_type - | DW_TAG_base_type of dw_tag_base_type - | DW_TAG_compile_unit of dw_tag_compile_unit - | DW_TAG_const_type of dw_tag_const_type - | DW_TAG_enumeration_type of dw_tag_enumeration_type - | DW_TAG_enumerator of dw_tag_enumerator - | DW_TAG_formal_parameter of dw_tag_formal_parameter - | DW_TAG_label of dw_tag_label - | DW_TAG_lexical_block of dw_tag_lexical_block - | DW_TAG_member of dw_tag_member - | DW_TAG_pointer_type of dw_tag_pointer_type - | DW_TAG_structure_type of dw_tag_structure_type - | DW_TAG_subprogram of dw_tag_subprogram - | DW_TAG_subrange_type of dw_tag_subrange_type - | DW_TAG_subroutine_type of dw_tag_subroutine_type - | DW_TAG_typedef of dw_tag_typedef - | DW_TAG_union_type of dw_tag_union_type - | DW_TAG_unspecified_parameter of dw_tag_unspecified_parameter - | DW_TAG_variable of dw_tag_variable - | DW_TAG_volatile_type of dw_tag_volatile_type - -(* The type of the entries. *) - -type dw_entry = - { - tag: dw_tag; - children: dw_entry list; - id: reference; - } - - -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 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_const_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 diff --git a/debug/DwarfTypes.mli b/debug/DwarfTypes.mli new file mode 100644 index 00000000..4f434c4d --- /dev/null +++ b/debug/DwarfTypes.mli @@ -0,0 +1,259 @@ +(* *********************************************************************) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +(* Types used for writing dwarf debug information *) + +(* Basic types for the value of attributes *) + +type constant = int + +type flag = bool + +type reference = int + +type encoding = + | DW_ATE_address + | DW_ATE_boolean + | DW_ATE_complex_float + | DW_ATE_float + | DW_ATE_signed + | DW_ATE_signed_char + | DW_ATE_unsigned + | DW_ATE_unsigned_char + +type address = int + +type block = string + +type location_value = + | LocConst of constant + | LocBlock of block + +type data_location_value = + | DataLocBlock of block + | DataLocRef of reference + +type bound_value = + | BoundConst of constant + | BoundRef of reference + +(* Types representing the attribute information per tag value *) + +type file_loc = string * constant + +type dw_tag_array_type = + { + array_type_file_loc: file_loc option; + array_type: reference; + } + +type dw_tag_base_type = + { + base_type_byte_size: constant; + base_type_encoding: encoding option; + base_type_name: string; + } + +type dw_tag_compile_unit = + { + compile_unit_name: string; + } + +type dw_tag_const_type = + { + const_type: reference; + } + +type dw_tag_enumeration_type = + { + enumeration_file_loc: file_loc option; + enumeration_byte_size: constant; + enumeration_declaration: flag option; + enumeration_name: string; + } + +type dw_tag_enumerator = + { + enumerator_file_loc: file_loc option; + enumerator_value: constant; + enumerator_name: string; + } + +type dw_tag_formal_parameter = + { + formal_parameter_file_loc: file_loc option; + formal_parameter_artificial: flag option; + formal_parameter_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; + } + +type dw_tag_label = + { + label_low_pc: address; + label_name: string; + } + +type dw_tag_lexical_block = + { + lexical_block_high_pc: address; + lexical_block_low_pc: address; + } + +type dw_tag_member = + { + member_file_loc: file_loc option; + member_byte_size: constant option; + member_bit_offset: constant option; + member_bit_size: constant option; + member_data_member_location: data_location_value option; + member_declaration: flag option; + member_name: string; + member_type: reference; + } + +type dw_tag_pointer_type = + { + pointer_type: reference; + } + +type dw_tag_structure_type = + { + structure_file_loc: file_loc option; + structure_byte_size: constant; + structure_declaration: flag option; + structure_name: string; + } + +type dw_tag_subprogram = + { + subprogram_file_loc: file_loc option; + subprogram_external: flag option; + subprogram_frame_base: location_value option; + subprogram_high_pc: address; + subprogram_low_pc: address; + subprogram_name: string; + subprogram_prototyped: flag; + subprogram_type: reference; + } + +type dw_tag_subrange_type = + { + subrange_type: reference option; + subrange_upper_bound: bound_value option; + } + +type dw_tag_subroutine_type = + { + subroutine_type: reference option; + subroutine_prototyped: flag; + } + +type dw_tag_typedef = + { + typedef_file_loc: file_loc option; + typedef_name: string; + typedef_type: reference; + } + +type dw_tag_union_type = + { + union_file_loc: file_loc option; + union_byte_size: constant; + union_name: string; + } + +type dw_tag_unspecified_parameter = + { + unspecified_parameter_file_loc: file_loc option; + unspecified_parameter_artificial: flag option; + } + +type dw_tag_variable = + { + 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; + } + +type dw_tag_volatile_type = + { + volatile_type: reference; + } + +type dw_tag = + | DW_TAG_array_type of dw_tag_array_type + | DW_TAG_base_type of dw_tag_base_type + | DW_TAG_compile_unit of dw_tag_compile_unit + | DW_TAG_const_type of dw_tag_const_type + | DW_TAG_enumeration_type of dw_tag_enumeration_type + | DW_TAG_enumerator of dw_tag_enumerator + | DW_TAG_formal_parameter of dw_tag_formal_parameter + | DW_TAG_label of dw_tag_label + | DW_TAG_lexical_block of dw_tag_lexical_block + | DW_TAG_member of dw_tag_member + | DW_TAG_pointer_type of dw_tag_pointer_type + | DW_TAG_structure_type of dw_tag_structure_type + | DW_TAG_subprogram of dw_tag_subprogram + | DW_TAG_subrange_type of dw_tag_subrange_type + | DW_TAG_subroutine_type of dw_tag_subroutine_type + | DW_TAG_typedef of dw_tag_typedef + | DW_TAG_union_type of dw_tag_union_type + | DW_TAG_unspecified_parameter of dw_tag_unspecified_parameter + | DW_TAG_variable of dw_tag_variable + | DW_TAG_volatile_type of dw_tag_volatile_type + +(* The type of the entries. *) + +type dw_entry = + { + tag: dw_tag; + children: dw_entry list; + id: reference; + } + + +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 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_const_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 diff --git a/debug/DwarfUtil.ml b/debug/DwarfUtil.ml index 764194a6..91ef94a8 100644 --- a/debug/DwarfUtil.ml +++ b/debug/DwarfUtil.ml @@ -33,10 +33,15 @@ let new_entry tag = } (* Add an entry as child to another entry *) -let add_children entry child = +let add_child entry child = {entry with children = child::entry.children;} +(* Add entries as children to another entry *) +let add_children entry children = + {entry with children = entry.children@children;} + + let list_iter_with_next f list = let rec aux = (function | [] -> () -- cgit