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 +++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 167 insertions(+), 1 deletion(-) (limited to 'debug/CtoDwarf.ml') 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 + -- cgit