diff options
Diffstat (limited to 'debug')
-rw-r--r-- | debug/CtoDwarf.ml | 494 | ||||
-rw-r--r-- | debug/DwarfPrinter.ml | 502 | ||||
-rw-r--r-- | debug/DwarfPrinter.mli | 18 | ||||
-rw-r--r-- | debug/DwarfTypes.mli | 272 | ||||
-rw-r--r-- | debug/DwarfUtil.ml | 118 |
5 files changed, 1404 insertions, 0 deletions
diff --git a/debug/CtoDwarf.ml b/debug/CtoDwarf.ml new file mode 100644 index 00000000..b1eea8f3 --- /dev/null +++ b/debug/CtoDwarf.ml @@ -0,0 +1,494 @@ +(* *********************************************************************) +(* *) +(* 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 Cprint +open Cutil +open C2C +open DwarfTypes +open DwarfUtil +open Env + +(* 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: (string, int) Hashtbl.t = Hashtbl.create 7 + +(* Get the type id of a composite_type *) +let get_composite_type (name: string): 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) + + +(* 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 = { + 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 (_,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 + s.id,((s::others)@et) + +(* Generate a dwarf tag for the given array type *) +and array_to_dwarf_tag child size = + 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 + 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.name 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 = + 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 (n,t) gloc = + let i,t = type_to_dwarf t in + Hashtbl.add typedef_table n.name i; + let td = { + typedef_file_loc = Some (gloc); + typedef_name = n.name; + typedef_type = i; + } in + let td = new_entry (DW_TAG_typedef td) in + 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_file_loc = (Some gloc); + variable_declaration = Some at_decl; + variable_external = Some ext; + variable_location = None; + variable_name = n.name; + variable_segment = None; + 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_file_loc = (Some gloc); + subprogram_external = Some ext; + subprogram_frame_base = None; + 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_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 + 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 = n.name; + } in + let id = get_composite_type n.name 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 = n.name; + } in + let id = get_composite_type n.name 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 = m.fld_name; + 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 = m.fld_name; + 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 = n.name; + } in + let id = get_composite_type n.name 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 = f.fld_name; + 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 = + PrintAnnot.add_file (fst decl.gloc); + match decl.gdesc with + | Gtypedef (n,t) -> let ret = typedef_to_dwarf (n,t) decl.gloc 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) ->let ret = enum_to_dwarf (n,at,e) decl.gloc in + typs@ret,decls + | Gcompositedef (Struct,n,at,m) -> let ret = struct_to_dwarf (n,at,m) env decl.gloc in + typs@ret,decls + | Gcompositedef (Union,n,at,m) -> let ret = union_to_dwarf (n,at,m) env decl.gloc in + typs@ret,decls + | Gcompositedecl _ + | Gpragma _ -> typs,decls + +(* 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,defs = List.fold_left (globdecl_to_dwarf env) ([],[]) prog 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/DwarfPrinter.ml b/debug/DwarfPrinter.ml new file mode 100644 index 00000000..dec3279e --- /dev/null +++ b/debug/DwarfPrinter.ml @@ -0,0 +1,502 @@ +(* *********************************************************************) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +(* Printer for the Dwarf 2 debug information in ASM *) + +open DwarfTypes +open DwarfUtil +open Printf +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): + sig + val print_debug: out_channel -> dw_entry -> unit + end = + struct + + open Target + open DwarfAbbrevs + + (* Byte value to string *) + let string_of_byte value = + sprintf " .byte %s\n" (if value then "0x1" else "0x0") + + (* Print a label *) + let print_label oc lbl = + fprintf oc "%a:\n" label lbl + + (* Helper functions for abbreviation printing *) + let add_byte buf value = + Buffer.add_string buf (string_of_byte value) + + let add_abbr_uleb v buf = + Buffer.add_string buf (Printf.sprintf " .uleb128 %d\n" v) + + let add_abbr_entry (v1,v2) buf = + add_abbr_uleb v1 buf; + add_abbr_uleb v2 buf + + let add_file_loc buf = + let file,line = file_loc_type_abbr in + add_abbr_entry (0x3a,file) buf; + add_abbr_entry (0x3b,line) buf + + let add_type = add_abbr_entry (0x49,type_abbr) + + let add_name = add_abbr_entry (0x3,name_type_abbr) + + let add_byte_size = add_abbr_entry (0xb,byte_size_type_abbr) + + let add_high_pc = add_abbr_entry (0x12,high_pc_type_abbr) + + let add_low_pc = add_abbr_entry (0x11,low_pc_type_abbr) + + let add_declaration = add_abbr_entry (0x3c,declaration_type_abbr) + + let add_location loc buf = + match loc with + | None -> () + | Some (LocConst _) -> add_abbr_entry (0x2,location_const_type_abbr) buf + | Some (LocBlock _) -> add_abbr_entry (0x2,location_block_type_abbr) buf + + (* Dwarf entity to string function *) + let abbrev_string_of_entity entity has_sibling = + let buf = Buffer.create 12 in + let add_attr_some v f = + match v with + | None -> () + | Some _ -> f buf in + let prologue id = + let has_child = match entity.children with + | [] -> false + | _ -> true in + add_abbr_uleb id buf; + add_byte buf has_child; + if has_sibling then add_abbr_entry (0x1,sibling_type_abbr) buf; + in + (match entity.tag with + | DW_TAG_array_type e -> + prologue 0x1; + add_attr_some e.array_type_file_loc add_file_loc; + add_type buf + | DW_TAG_base_type b -> + prologue 0x24; + add_byte_size buf; + add_attr_some b.base_type_encoding (add_abbr_entry (0x3e,encoding_type_abbr)); + add_name buf + | 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_abbr_entry (0x13,language_type_abbr) buf; + add_name buf; + add_abbr_entry (0x25,producer_type_abbr) buf; + add_abbr_entry (0x10,stmt_list_type_abbr) buf; + | DW_TAG_const_type _ -> + prologue 0x26; + add_type buf + | DW_TAG_enumeration_type e -> + prologue 0x4; + add_attr_some e.enumeration_file_loc add_file_loc; + add_byte_size buf; + add_attr_some e.enumeration_declaration add_declaration; + add_name buf + | DW_TAG_enumerator e -> + prologue 0x28; + add_attr_some e.enumerator_file_loc add_file_loc; + add_abbr_entry (0x1c,value_type_abbr) buf; + add_name buf + | DW_TAG_formal_parameter e -> + prologue 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_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_abbr_entry (0x4b,variable_parameter_type_abbr)) + | DW_TAG_label _ -> + prologue 0xa; + add_low_pc buf; + add_name buf; + | DW_TAG_lexical_block _ -> + prologue 0xb; + add_high_pc buf; + add_low_pc buf + | DW_TAG_member e -> + prologue 0xd; + add_attr_some e.member_file_loc add_file_loc; + add_attr_some e.member_byte_size add_byte_size; + add_attr_some e.member_bit_offset (add_abbr_entry (0xd,bit_offset_type_abbr)); + add_attr_some e.member_bit_size (add_abbr_entry (0xc,bit_size_type_abbr)); + (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_name buf; + add_type buf + | DW_TAG_pointer_type _ -> + prologue 0xf; + add_type buf + | DW_TAG_structure_type e -> + prologue 0x13; + add_attr_some e.structure_file_loc add_file_loc; + add_attr_some e.structure_byte_size add_byte_size; + add_attr_some e.structure_declaration add_declaration; + add_name buf + | DW_TAG_subprogram e -> + prologue 0x2e; + add_attr_some e.subprogram_file_loc add_file_loc; + add_attr_some e.subprogram_external (add_abbr_entry (0x3f,external_type_abbr)); + add_high_pc buf; + add_low_pc buf; + add_name buf; + add_abbr_entry (0x27,prototyped_type_abbr) buf; + add_attr_some e.subprogram_type add_type; + | DW_TAG_subrange_type e -> + prologue 0x21; + add_attr_some e.subrange_type add_type; + (match e.subrange_upper_bound with + | None -> () + | Some (BoundConst _) -> add_abbr_entry (0x2f,bound_const_type_abbr) buf + | Some (BoundRef _) -> add_abbr_entry (0x2f,bound_ref_type_abbr) buf) + | DW_TAG_subroutine_type e -> + prologue 0x15; + add_attr_some e.subroutine_type add_type; + add_abbr_entry (0x27,prototyped_type_abbr) buf + | DW_TAG_typedef e -> + prologue 0x16; + add_attr_some e.typedef_file_loc add_file_loc; + add_name buf; + add_type buf + | DW_TAG_union_type e -> + prologue 0x17; + add_attr_some e.union_file_loc add_file_loc; + add_attr_some e.union_byte_size add_byte_size; + add_attr_some e.union_declaration add_declaration; + add_name buf + | DW_TAG_unspecified_parameter e -> + prologue 0x18; + add_attr_some e.unspecified_parameter_file_loc add_file_loc; + add_attr_some e.unspecified_parameter_artificial (add_abbr_entry (0x34,artificial_type_abbr)) + | DW_TAG_variable e -> + prologue 0x34; + 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_name buf; + add_location e.variable_segment buf; + add_type buf + | DW_TAG_volatile_type _ -> + prologue 0x35; + add_type buf); + Buffer.contents buf + + let abbrev_start_addr = ref (-1) + + let curr_abbrev = ref 1 + + (* Function to get unique abbreviation ids *) + let next_abbrev () = + let abbrev = !curr_abbrev in + incr curr_abbrev;abbrev + + (* Mapping from abbreviation string to abbrevaiton id *) + let abbrev_mapping: (string,int) Hashtbl.t = Hashtbl.create 7 + + (* Look up the id of the abbreviation and add it if it is missing *) + let get_abbrev entity has_sibling = + let abbrev_string = abbrev_string_of_entity entity has_sibling in + (try + Hashtbl.find abbrev_mapping abbrev_string + with Not_found -> + let id = next_abbrev () in + Hashtbl.add abbrev_mapping abbrev_string id; + id) + + (* Compute the abbreviations of an entry and its children *) + let compute_abbrev entry = + entry_iter_sib (fun sib entry -> + let has_sib = match sib with + | None -> false + | Some _ -> true in + ignore (get_abbrev entry has_sib)) (fun _ -> ()) entry + + (* Print the debug_abbrev section using the previous computed abbreviations*) + 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); + let lbl = new_label () in + abbrev_start_addr := lbl; + print_label oc lbl; + List.iter (fun (s,id) -> + fprintf oc " .uleb128 %d\n" id; + output_string oc s; + fprintf oc " .uleb128 0\n"; + fprintf oc " .uleb128 0\n") abbrevs; + fprintf oc " .sleb128 0\n" + + let debug_start_addr = ref (-1) + + let entry_labels: (int,int) Hashtbl.t = Hashtbl.create 7 + + (* Translate the ids to address labels *) + let entry_to_label id = + try + Hashtbl.find entry_labels id + with Not_found -> + let label = new_label () in + Hashtbl.add entry_labels id label; + label + + (* Helper functions for debug printing *) + let print_opt_value oc o f = + match o with + | 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) + + let print_string oc s = + fprintf oc " .asciz \"%s\"\n" s + + let print_uleb128 oc d = + fprintf oc " .uleb128 %d\n" d + + let print_sleb128 oc d = + fprintf oc " .sleb128 %d\n" d + + let print_byte oc b = + fprintf oc " .byte 0x%X\n" b + + let print_loc oc loc = + () + + let print_data_location oc dl = + () + + 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 + + let print_array_type oc at = + print_file_loc oc at.array_type_file_loc; + print_ref oc at.array_type + + let print_bound_value oc = function + | BoundConst bc -> print_uleb128 oc bc + | BoundRef br -> print_ref oc br + + let print_base_type oc bt = + print_byte oc bt.base_type_byte_size; + (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 = + print_string oc (Sys.getcwd ()); + 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 ("CompCert "^Configuration.version); + print_addr oc (get_stmt_list_addr ()) + + let print_const_type oc ct = + print_ref oc ct.const_type + + let print_enumeration_type oc et = + print_file_loc oc et.enumeration_file_loc; + print_uleb128 oc et.enumeration_byte_size; + print_opt_value oc et.enumeration_declaration print_flag; + print_string oc et.enumeration_name + + let print_enumerator oc en = + print_file_loc oc en.enumerator_file_loc; + print_sleb128 oc en.enumerator_value; + print_string oc en.enumerator_name + + let print_formal_parameter oc fp = + print_file_loc oc fp.formal_parameter_file_loc; + print_opt_value oc fp.formal_parameter_artificial print_flag; + print_opt_value oc fp.formal_parameter_location print_loc; + 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 + + let print_tag_label oc tl = + print_ref oc tl.label_low_pc; + 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 + + let print_member oc mb = + print_file_loc oc mb.member_file_loc; + print_opt_value oc mb.member_byte_size print_byte; + print_opt_value oc mb.member_bit_offset print_byte; + print_opt_value oc mb.member_bit_size print_byte; + print_opt_value oc mb.member_data_member_location print_data_location; + print_opt_value oc mb.member_declaration print_flag; + print_string oc mb.member_name; + print_ref oc mb.member_type + + let print_pointer oc pt = + print_ref oc pt.pointer_type + + let print_structure oc st = + print_file_loc oc st.structure_file_loc; + print_opt_value oc st.structure_byte_size print_uleb128; + print_opt_value oc st.structure_declaration print_flag; + print_string oc st.structure_name + + let print_subprogram oc sp = + let s,e = 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; + fprintf oc " .4byte %a\n" label s; + fprintf oc " .4byte %a\n" label e; + print_string oc sp.subprogram_name; + print_flag oc sp.subprogram_prototyped; + print_opt_value oc sp.subprogram_type print_ref + + let print_subrange oc sr = + print_opt_value oc sr.subrange_type print_ref; + print_opt_value oc sr.subrange_upper_bound print_bound_value + + 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 = + print_file_loc oc td.typedef_file_loc; + print_string oc td.typedef_name; + print_ref oc td.typedef_type + + let print_union_type oc ut = + print_file_loc oc ut.union_file_loc; + print_opt_value oc ut.union_byte_size print_uleb128; + print_opt_value oc ut.union_declaration print_flag; + print_string oc ut.union_name + + let print_unspecified_parameter oc up = + print_file_loc oc up.unspecified_parameter_file_loc; + print_opt_value oc up.unspecified_parameter_artificial print_flag + + let print_variable oc var = + 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_string oc var.variable_name; + print_opt_value oc var.variable_segment print_loc; + print_ref oc var.variable_type + + let print_volatile_type oc vt = + print_ref oc vt.volatile_type + + (* Print an debug entry *) + let print_entry oc entry = + entry_iter_sib (fun sib entry -> + print_label oc (entry_to_label entry.id); + let has_sib = match sib with + | None -> false + | Some _ -> true in + let id = get_abbrev entry has_sib in + print_sleb128 oc id; + (match sib with + | None -> () + | Some s -> let lbl = entry_to_label s in + fprintf oc " .4byte %a-%a\n" label lbl label !debug_start_addr); + begin + match entry.tag with + | DW_TAG_array_type arr_type -> print_array_type oc arr_type + | DW_TAG_compile_unit comp -> print_compilation_unit oc comp + | DW_TAG_base_type bt -> print_base_type oc bt + | DW_TAG_const_type ct -> print_const_type oc ct + | DW_TAG_enumeration_type et -> print_enumeration_type oc et + | DW_TAG_enumerator et -> print_enumerator oc et + | DW_TAG_formal_parameter fp -> print_formal_parameter oc fp + | DW_TAG_label lb -> print_tag_label oc lb + | DW_TAG_lexical_block lb -> print_lexical_block oc lb + | DW_TAG_member mb -> print_member oc mb + | DW_TAG_pointer_type pt -> print_pointer oc pt + | DW_TAG_structure_type st -> print_structure oc st + | DW_TAG_subprogram sb -> print_subprogram oc sb + | DW_TAG_subrange_type sb -> print_subrange oc sb + | DW_TAG_subroutine_type st -> print_subroutine oc st + | DW_TAG_typedef tp -> print_typedef oc tp + | DW_TAG_union_type ut -> print_union_type oc ut + | DW_TAG_unspecified_parameter up -> print_unspecified_parameter oc up + | DW_TAG_variable var -> print_variable oc var + | DW_TAG_volatile_type vt -> print_volatile_type oc vt + end) (fun e -> + if e.children <> [] then + print_sleb128 oc 0) entry + + (* Print the debug abbrev section *) + let print_debug_abbrev oc entry = + compute_abbrev entry; + 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 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; + print_label oc debug_length_start; + fprintf oc " .2byte 0x2\n"; (* Dwarf version *) + print_addr oc !abbrev_start_addr; (* Offset into the abbreviation *) + print_byte oc !Machine.config.Machine.sizeof_ptr; (* Sizeof pointer type *) + print_entry oc entry; + print_sleb128 oc 0; + print_label oc debug_end (* End of the debug section *) + + + (* Print the debug info and abbrev section *) + let print_debug oc entry = + print_debug_abbrev oc entry; + print_debug_info oc entry + + end diff --git a/debug/DwarfPrinter.mli b/debug/DwarfPrinter.mli new file mode 100644 index 00000000..9e0e6693 --- /dev/null +++ b/debug/DwarfPrinter.mli @@ -0,0 +1,18 @@ +(* *********************************************************************) +(* *) +(* 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 DwarfTypes + +module DwarfPrinter: functor (Target: DWARF_TARGET) -> functor (DwarfAbbrevs: DWARF_ABBREVS) -> + sig + val print_debug: out_channel -> dw_entry -> unit + end diff --git a/debug/DwarfTypes.mli b/debug/DwarfTypes.mli new file mode 100644 index 00000000..c02558b5 --- /dev/null +++ b/debug/DwarfTypes.mli @@ -0,0 +1,272 @@ +(* *********************************************************************) +(* *) +(* 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 *) + +open Sections + +(* 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 option; + 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_name: string; + subprogram_prototyped: flag; + subprogram_type: reference option; + } + +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 option; + union_declaration: flag option; + 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 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 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 + +(* 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 get_fun_addr: string -> int * int + end diff --git a/debug/DwarfUtil.ml b/debug/DwarfUtil.ml new file mode 100644 index 00000000..e2c87a9d --- /dev/null +++ b/debug/DwarfUtil.ml @@ -0,0 +1,118 @@ +(* *********************************************************************) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +(* Utility functions for the dwarf debuging type *) + +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 + { + tag = tag; + children = []; + id = id; + } + +(* Add an entry as child to another entry *) +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 + | [] -> () + | [a] -> f None a + | a::b::rest -> f (Some b.id) a; aux (b::rest)) in + aux list + +(* Iter over the tree and pass the sibling id *) +let entry_iter_sib f g entry = + let rec aux sib entry = + f sib entry; + list_iter_with_next aux entry.children; + g entry in + aux None entry + + +(* Fold over the tree in prefix order *) +let rec entry_fold f acc entry = + let acc = f acc entry.tag in + List.fold_left (entry_fold f) acc entry.children + +(* Attribute form encoding *) +let dw_form_addr = 0x01 +let dw_form_block2 = 0x03 +let dw_form_block4 = 0x04 +let dw_form_data2 = 0x05 +let dw_form_data4 = 0x06 +let dw_form_data8 = 0x07 +let dw_form_string = 0x08 +let dw_form_block = 0x09 +let dw_form_block1 = 0x0a +let dw_form_data1 = 0x0b +let dw_form_flag = 0x0c +let dw_form_sdata = 0x0d +let dw_form_strp = 0x0e +let dw_form_udata = 0x0f +let dw_form_ref_addr = 0x10 +let dw_form_ref1 = 0x11 +let dw_form_ref2 = 0x12 +let dw_form_ref4 = 0x13 +let dw_form_ref8 = 0x14 +let dw_ref_udata = 0x15 +let dw_ref_indirect = 0x16 + +(* 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 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_const_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 |