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