diff options
| author | François Pottier <francois.pottier@inria.fr> | 2015-10-23 15:08:33 +0200 |
|---|---|---|
| committer | François Pottier <francois.pottier@inria.fr> | 2015-10-23 15:17:50 +0200 |
| commit | 136986c204af19341aeb455d72fe817b16fa6fff (patch) | |
| tree | 02e9178d9f2cf942bd32366891d480ff161406f6 /debug | |
| parent | c46723c0169145d41d1879c236f53314456f1ba1 (diff) | |
| parent | 1cb3d93ff278ebbd0c6967c5f9401a97f9b618b4 (diff) | |
| download | compcert-136986c204af19341aeb455d72fe817b16fa6fff.tar.gz compcert-136986c204af19341aeb455d72fe817b16fa6fff.zip | |
Merge remote branch 'upstream/master' into clean
Conflicts:
Makefile.extr
Diffstat (limited to 'debug')
| -rw-r--r-- | debug/Debug.ml | 133 | ||||
| -rw-r--r-- | debug/Debug.mli | 79 | ||||
| -rw-r--r-- | debug/DebugInformation.ml | 186 | ||||
| -rw-r--r-- | debug/DebugInit.ml | 108 | ||||
| -rw-r--r-- | debug/DebugTypes.mli | 6 | ||||
| -rw-r--r-- | debug/DwarfPrinter.ml | 548 | ||||
| -rw-r--r-- | debug/DwarfTypes.mli | 138 | ||||
| -rw-r--r-- | debug/DwarfUtil.ml | 75 | ||||
| -rw-r--r-- | debug/Dwarfgen.ml | 915 |
9 files changed, 1155 insertions, 1033 deletions
diff --git a/debug/Debug.ml b/debug/Debug.ml index 161ee3ed..87d04ad7 100644 --- a/debug/Debug.ml +++ b/debug/Debug.ml @@ -16,55 +16,51 @@ open C open Camlcoq open Dwarfgen open DwarfTypes +open Sections (* Interface for generating and printing debug information *) (* Record used for stroring references to the actual implementation functions *) -type implem = +type implem = { - mutable init: string -> unit; - mutable atom_function: ident -> atom -> unit; - mutable atom_global_variable: ident -> atom -> unit; - mutable set_composite_size: ident -> struct_or_union -> int option -> unit; - mutable set_member_offset: ident -> string -> int -> unit; - mutable set_bitfield_offset: ident -> string -> int -> string -> int -> unit; - mutable insert_global_declaration: Env.t -> globdecl -> unit; - mutable add_fun_addr: atom -> (int * int) -> unit; - mutable generate_debug_info: (atom -> string) -> string -> debug_entries option; - mutable all_files_iter: (string -> unit) -> unit; - mutable insert_local_declaration: storage -> ident -> typ -> location -> unit; - mutable atom_local_variable: ident -> atom -> unit; - mutable enter_scope: int -> int -> int -> unit; - mutable enter_function_scope: int -> int -> unit; - mutable add_lvar_scope: int -> ident -> int -> unit; - mutable open_scope: atom -> int -> positive -> unit; - mutable close_scope: atom -> int -> positive -> unit; - mutable start_live_range: (atom * atom) -> positive -> int * int builtin_arg -> unit; - mutable end_live_range: (atom * atom) -> positive -> unit; - mutable stack_variable: (atom * atom) -> int * int builtin_arg -> unit; - mutable function_end: atom -> positive -> unit; - mutable add_label: atom -> positive -> int -> unit; - mutable atom_parameter: ident -> ident -> atom -> unit; - mutable add_compilation_section_start: string -> int -> unit; - mutable add_compilation_section_end: string -> int -> unit; - mutable compute_diab_file_enum: (string -> int) -> (string-> int) -> (unit -> unit) -> unit; - mutable compute_gnu_file_enum: (string -> unit) -> unit; - mutable exists_section: string -> bool; - mutable remove_unused: ident -> unit; - mutable variable_printed: string -> unit; - mutable add_diab_info: string -> (int * int * string) -> unit; + init: string -> unit; + atom_global: ident -> atom -> unit; + set_composite_size: ident -> struct_or_union -> int option -> unit; + set_member_offset: ident -> string -> int -> unit; + set_bitfield_offset: ident -> string -> int -> string -> int -> unit; + insert_global_declaration: Env.t -> globdecl -> unit; + add_fun_addr: atom -> section_name -> (int * int) -> unit; + generate_debug_info: (atom -> string) -> string -> debug_entries option; + all_files_iter: (string -> unit) -> unit; + insert_local_declaration: storage -> ident -> typ -> location -> unit; + atom_local_variable: ident -> atom -> unit; + enter_scope: int -> int -> int -> unit; + enter_function_scope: int -> int -> unit; + add_lvar_scope: int -> ident -> int -> unit; + open_scope: atom -> int -> positive -> unit; + close_scope: atom -> int -> positive -> unit; + start_live_range: (atom * atom) -> positive -> int * int builtin_arg -> unit; + end_live_range: (atom * atom) -> positive -> unit; + stack_variable: (atom * atom) -> int * int builtin_arg -> unit; + add_label: atom -> positive -> int -> unit; + atom_parameter: ident -> ident -> atom -> unit; + compute_diab_file_enum: (section_name -> int) -> (string-> int) -> (unit -> unit) -> unit; + compute_gnu_file_enum: (string -> unit) -> unit; + exists_section: section_name -> bool; + remove_unused: ident -> unit; + variable_printed: string -> unit; + add_diab_info: section_name -> int -> int -> int -> unit; } -let implem = +let default_implem = { init = (fun _ -> ()); - atom_function = (fun _ _ -> ()); - atom_global_variable = (fun _ _ -> ()); + atom_global = (fun _ _ -> ()); set_composite_size = (fun _ _ _ -> ()); set_member_offset = (fun _ _ _ -> ()); set_bitfield_offset = (fun _ _ _ _ _ -> ()); insert_global_declaration = (fun _ _ -> ()); - add_fun_addr = (fun _ _ -> ()); + add_fun_addr = (fun _ _ _ -> ()); generate_debug_info = (fun _ _ -> None); all_files_iter = (fun _ -> ()); insert_local_declaration = (fun _ _ _ _ -> ()); @@ -77,47 +73,42 @@ let implem = start_live_range = (fun _ _ _ -> ()); end_live_range = (fun _ _ -> ()); stack_variable = (fun _ _ -> ()); - function_end = (fun _ _ -> ()); add_label = (fun _ _ _ -> ()); atom_parameter = (fun _ _ _ -> ()); - add_compilation_section_start = (fun _ _ -> ()); - add_compilation_section_end = (fun _ _ -> ()); compute_diab_file_enum = (fun _ _ _ -> ()); compute_gnu_file_enum = (fun _ -> ()); exists_section = (fun _ -> true); remove_unused = (fun _ -> ()); variable_printed = (fun _ -> ()); - add_diab_info = (fun _ _ -> ()); + add_diab_info = (fun _ _ _ _ -> ()); } -let init_compile_unit name = implem.init name -let atom_function id atom = implem.atom_function id atom -let atom_global_variable id atom = implem.atom_global_variable id atom -let set_composite_size id sou size = implem.set_composite_size id sou size -let set_member_offset id field off = 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 fun_s var_s = implem.generate_debug_info fun_s var_s -let all_files_iter f = implem.all_files_iter f -let insert_local_declaration sto id ty loc = implem.insert_local_declaration sto id ty loc -let atom_local_variable id atom = implem.atom_local_variable id atom -let enter_scope p_id id = implem.enter_scope p_id id -let enter_function_scope fun_id sc_id = implem.enter_function_scope fun_id sc_id -let add_lvar_scope fun_id var_id s_id = implem.add_lvar_scope fun_id var_id s_id -let open_scope atom id lbl = implem.open_scope atom id lbl -let close_scope atom id lbl = implem.close_scope atom id lbl -let start_live_range atom lbl loc = implem.start_live_range atom lbl loc -let end_live_range atom lbl = implem.end_live_range atom lbl -let stack_variable atom loc = implem.stack_variable atom loc -let function_end atom loc = implem.function_end atom loc -let add_label atom p lbl = implem.add_label atom p lbl -let atom_parameter fid pid atom = implem.atom_parameter fid pid atom -let add_compilation_section_start sec addr = implem.add_compilation_section_start sec addr -let add_compilation_section_end sec addr = implem.add_compilation_section_end sec addr -let exists_section sec = implem.exists_section sec -let compute_diab_file_enum end_l entry_l line_e = implem.compute_diab_file_enum end_l entry_l line_e -let compute_gnu_file_enum f = implem.compute_gnu_file_enum f -let remove_unused ident = implem.remove_unused ident -let variable_printed ident = implem.variable_printed ident -let add_diab_info sec addr = implem.add_diab_info sec addr +let implem = ref default_implem + +let init_compile_unit name = !implem.init name +let atom_global id atom = !implem.atom_global id atom +let set_composite_size id sou size = !implem.set_composite_size id sou size +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 fun_s var_s = !implem.generate_debug_info fun_s var_s +let all_files_iter f = !implem.all_files_iter f +let insert_local_declaration sto id ty loc = !implem.insert_local_declaration sto id ty loc +let atom_local_variable id atom = !implem.atom_local_variable id atom +let enter_scope p_id id = !implem.enter_scope p_id id +let enter_function_scope fun_id sc_id = !implem.enter_function_scope fun_id sc_id +let add_lvar_scope fun_id var_id s_id = !implem.add_lvar_scope fun_id var_id s_id +let open_scope atom id lbl = !implem.open_scope atom id lbl +let close_scope atom id lbl = !implem.close_scope atom id lbl +let start_live_range atom lbl loc = !implem.start_live_range atom lbl loc +let end_live_range atom lbl = !implem.end_live_range atom lbl +let stack_variable atom loc = !implem.stack_variable atom loc +let add_label atom p lbl = !implem.add_label atom p lbl +let atom_parameter fid pid atom = !implem.atom_parameter fid pid atom +let exists_section sec = !implem.exists_section sec +let compute_diab_file_enum end_l entry_l line_e = !implem.compute_diab_file_enum end_l entry_l line_e +let compute_gnu_file_enum f = !implem.compute_gnu_file_enum f +let remove_unused ident = !implem.remove_unused ident +let variable_printed ident = !implem.variable_printed ident +let add_diab_info sec line_start debug_info low_pc = !implem.add_diab_info sec line_start debug_info low_pc diff --git a/debug/Debug.mli b/debug/Debug.mli index 577b0ef8..1585e7e4 100644 --- a/debug/Debug.mli +++ b/debug/Debug.mli @@ -15,54 +15,52 @@ open C open Camlcoq open DwarfTypes open BinNums +open Sections (* Record used for stroring references to the actual implementation functions *) -type implem = +type implem = { - mutable init: string -> unit; - mutable atom_function: ident -> atom -> unit; - mutable atom_global_variable: ident -> atom -> unit; - mutable set_composite_size: ident -> struct_or_union -> int option -> unit; - mutable set_member_offset: ident -> string -> int -> unit; - mutable set_bitfield_offset: ident -> string -> int -> string -> int -> unit; - mutable insert_global_declaration: Env.t -> globdecl -> unit; - mutable add_fun_addr: atom -> (int * int) -> unit; - mutable generate_debug_info: (atom -> string) -> string -> debug_entries option; - mutable all_files_iter: (string -> unit) -> unit; - mutable insert_local_declaration: storage -> ident -> typ -> location -> unit; - mutable atom_local_variable: ident -> atom -> unit; - mutable enter_scope: int -> int -> int -> unit; - mutable enter_function_scope: int -> int -> unit; - mutable add_lvar_scope: int -> ident -> int -> unit; - mutable open_scope: atom -> int -> positive -> unit; - mutable close_scope: atom -> int -> positive -> unit; - mutable start_live_range: (atom * atom) -> positive -> int * int builtin_arg -> unit; - mutable end_live_range: (atom * atom) -> positive -> unit; - mutable stack_variable: (atom * atom) -> int * int builtin_arg -> unit; - mutable function_end: atom -> positive -> unit; - mutable add_label: atom -> positive -> int -> unit; - mutable atom_parameter: ident -> ident -> atom -> unit; - mutable add_compilation_section_start: string -> int -> unit; - mutable add_compilation_section_end: string -> int -> unit; - mutable compute_diab_file_enum: (string -> int) -> (string-> int) -> (unit -> unit) -> unit; - mutable compute_gnu_file_enum: (string -> unit) -> unit; - mutable exists_section: string -> bool; - mutable remove_unused: ident -> unit; - mutable variable_printed: string -> unit; - mutable add_diab_info: string -> (int * int * string) -> unit; + init: string -> unit; + atom_global: ident -> atom -> unit; + set_composite_size: ident -> struct_or_union -> int option -> unit; + set_member_offset: ident -> string -> int -> unit; + set_bitfield_offset: ident -> string -> int -> string -> int -> unit; + insert_global_declaration: Env.t -> globdecl -> unit; + add_fun_addr: atom -> section_name -> (int * int) -> unit; + generate_debug_info: (atom -> string) -> string -> debug_entries option; + all_files_iter: (string -> unit) -> unit; + insert_local_declaration: storage -> ident -> typ -> location -> unit; + atom_local_variable: ident -> atom -> unit; + enter_scope: int -> int -> int -> unit; + enter_function_scope: int -> int -> unit; + add_lvar_scope: int -> ident -> int -> unit; + open_scope: atom -> int -> positive -> unit; + close_scope: atom -> int -> positive -> unit; + start_live_range: (atom * atom) -> positive -> int * int builtin_arg -> unit; + end_live_range: (atom * atom) -> positive -> unit; + stack_variable: (atom * atom) -> int * int builtin_arg -> unit; + add_label: atom -> positive -> int -> unit; + atom_parameter: ident -> ident -> atom -> unit; + compute_diab_file_enum: (section_name -> int) -> (string-> int) -> (unit -> unit) -> unit; + compute_gnu_file_enum: (string -> unit) -> unit; + exists_section: section_name -> bool; + remove_unused: ident -> unit; + variable_printed: string -> unit; + add_diab_info: section_name -> int -> int -> int -> unit; } -val implem: implem +val default_implem: implem + +val implem: implem ref val init_compile_unit: string -> unit -val atom_function: ident -> atom -> unit -val atom_global_variable: ident -> atom -> unit +val atom_global: ident -> atom -> unit val set_composite_size: ident -> struct_or_union -> int option -> unit val set_member_offset: ident -> string -> int -> unit val set_bitfield_offset: ident -> string -> int -> string -> int -> unit val insert_global_declaration: Env.t -> globdecl -> unit -val add_fun_addr: atom -> (int * int) -> unit +val add_fun_addr: atom -> section_name -> (int * int) -> unit val all_files_iter: (string -> unit) -> unit val insert_local_declaration: storage -> ident -> typ -> location -> unit val atom_local_variable: ident -> atom -> unit @@ -74,15 +72,12 @@ val close_scope: atom -> int -> positive -> unit val start_live_range: (atom * atom) -> positive -> (int * int builtin_arg) -> unit val end_live_range: (atom * atom) -> positive -> unit val stack_variable: (atom * atom) -> int * int builtin_arg -> unit -val function_end: atom -> positive -> unit val add_label: atom -> positive -> int -> unit val generate_debug_info: (atom -> string) -> string -> debug_entries option val atom_parameter: ident -> ident -> atom -> unit -val add_compilation_section_start: string -> int -> unit -val add_compilation_section_end: string -> int -> unit -val compute_diab_file_enum: (string -> int) -> (string-> int) -> (unit -> unit) -> unit +val compute_diab_file_enum: (section_name -> int) -> (string-> int) -> (unit -> unit) -> unit val compute_gnu_file_enum: (string -> unit) -> unit -val exists_section: string -> bool +val exists_section: section_name -> bool val remove_unused: ident -> unit val variable_printed: string -> unit -val add_diab_info: string -> (int * int * string) -> unit +val add_diab_info: section_name -> int -> int -> int -> unit diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index 874dfb77..51fbfde9 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -16,8 +16,9 @@ open C open Camlcoq open Cutil open DebugTypes +open Sections -(* This implements an interface for the collection of debugging +(* This implements an interface for the collection of debugging information. *) (* Simple id generator *) @@ -60,53 +61,7 @@ let typ_to_string (ty: typ) = Buffer.contents buf (* Helper functions for the attributes *) -let strip_attributes typ = - let strip = List.filter (fun a -> a = AConst || a = AVolatile) in - match typ with - | TVoid at -> TVoid (strip at) - | TInt (k,at) -> TInt (k,strip at) - | TFloat (k,at) -> TFloat(k,strip at) - | TPtr (t,at) -> TPtr(t,strip at) - | TArray (t,s,at) -> TArray(t,s,strip at) - | TFun (t,arg,v,at) -> TFun(t,arg,v,strip at) - | TNamed (n,at) -> TNamed(n,strip at) - | TStruct (n,at) -> TStruct(n,strip at) - | TUnion (n,at) -> TUnion(n,strip at) - | TEnum (n,at) -> TEnum(n,strip at) - -let strip_last_attribute typ = - let rec hd_opt l = match l with - [] -> None,[] - | AConst::rest -> Some AConst,rest - | AVolatile::rest -> Some AVolatile,rest - | _::rest -> hd_opt rest in - match typ with - | TVoid at -> let l,r = hd_opt at in - l,TVoid r - | TInt (k,at) -> let l,r = hd_opt at in - l,TInt (k,r) - | TFloat (k,at) -> let l,r = hd_opt at in - l,TFloat (k,r) - | TPtr (t,at) -> let l,r = hd_opt at in - l,TPtr(t,r) - | TArray (t,s,at) -> let l,r = hd_opt at in - l,TArray(t,s,r) - | TFun (t,arg,v,at) -> let l,r = hd_opt at in - l,TFun(t,arg,v,r) - | TNamed (n,at) -> let l,r = hd_opt at in - l,TNamed(n,r) - | TStruct (n,at) -> let l,r = hd_opt at in - l,TStruct(n,r) - | TUnion (n,at) -> let l,r = hd_opt at in - l,TUnion(n,r) - | TEnum (n,at) -> let l,r = hd_opt at in - l,TEnum(n,r) - -(* Does the type already exist? *) -let exist_type (ty: typ) = - (* We are only interrested in Const and Volatile *) - let ty = strip_attributes ty in - Hashtbl.mem lookup_types (typ_to_string ty) +let strip_attributes typ = strip_attributes_type typ [AConst; AVolatile] (* Find the type id to an type *) let find_type (ty: typ) = @@ -117,20 +72,20 @@ let find_type (ty: typ) = (* Add type and information *) let insert_type (ty: typ) = let insert d_ty ty = - let id = next_id () + let id = next_id () and name = typ_to_string ty in Hashtbl.add types id d_ty; Hashtbl.add lookup_types name id; id in (* We are only interrested in Const and Volatile *) let ty = strip_attributes ty in - let rec typ_aux ty = + let rec typ_aux ty = try find_type ty with | Not_found -> let d_ty = match ty with | TVoid _ -> Void - | TInt (k,_) -> + | TInt (k,_) -> IntegerType ({int_kind = k }) | TFloat (k,_) -> FloatType ({float_kind = k}) @@ -150,14 +105,14 @@ let insert_type (ty: typ) = } in ArrayType arr | TFun (t,param,va,_) -> - let param,prot = (match param with + let param,prot = (match param with | None -> [],false - | Some p -> List.map (fun (i,t) -> let t = attr_aux t in + | Some p -> List.map (fun (i,t) -> let t = attr_aux t in { param_type = t; - param_name = i.name; + param_name = i.name; }) p,true) in - let ret = (match t with + let ret = (match t with | TVoid _ -> None | _ -> Some (attr_aux t)) in let ftype = { @@ -201,7 +156,7 @@ let insert_type (ty: typ) = } in CompositeType union | TEnum (id,_) -> - let enum = + let enum = { enum_name = id.name; enum_byte_size = None; @@ -210,13 +165,13 @@ let insert_type (ty: typ) = } in EnumType enum in insert d_ty ty - and attr_aux ty = + and attr_aux ty = try find_type ty with Not_found -> match strip_last_attribute ty with - | Some AConst,t -> + | Some AConst,t -> let id = attr_aux t in let const = { cst_type = id} in insert (ConstType const) ty @@ -267,6 +222,7 @@ let name_to_definition: (string,int) Hashtbl.t = Hashtbl.create 7 (* Mapping from atom to debug id *) let atom_to_definition: (atom, int) Hashtbl.t = Hashtbl.create 7 +(* Various lookup functions for defintions *) let find_gvar_stamp id = let id = (Hashtbl.find stamp_to_definition id) in let var = Hashtbl.find definitions id in @@ -302,9 +258,6 @@ let local_variables: (int, local_information) Hashtbl.t = Hashtbl.create 7 (* Mapping from stampt to the debug id of the local variable *) let stamp_to_local: (int,int) Hashtbl.t = Hashtbl.create 7 -(* Mapping form atom to the debug id of the local variable *) -let atom_to_local: (atom, int) Hashtbl.t = Hashtbl.create 7 - (* Map from scope id + function id to debug id *) let scope_to_local: (int * int,int) Hashtbl.t = Hashtbl.create 7 @@ -333,7 +286,7 @@ let replace_scope id var = let var = Scope var in Hashtbl.replace local_variables id var -let gen_comp_typ sou id at = +let gen_comp_typ sou id at = if sou = Struct then TStruct (id,at) else @@ -377,11 +330,11 @@ let insert_global_declaration env dec= end end else begin (* Implict declarations need special handling *) - let id' = try Hashtbl.find name_to_definition id.name with Not_found -> + let id' = try Hashtbl.find name_to_definition id.name with Not_found -> let id' = next_id () in Hashtbl.add name_to_definition id.name id';id' in Hashtbl.add stamp_to_definition id.stamp id' - end + end | Gfundef f -> let ret = (match f.fd_ret with | TVoid _ -> None @@ -398,7 +351,7 @@ let insert_global_declaration env dec= parameter_type = ty; }) f.fd_params in let fd = - { + { fun_name = f.fd_name.name; fun_atom = None; fun_file_loc = dec.gloc; @@ -411,19 +364,19 @@ let insert_global_declaration env dec= fun_scope = None; } in begin - let id' = try Hashtbl.find name_to_definition f.fd_name.name with Not_found -> + let id' = try Hashtbl.find name_to_definition f.fd_name.name with Not_found -> let id' = next_id () in Hashtbl.add name_to_definition f.fd_name.name id';id' in Hashtbl.add stamp_to_definition f.fd_name.stamp id'; Hashtbl.add definitions id' (Function fd) end - | Gcompositedecl (sou,id,at) -> + | Gcompositedecl (sou,id,at) -> ignore (insert_type (gen_comp_typ sou id at)); let id = find_type (gen_comp_typ sou id []) in replace_composite id (fun comp -> if comp.ct_file_loc = None then {comp with ct_file_loc = Some (dec.gloc);} else comp) - | Gcompositedef (sou,id,at,fi) -> + | 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 *) @@ -440,15 +393,15 @@ let insert_global_declaration env dec= 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; ct_declaration = false;}) - | Gtypedef (id,t) -> + | Gtypedef (id,t) -> let id = insert_type (TNamed (id,[])) in let tid = insert_type t in replace_typedef id (fun typ -> {typ with typedef_file_loc = Some dec.gloc; typ = Some tid;}); - | Genumdef (n,at,e) -> + | Genumdef (n,at,e) -> ignore(insert_type (TEnum (n,at))); let id = find_type (TEnum (n,[])) in let enumerator = List.map (fun (i,c,_) -> - { + { enumerator_name = i.name; enumerator_const = c; }) e in @@ -459,37 +412,35 @@ let insert_global_declaration env dec= let set_member_offset str field offset = let id = find_type (TStruct (str,[])) in replace_composite id (fun comp -> - let name f = f.cfd_name = field || match f.cfd_bitfield with Some n -> n = field | _ -> false in + let name f = f.cfd_name = field || match f.cfd_bitfield with Some n -> n = field | _ -> false in let members = list_replace name (fun a -> {a with cfd_byte_offset = Some offset;}) comp.ct_members in {comp with ct_members = members;}) let set_composite_size comp sou size = let id = find_type (gen_comp_typ sou comp []) in - replace_composite id (fun comp -> {comp with ct_sizeof = size;}) + replace_composite id (fun comp -> {comp with ct_sizeof = size;}) let set_bitfield_offset str field offset underlying size = let id = find_type (TStruct (str,[])) in replace_composite id (fun comp -> let name f = f.cfd_name = field in - let members = list_replace name (fun a -> + let members = list_replace name (fun a -> {a with cfd_bit_offset = Some offset; cfd_bitfield = Some underlying; cfd_byte_size = Some size}) comp.ct_members in {comp with ct_members = members;}) -let atom_global_variable id atom = - try - let id,var = find_gvar_stamp id.stamp in - replace_var id ({var with gvar_atom = Some atom;}); - Hashtbl.add atom_to_definition atom id - with Not_found -> () - -let atom_function id atom = +let atom_global id atom = try - let id',f = find_fun_stamp id.stamp in - replace_fun id' ({f with fun_atom = Some atom;}); - Hashtbl.add atom_to_definition atom id'; - Hashtbl.iter (fun (fid,sid) tid -> if fid = id.stamp then - Hashtbl.add atom_to_scope (atom,sid) tid) scope_to_local + let id' = (Hashtbl.find stamp_to_definition id.stamp) in + let g = Hashtbl.find definitions id' in + match g with + | Function f -> + replace_fun id' ({f with fun_atom = Some atom;}); + Hashtbl.add atom_to_definition atom id'; + Hashtbl.iter (fun (fid,sid) tid -> if fid = id.stamp then + Hashtbl.add atom_to_scope (atom,sid) tid) scope_to_local + | GlobalVariable var -> + replace_var id' ({var with gvar_atom = Some atom;}) with Not_found -> () let atom_parameter fid id atom = @@ -499,7 +450,7 @@ let atom_parameter fid id atom = let params = list_replace name (fun p -> {p with parameter_atom = Some atom;}) f.fun_parameter in replace_fun fid' ({f with fun_parameter = params;}) with Not_found -> () - + let add_fun_addr atom (high,low) = try let id,f = find_fun_atom atom in @@ -509,14 +460,13 @@ let add_fun_addr atom (high,low) = let atom_local_variable id atom = try let id,var = find_lvar_stamp id.stamp in - replace_lvar id ({var with lvar_atom = Some atom;}); - Hashtbl.add atom_to_local atom id + replace_lvar id ({var with lvar_atom = Some atom;}) with Not_found -> () let add_lvar_scope f_id var_id s_id = try let s_id',scope = find_scope_id f_id s_id in - let var_id,_ = find_lvar_stamp var_id.stamp in + let var_id,_ = find_lvar_stamp var_id.stamp in replace_scope s_id' ({scope_variables = var_id::scope.scope_variables;}) with Not_found -> () @@ -582,21 +532,11 @@ let label_translation: (atom * positive, int) Hashtbl.t = Hashtbl.create 7 let add_label atom p i = Hashtbl.add label_translation (atom,p) i -(* Auxiliary data structures and functions *) -module IntSet = Set.Make(struct - type t = int - let compare (x:int) (y:int) = compare x y -end) - -let open_scopes: IntSet.t ref = ref IntSet.empty -let open_vars: atom list ref = ref [] - let open_scope atom s_id lbl = try let s_id = Hashtbl.find atom_to_scope (atom,s_id) in let old_r = try Hashtbl.find scope_ranges s_id with Not_found -> [] in let n_scop = { start_addr = Some lbl; end_addr = None;} in - open_scopes := IntSet.add s_id !open_scopes; Hashtbl.replace scope_ranges s_id (n_scop::old_r) with Not_found -> () @@ -604,14 +544,13 @@ let close_scope atom s_id lbl = try let s_id = Hashtbl.find atom_to_scope (atom,s_id) in let old_r = try Hashtbl.find scope_ranges s_id with Not_found -> [] in - let last_r,rest = + let last_r,rest = begin match old_r with | a::rest -> a,rest | _ -> assert false (* We must have an opening scope *) end in let new_r = ({last_r with end_addr = Some lbl;})::rest in - open_scopes := IntSet.remove s_id !open_scopes; Hashtbl.replace scope_ranges s_id new_r with Not_found -> () @@ -620,7 +559,6 @@ let start_live_range (f,v) lbl loc = match old_r with | RangeLoc old_r -> let n_r = { range_start = Some lbl; range_end = None; var_loc = loc } in - open_vars := v::!open_vars; Hashtbl.replace var_locations (f,v) (RangeLoc (n_r::old_r)) | _ -> () (* Parameter that is passed as variable *) @@ -638,28 +576,39 @@ let end_live_range (f,v) lbl = let stack_variable (f,v) (sp,loc) = Hashtbl.add var_locations (f,v) (FunctionLoc (sp,loc)) -let function_end atom loc = - IntSet.iter (fun id -> close_scope atom id loc) !open_scopes; - open_scopes := IntSet.empty; - List.iter (fun id-> end_live_range (atom,id) loc) !open_vars; - open_vars:= [] - let compilation_section_start: (string,int) Hashtbl.t = Hashtbl.create 7 let compilation_section_end: (string,int) Hashtbl.t = Hashtbl.create 7 -let diab_additional: (string,int * int * string) Hashtbl.t = Hashtbl.create 7 +let diab_additional: (string,int * int * section_name) Hashtbl.t = Hashtbl.create 7 + +let section_to_string = function + | Section_user (n,_,_) -> n + | _ -> ".text" let add_compilation_section_start sec addr = + let sec = section_to_string sec in Hashtbl.add compilation_section_start sec addr let add_compilation_section_end sec addr = + let sec = section_to_string sec in Hashtbl.add compilation_section_end sec addr -let add_diab_info sec addr = - Hashtbl.add diab_additional sec addr +let add_diab_info sec addr1 add2 addr3 = + let sec' = section_to_string sec in + Hashtbl.add compilation_section_start sec' addr3; + Hashtbl.add diab_additional sec' (addr1,add2,sec) + +let diab_add_fun_addr name _ addr = add_fun_addr name addr + +let gnu_add_fun_addr name sec (high,low) = + let sec = section_to_string sec in + if not (Hashtbl.mem compilation_section_start sec) then + Hashtbl.add compilation_section_start sec low; + Hashtbl.replace compilation_section_end sec high; + add_fun_addr name (high,low) let exists_section sec = - Hashtbl.mem compilation_section_start sec + Hashtbl.mem compilation_section_start (section_to_string sec) let filenum: (string * string,int) Hashtbl.t = Hashtbl.create 7 @@ -690,11 +639,14 @@ let init name = Hashtbl.reset atom_to_definition; Hashtbl.reset local_variables; Hashtbl.reset stamp_to_local; - Hashtbl.reset atom_to_local; Hashtbl.reset scope_to_local; + Hashtbl.reset atom_to_scope; Hashtbl.reset compilation_section_start; Hashtbl.reset compilation_section_end; + Hashtbl.reset diab_additional; Hashtbl.reset filenum; + Hashtbl.reset var_locations; + Hashtbl.reset scope_ranges; + Hashtbl.reset label_translation; all_files := StringSet.singleton name; - Hashtbl.reset diab_additional; - printed_vars := StringSet.empty; + printed_vars := StringSet.empty diff --git a/debug/DebugInit.ml b/debug/DebugInit.ml index 7ee56ff1..455112ed 100644 --- a/debug/DebugInit.ml +++ b/debug/DebugInit.ml @@ -18,75 +18,51 @@ open Dwarfgen open DwarfTypes open Debug +let default_debug = + { + init = DebugInformation.init; + atom_global = DebugInformation.atom_global; + set_composite_size = DebugInformation.set_composite_size; + set_member_offset = DebugInformation.set_member_offset; + set_bitfield_offset = DebugInformation.set_bitfield_offset; + insert_global_declaration = DebugInformation.insert_global_declaration; + add_fun_addr = (fun _ _ _ -> ()); + generate_debug_info = (fun _ _ -> None); + all_files_iter = (fun f -> DebugInformation.StringSet.iter f !DebugInformation.all_files); + insert_local_declaration = DebugInformation.insert_local_declaration; + atom_local_variable = DebugInformation.atom_local_variable; + enter_scope = DebugInformation.enter_scope; + enter_function_scope = DebugInformation.enter_function_scope; + add_lvar_scope = DebugInformation.add_lvar_scope; + open_scope = DebugInformation.open_scope; + close_scope = DebugInformation.close_scope; + start_live_range = DebugInformation.start_live_range; + end_live_range = DebugInformation.end_live_range; + stack_variable = DebugInformation.stack_variable; + add_label = DebugInformation.add_label; + atom_parameter = DebugInformation.atom_parameter; + compute_diab_file_enum = DebugInformation.compute_diab_file_enum; + compute_gnu_file_enum = DebugInformation.compute_gnu_file_enum; + exists_section = DebugInformation.exists_section; + remove_unused = DebugInformation.remove_unused; + variable_printed = DebugInformation.variable_printed; + add_diab_info = (fun _ _ _ _ -> ()); + } + let init_debug () = - implem.init <- DebugInformation.init; - implem.atom_function <- DebugInformation.atom_function; - implem.atom_global_variable <- DebugInformation.atom_global_variable; - implem.set_composite_size <- DebugInformation.set_composite_size; - implem.set_member_offset <- DebugInformation.set_member_offset; - implem.set_bitfield_offset <- DebugInformation.set_bitfield_offset; - implem.insert_global_declaration <- DebugInformation.insert_global_declaration; - implem.add_fun_addr <- DebugInformation.add_fun_addr; - implem.generate_debug_info <- - if Configuration.system = "diab" then - (fun a b -> Some (Dwarfgen.gen_diab_debug_info a b)) - else - (fun a b -> Some (Dwarfgen.gen_gnu_debug_info a b)); - implem.all_files_iter <- (fun f -> DebugInformation.StringSet.iter f !DebugInformation.all_files); - implem.insert_local_declaration <- DebugInformation.insert_local_declaration; - implem.atom_local_variable <- DebugInformation.atom_local_variable; - implem.enter_scope <- DebugInformation.enter_scope; - implem.enter_function_scope <- DebugInformation.enter_function_scope; - implem.add_lvar_scope <- DebugInformation.add_lvar_scope; - implem.open_scope <- DebugInformation.open_scope; - implem.close_scope <- DebugInformation.close_scope; - implem.start_live_range <- DebugInformation.start_live_range; - implem.end_live_range <- DebugInformation.end_live_range; - implem.stack_variable <- DebugInformation.stack_variable; - implem.function_end <- DebugInformation.function_end; - implem.add_label <- DebugInformation.add_label; - implem.atom_parameter <- DebugInformation.atom_parameter; - implem.add_compilation_section_start <- DebugInformation.add_compilation_section_start; - implem.add_compilation_section_end <- DebugInformation.add_compilation_section_end; - implem.compute_diab_file_enum <- DebugInformation.compute_diab_file_enum; - implem.compute_gnu_file_enum <- DebugInformation.compute_gnu_file_enum; - implem.exists_section <- DebugInformation.exists_section; - implem.remove_unused <- DebugInformation.remove_unused; - implem.variable_printed <- DebugInformation.variable_printed; - implem.add_diab_info <- DebugInformation.add_diab_info + implem := + if Configuration.system = "diab" then + let gen = (fun a b -> Some (Dwarfgen.gen_diab_debug_info a b)) in + Clflags.option_gdwarf := 2; (* Dwarf 2 is the only supported target *) + {default_debug with generate_debug_info = gen; + add_diab_info = DebugInformation.add_diab_info; + add_fun_addr = DebugInformation.diab_add_fun_addr;} + else + {default_debug with generate_debug_info = (fun a b -> Some (Dwarfgen.gen_gnu_debug_info a b)); + add_fun_addr = DebugInformation.gnu_add_fun_addr} let init_none () = - implem.init <- (fun _ -> ()); - implem.atom_function <- (fun _ _ -> ()); - implem.atom_global_variable <- (fun _ _ -> ()); - implem.set_composite_size <- (fun _ _ _ -> ()); - implem.set_member_offset <- (fun _ _ _ -> ()); - implem.set_bitfield_offset <- (fun _ _ _ _ _ -> ()); - implem.insert_global_declaration <- (fun _ _ -> ()); - implem.add_fun_addr <- (fun _ _ -> ()); - implem.generate_debug_info <- (fun _ _ -> None); - implem.all_files_iter <- (fun _ -> ()); - implem.insert_local_declaration <- (fun _ _ _ _ -> ()); - implem.atom_local_variable <- (fun _ _ -> ()); - implem.enter_scope <- (fun _ _ _ -> ()); - implem.enter_function_scope <- (fun _ _ -> ()); - implem.add_lvar_scope <- (fun _ _ _ -> ()); - implem.open_scope <- (fun _ _ _ -> ()); - implem.close_scope <- (fun _ _ _ -> ()); - implem.start_live_range <- (fun _ _ _ -> ()); - implem.end_live_range <- (fun _ _ -> ()); - implem.stack_variable <- (fun _ _ -> ()); - implem.function_end <- (fun _ _ -> ()); - implem.add_label <- (fun _ _ _ -> ()); - implem.atom_parameter <- (fun _ _ _ -> ()); - implem.add_compilation_section_start <- (fun _ _ -> ()); - implem.add_compilation_section_end <- (fun _ _ -> ()); - implem.compute_diab_file_enum <- (fun _ _ _ -> ()); - implem.compute_gnu_file_enum <- (fun _ -> ()); - implem.exists_section <- (fun _ -> true); - implem.remove_unused <- (fun _ -> ()); - implem.variable_printed <- (fun _ -> ()); - implem.add_diab_info <- (fun _ _ -> ()) + implem := default_implem let init () = if !Clflags.option_g && Configuration.advanced_debug then diff --git a/debug/DebugTypes.mli b/debug/DebugTypes.mli index 6a4f619c..b2f19f7a 100644 --- a/debug/DebugTypes.mli +++ b/debug/DebugTypes.mli @@ -68,7 +68,7 @@ type enum_type = { enum_name: string; enum_byte_size: int option; enum_file_loc: location option; - enum_enumerators: enumerator list; + enum_enumerators: enumerator list; } type int_type = { @@ -115,7 +115,7 @@ type global_variable_information = { gvar_type: int; } -type parameter_information = +type parameter_information = { parameter_name: string; parameter_ident: int; @@ -150,7 +150,7 @@ type local_variable_information = { lvar_static: bool; (* Static variable are mapped to symbols *) } -type scope_information = +type scope_information = { scope_variables: int list; (* Variable and Scope ids *) } diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index 980c49db..3e85ecfc 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -27,55 +27,77 @@ module DwarfPrinter(Target: DWARF_TARGET): open Target + let print_comment oc s = + if s <> "" then + fprintf oc " %s %s" comment s + + let string_of_comment s = sprintf " %s %s" comment s + + let add_comment buf s = + Buffer.add_string buf (sprintf " %s %s" comment s) + (* Byte value to string *) - let string_of_byte value = - sprintf " .byte %s\n" (if value then "0x1" else "0x0") + let string_of_byte value ct = + sprintf " .byte %s%s\n" (if value then "0x1" else "0x0") (string_of_comment ct) (* Print a label *) let print_label oc lbl = fprintf oc "%a:\n" label lbl - (* Print a positive label *) - let print_plabel oc lbl = - print_label oc (transl_label lbl) - (* Helper functions for abbreviation printing *) - let add_byte buf value = - Buffer.add_string buf (string_of_byte value) + let add_byte buf value ct = + Buffer.add_string buf (string_of_byte value ct) - let add_abbr_uleb v buf = - Buffer.add_string buf (Printf.sprintf " .uleb128 %d\n" v) + let add_abbr_uleb v ct buf = + Buffer.add_string buf (sprintf " .uleb128 %d%s\n" v (string_of_comment ct)) + + let add_abbr_entry (v1,c1,v2) buf = + add_abbr_uleb v1 c1 buf; + let v2,c2 = code_of_dw_form v2 in + Buffer.add_string buf (sprintf " .uleb128 %d%s\n" v2 (string_of_comment c2)) - 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 + add_abbr_entry (0x3a,"DW_AT_decl_file",DW_FORM_data4) buf; + add_abbr_entry (0x3b,"DW_AT_decl_line",DW_FORM_udata) buf + + let add_type = add_abbr_entry (0x49,"DW_AT_type",DW_FORM_ref_addr) + + let add_byte_size = add_abbr_entry (0x0b,"DW_AT_byte_size",DW_FORM_data1) - let add_type = add_abbr_entry (0x49,type_abbr) + let add_member_size = add_abbr_entry (0x0b,"DW_AT_byte_size",DW_FORM_udata) - let add_name = add_abbr_entry (0x3,name_type_abbr) + let add_high_pc = add_abbr_entry (0x12,"DW_AT_high_pc",DW_FORM_addr) - let add_byte_size = add_abbr_entry (0xb,byte_size_type_abbr) + let add_low_pc = add_abbr_entry (0x11,"DW_AT_low_pc",DW_FORM_addr) - let add_member_size = add_abbr_entry (0xb,member_size_abbr) + let add_declaration = add_abbr_entry (0x3c,"DW_AT_declaration",DW_FORM_flag) - let add_high_pc = add_abbr_entry (0x12,high_pc_type_abbr) + let add_string buf id c = function + | Simple_string _ -> add_abbr_entry (id,c,DW_FORM_string) buf + | Offset_string _ -> add_abbr_entry (id,c,DW_FORM_strp) buf - let add_low_pc = add_abbr_entry (0x11,low_pc_type_abbr) + let add_name buf = add_string buf 0x3 "DW_AT_name" - let add_declaration = add_abbr_entry (0x3c,declaration_type_abbr) + let add_name_opt buf = function + | None -> () + | Some s -> add_name buf s let add_location loc buf = match loc with | None -> () - | Some (LocRef _) -> add_abbr_entry (0x2,location_ref_type_abbr) buf + | Some (LocRef _) -> add_abbr_entry (0x2,"DW_AT_location",DW_FORM_data4) buf | Some (LocList _ ) | Some (LocSymbol _) - | Some (LocSimple _) -> add_abbr_entry (0x2,location_block_type_abbr) buf + | Some (LocSimple _) -> add_abbr_entry (0x2,"DW_AT_location",DW_FORM_block) buf + + let add_range buf = function + | Pc_pair _ -> + add_abbr_entry (0x11,"DW_AT_low_pc",DW_FORM_addr) buf; + add_abbr_entry (0x12,"DW_AT_high_pc",DW_FORM_addr) buf + | Offset _ -> + add_abbr_entry (0x55,"DW_AT_ranges",DW_FORM_data4) buf + | Empty -> () (* Dwarf entity to string function *) let abbrev_string_of_entity entity has_sibling = @@ -84,130 +106,122 @@ module DwarfPrinter(Target: DWARF_TARGET): match v with | None -> () | Some _ -> f buf in - let prologue id = + let prologue id c = 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; + add_abbr_uleb id c buf; + add_byte buf has_child (if has_child then "DW_CHILDREN_yes" else "DW_CHILDREN_no"); + if has_sibling then add_abbr_entry (0x1,"DW_AT_sibling",DW_FORM_ref4) buf; in (match entity.tag with | DW_TAG_array_type e -> - prologue 0x1; - add_attr_some e.array_type_file_loc add_file_loc; + prologue 0x1 "DW_TAG_array_type"; add_type buf | DW_TAG_base_type b -> - prologue 0x24; + prologue 0x24 "DW_TAG_base_type"; add_byte_size buf; - add_attr_some b.base_type_encoding (add_abbr_entry (0x3e,encoding_type_abbr)); - add_name buf + add_attr_some b.base_type_encoding (add_abbr_entry (0x3e,"DW_AT_encoding",DW_FORM_data1)); + add_name buf b.base_type_name; | DW_TAG_compile_unit e -> - prologue 0x11; - add_abbr_entry (0x1b,comp_dir_type_abbr) buf; - add_low_pc buf; - add_high_pc buf; - add_abbr_entry (0x13,language_type_abbr) buf; - add_name buf; - add_abbr_entry (0x25,producer_type_abbr) buf; - add_abbr_entry (0x10,stmt_list_type_abbr) buf; + prologue 0x11 "DW_TAG_compile_unit"; + add_string buf 0x1b "DW_AT_comp_dir" e.compile_unit_dir; + add_range buf e.compile_unit_range; + add_abbr_entry (0x13,"DW_AT_language",DW_FORM_udata) buf; + add_name buf e.compile_unit_name; + add_string buf 0x25 "DW_AT_producer" e.compile_unit_prod_name; + add_abbr_entry (0x10,"DW_AT_stmt_list",DW_FORM_data4) buf; | DW_TAG_const_type _ -> - prologue 0x26; + prologue 0x26 "DW_TAG_const_type"; add_type buf | DW_TAG_enumeration_type e -> - prologue 0x4; + prologue 0x4 "DW_TAG_enumeration_type"; add_attr_some e.enumeration_file_loc add_file_loc; add_byte_size buf; add_attr_some e.enumeration_declaration add_declaration; - add_attr_some e.enumeration_name add_name + add_name buf e.enumeration_name | 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 + prologue 0x28 "DW_TAG_enumerator"; + add_abbr_entry (0x1c,"DW_AT_const_value",DW_FORM_sdata) buf; + add_name buf e.enumerator_name | DW_TAG_formal_parameter e -> - 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_attr_some e.formal_parameter_name add_name; + prologue 0x5 "DW_TAG_formal_parameter"; + add_attr_some e.formal_parameter_artificial (add_abbr_entry (0x34,"DW_AT_artificial",DW_FORM_flag)); + add_name_opt buf e.formal_parameter_name; add_type buf; - add_attr_some e.formal_parameter_variable_parameter (add_abbr_entry (0x4b,variable_parameter_type_abbr)); + add_attr_some e.formal_parameter_variable_parameter (add_abbr_entry (0x4b,"DW_AT_variable_parameter",DW_FORM_flag)); add_location e.formal_parameter_location buf - | DW_TAG_label _ -> - prologue 0xa; + | DW_TAG_label e -> + prologue 0xa "DW_TAG_label"; add_low_pc buf; - add_name buf; + add_name buf e.label_name; | DW_TAG_lexical_block a -> - prologue 0xb; - add_attr_some a.lexical_block_high_pc add_high_pc; - add_attr_some a.lexical_block_low_pc add_low_pc + prologue 0xb "DW_TAG_lexical_block"; + add_range buf a.lexical_block_range; | DW_TAG_member e -> - prologue 0xd; - add_attr_some e.member_file_loc add_file_loc; + prologue 0xd "DW_TAG_member"; add_attr_some e.member_byte_size add_byte_size; - 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_bit_offset (add_abbr_entry (0xc,"DW_AT_bit_offset",DW_FORM_data1)); + add_attr_some e.member_bit_size (add_abbr_entry (0xd,"DW_AT_bit_size",DW_FORM_data1)); add_attr_some e.member_declaration add_declaration; - add_attr_some e.member_name add_name; + add_name buf e.member_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) + | Some (DataLocBlock __) -> add_abbr_entry (0x38,"DW_AT_data_member_location",DW_FORM_block) buf + | Some (DataLocRef _) -> add_abbr_entry (0x38,"DW_AT_data_member_location",DW_FORM_ref4) buf) | DW_TAG_pointer_type _ -> - prologue 0xf; + prologue 0xf "DW_TAG_pointer_type"; add_type buf | DW_TAG_structure_type e -> - prologue 0x13; + prologue 0x13 "DW_TAG_structure_type"; add_attr_some e.structure_file_loc add_file_loc; add_attr_some e.structure_byte_size add_member_size; add_attr_some e.structure_declaration add_declaration; - add_attr_some e.structure_name add_name + add_name_opt buf e.structure_name | DW_TAG_subprogram e -> - prologue 0x2e; + prologue 0x2e "DW_TAG_subprogram"; add_file_loc buf; - add_attr_some e.subprogram_external (add_abbr_entry (0x3f,external_type_abbr)); - 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_external (add_abbr_entry (0x3f,"DW_AT_external",DW_FORM_flag)); + add_range buf e.subprogram_range; + add_name buf e.subprogram_name; + add_abbr_entry (0x27,"DW_AT_prototyped",DW_FORM_flag) buf; add_attr_some e.subprogram_type add_type; | DW_TAG_subrange_type e -> - prologue 0x21; + prologue 0x21 "DW_TAG_subrange_type"; 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) + | Some (BoundConst _) -> add_abbr_entry (0x2f,"DW_AT_upper_bound",DW_FORM_udata) buf + | Some (BoundRef _) -> add_abbr_entry (0x2f,"DW_AT_upper_bound",DW_FORM_ref4) buf) | DW_TAG_subroutine_type e -> - prologue 0x15; + prologue 0x15 "DW_TAG_subroutine_type"; add_attr_some e.subroutine_type add_type; - add_abbr_entry (0x27,prototyped_type_abbr) buf + add_abbr_entry (0x27,"DW_AT_prototyped",DW_FORM_flag) buf | DW_TAG_typedef e -> - prologue 0x16; + prologue 0x16 "DW_TAG_typedef"; add_attr_some e.typedef_file_loc add_file_loc; - add_name buf; + add_name buf e.typedef_name; add_type buf | DW_TAG_union_type e -> - prologue 0x17; + prologue 0x17 "DW_TAG_union_type"; add_attr_some e.union_file_loc add_file_loc; add_attr_some e.union_byte_size add_member_size; add_attr_some e.union_declaration add_declaration; - add_attr_some e.union_name add_name + add_name_opt buf e.union_name | 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)) + prologue 0x18 "DW_TAG_unspecified_parameter"; + add_attr_some e.unspecified_parameter_artificial (add_abbr_entry (0x34,"DW_AT_artificial",DW_FORM_flag)) | DW_TAG_variable e -> - prologue 0x34; + prologue 0x34 "DW_TAG_variable"; 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 e.variable_location buf; - add_name buf; + add_attr_some e.variable_external (add_abbr_entry (0x3f,"DW_AT_external",DW_FORM_flag)); + add_location e.variable_location buf; + add_name buf e.variable_name; add_type buf | DW_TAG_volatile_type _ -> - prologue 0x35; + prologue 0x35 "DW_TAG_volatile_type"; add_type buf); Buffer.contents buf @@ -248,16 +262,18 @@ module DwarfPrinter(Target: DWARF_TARGET): section oc Section_debug_abbrev; print_label oc !abbrev_start_addr; List.iter (fun (s,id) -> - fprintf oc " .uleb128 %d\n" id; + fprintf oc " .uleb128 %d%a\n" id print_comment "Abbreviation Code"; output_string oc s; - fprintf oc " .uleb128 0\n"; - fprintf oc " .uleb128 0\n\n") abbrevs; - fprintf oc " .sleb128 0\n" + fprintf oc " .uleb128 0%a\n" print_comment "EOM(1)"; + fprintf oc " .uleb128 0%a\n" print_comment "EOM(2)") abbrevs; + fprintf oc " .sleb128 0%a\n" print_comment "EOM(3)" let debug_start_addr = ref (-1) let debug_stmt_list = ref (-1) + let debug_ranges_addr = ref (-1) + let entry_labels: (int,int) Hashtbl.t = Hashtbl.create 7 (* Translate the ids to address labels *) @@ -280,116 +296,117 @@ module DwarfPrinter(Target: DWARF_TARGET): Hashtbl.add loc_labels id label; label - let print_loc_ref oc r = + let print_loc_ref oc c r = let ref = loc_to_label r in - fprintf oc " .4byte %a\n" label ref + fprintf oc " .4byte %a%a\n" label ref print_comment c (* Helper functions for debug printing *) - let print_opt_value oc o f = + let print_opt_value oc c o f = match o with | None -> () - | Some o -> f oc o + | Some o -> f oc c o - let print_flag oc b = - output_string oc (string_of_byte b) + let print_flag oc c b = + output_string oc (string_of_byte b c) - let print_string oc s = - fprintf oc " .asciz \"%s\"\n" s + let print_string oc c = function + | Simple_string s -> + fprintf oc " .asciz \"%s\"%a\n" s print_comment c + | Offset_string o -> print_loc_ref oc c o - let print_uleb128 oc d = - fprintf oc " .uleb128 %d\n" d + let print_uleb128 oc c d = + fprintf oc " .uleb128 %d%a\n" d print_comment c - let print_sleb128 oc d = - fprintf oc " .sleb128 %d\n" d + let print_sleb128 oc c d = + fprintf oc " .sleb128 %d%a\n" d print_comment c - let print_byte oc b = - fprintf oc " .byte 0x%X\n" b + let print_byte oc c b = + fprintf oc " .byte 0x%X%a\n" b print_comment c - let print_2byte oc b = - fprintf oc " .2byte 0x%X\n" b + let print_2byte oc c b = + fprintf oc " .2byte 0x%X%a\n" b print_comment c - let print_ref oc r = + let print_ref oc c r = let ref = entry_to_label r in - fprintf oc " .4byte %a\n" label ref + fprintf oc " .4byte %a%a\n" label ref print_comment c let print_file_loc oc = function | Some (Diab_file_loc (file,col)) -> - fprintf oc " .4byte %a\n" label file; - print_uleb128 oc col + fprintf oc " .4byte %a%a\n" label file print_comment "DW_AT_decl_file"; + print_uleb128 oc "DW_AT_decl_line" col | Some (Gnu_file_loc (file,col)) -> - fprintf oc " .4byte %l\n" file; - print_uleb128 oc col + fprintf oc " .4byte %l%a\n" file print_comment "DW_AT_decl_file"; + print_uleb128 oc "DW_AT_decl_line" col | None -> () let print_loc_expr oc = function | DW_OP_bregx (a,b) -> - print_byte oc dw_op_bregx; - print_uleb128 oc a; - fprintf oc " .sleb128 %ld\n" b + print_byte oc "" dw_op_bregx; + print_uleb128 oc "" a; + fprintf oc " .sleb128 %ld\n" b; | DW_OP_plus_uconst i -> - print_byte oc dw_op_plus_uconst; - print_uleb128 oc i + print_byte oc "" dw_op_plus_uconst; + print_uleb128 oc "" i | DW_OP_piece i -> - print_byte oc dw_op_piece; - print_uleb128 oc i + print_byte oc "" dw_op_piece; + print_uleb128 oc "" i | DW_OP_reg i -> if i < 32 then - print_byte oc (dw_op_reg0 + i) + print_byte oc "" (dw_op_reg0 + i) else begin - print_byte oc dw_op_regx; - print_uleb128 oc i + print_byte oc "" dw_op_regx; + print_uleb128 oc "" i end - let print_loc oc loc = + let print_loc oc c loc = match loc with | LocSymbol s -> - print_sleb128 oc 5; - print_byte oc dw_op_addr; + print_sleb128 oc c 5; + print_byte oc "" dw_op_addr; fprintf oc " .4byte %a\n" symbol s | LocSimple e -> - print_sleb128 oc (size_of_loc_expr e); + print_sleb128 oc c (size_of_loc_expr e); print_loc_expr oc e | LocList e -> let size = List.fold_left (fun acc a -> acc + size_of_loc_expr a) 0 e in - print_sleb128 oc size; + print_sleb128 oc "" size; List.iter (print_loc_expr oc) e - | LocRef f -> print_loc_ref oc f + | LocRef f -> print_loc_ref oc c f let print_list_loc oc = function | LocSymbol s -> - print_2byte oc 5; - print_byte oc dw_op_addr; + print_2byte oc "" 5; + print_byte oc "" dw_op_addr; fprintf oc " .4byte %a\n" symbol s | LocSimple e -> - print_2byte oc (size_of_loc_expr e); + print_2byte oc "" (size_of_loc_expr e); print_loc_expr oc e | LocList e -> let size = List.fold_left (fun acc a -> acc + size_of_loc_expr a) 0 e in - print_2byte oc size; + print_2byte oc "" size; List.iter (print_loc_expr oc) e - | LocRef f -> print_loc_ref oc f + | LocRef f -> print_loc_ref oc "" f - let print_data_location oc dl = + let print_data_location oc c dl = match dl with | DataLocBlock e -> - print_sleb128 oc (size_of_loc_expr e); + print_sleb128 oc c (size_of_loc_expr e); print_loc_expr oc e | _ -> () - let print_addr oc a = - fprintf oc " .4byte %a\n" label a + let print_addr oc c a = + fprintf oc " .4byte %a%a\n" label a print_comment c let print_array_type oc at = - print_file_loc oc at.array_type_file_loc; - print_ref oc at.array_type + print_ref oc "DW_AT_type" at.array_type - let print_bound_value oc = function - | BoundConst bc -> print_uleb128 oc bc - | BoundRef br -> print_ref oc br + let print_bound_value oc c = function + | BoundConst bc -> print_uleb128 oc c bc + | BoundRef br -> print_ref oc c br let print_base_type oc bt = - print_byte oc bt.base_type_byte_size; + print_byte oc "DW_AT_byte_size" bt.base_type_byte_size; (match bt.base_type_encoding with | Some e -> let encoding = match e with @@ -402,123 +419,114 @@ module DwarfPrinter(Target: DWARF_TARGET): | DW_ATE_unsigned -> 0x7 | DW_ATE_unsigned_char -> 0x8 in - print_byte oc encoding; + print_byte oc "DW_AT_encoding" encoding; | None -> ()); - print_string oc bt.base_type_name + print_string oc "DW_AT_name" bt.base_type_name + + let print_range oc = function + | Pc_pair (l,h) -> + print_addr oc "DW_AT_low_pc" l; + print_addr oc "DW_AT_high_pc" h + | Offset i -> fprintf oc " .4byte %a+0x%d%a\n" + label !debug_ranges_addr i print_comment "DW_AT_ranges" + | _ -> () let print_compilation_unit oc tag = - let version_string = - if Version.buildnr <> "" && Version.tag <> "" then - sprintf "%s, Build: %s, Tag: %s" Version.version Version.buildnr Version.tag - else - Version.version in - let prod_name = sprintf "AbsInt Angewandte Informatik GmbH:CompCert Version %s:(%s,%s,%s,%s)" - version_string Configuration.arch Configuration.system Configuration.abi Configuration.model in - print_string oc (Sys.getcwd ()); - print_addr oc tag.compile_unit_low_pc; - print_addr oc tag.compile_unit_high_pc; - print_uleb128 oc 1; - print_string oc tag.compile_unit_name; - print_string oc prod_name; - print_addr oc !debug_stmt_list + print_string oc "DW_AT_comp_dir" tag.compile_unit_dir; + print_range oc tag.compile_unit_range; + print_uleb128 oc "DW_AT_language" 1; + print_string oc "DW_AT_name" tag.compile_unit_name; + print_string oc "DW_AT_producer" tag.compile_unit_prod_name; + print_addr oc "DW_AT_stmt_list" !debug_stmt_list let print_const_type oc ct = - print_ref oc ct.const_type + print_ref oc "DW_AT_type" 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_opt_value oc et.enumeration_name print_string + print_uleb128 oc "DW_AT_byte_size" et.enumeration_byte_size; + print_opt_value oc "DW_AT_declaration" et.enumeration_declaration print_flag; + print_string oc "DW_AT_name" 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 + print_sleb128 oc "DW_AT_const_value" en.enumerator_value; + print_string oc "DW_AT_name" 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_name print_string; - print_ref oc fp.formal_parameter_type; - print_opt_value oc fp.formal_parameter_variable_parameter print_flag; - print_opt_value oc fp.formal_parameter_location print_loc + print_opt_value oc "DW_AT_artificial" fp.formal_parameter_artificial print_flag; + print_opt_value oc "DW_AT_name" fp.formal_parameter_name print_string; + print_ref oc "DW_AT_type" fp.formal_parameter_type; + print_opt_value oc "DW_AT_variable_parameter" fp.formal_parameter_variable_parameter print_flag; + print_opt_value oc "DW_AT_location" fp.formal_parameter_location print_loc let print_tag_label oc tl = - print_ref oc tl.label_low_pc; - print_string oc tl.label_name + print_ref oc "DW_AT_low_pc" tl.label_low_pc; + print_string oc "DW_AT_name" tl.label_name let print_lexical_block oc lb = - print_opt_value oc lb.lexical_block_high_pc print_addr; - print_opt_value oc lb.lexical_block_low_pc print_addr + print_range oc lb.lexical_block_range 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_declaration print_flag; - print_opt_value oc mb.member_name print_string; - print_ref oc mb.member_type; - print_opt_value oc mb.member_data_member_location print_data_location + print_opt_value oc "DW_AT_byte_size" mb.member_byte_size print_byte; + print_opt_value oc "DW_AT_bit_offset" mb.member_bit_offset print_byte; + print_opt_value oc "DW_AT_bit_size" mb.member_bit_size print_byte; + print_opt_value oc "DW_AT_declaration" mb.member_declaration print_flag; + print_string oc "DW_AT_name" mb.member_name; + print_ref oc "DW_AT_type" mb.member_type; + print_opt_value oc "DW_AT_data_member_location" mb.member_data_member_location print_data_location let print_pointer oc pt = - print_ref oc pt.pointer_type + print_ref oc "DW_AT_type" 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_opt_value oc st.structure_name print_string - - let print_subprogram_addr oc (s,e) = - fprintf oc " .4byte %a\n" label e; - fprintf oc " .4byte %a\n" label s - + print_opt_value oc "DW_AT_byte_size" st.structure_byte_size print_uleb128; + print_opt_value oc "DW_AT_declaration" st.structure_declaration print_flag; + print_opt_value oc "DW_AT_name" st.structure_name print_string + + let print_subprogram oc sp = print_file_loc oc (Some sp.subprogram_file_loc); - print_opt_value oc sp.subprogram_external print_flag; - 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 + print_opt_value oc "DW_AT_external" sp.subprogram_external print_flag; + print_range oc sp.subprogram_range; + print_string oc "DW_AT_name" sp.subprogram_name; + print_flag oc "DW_AT_prototyped" sp.subprogram_prototyped; + print_opt_value oc "DW_AT_type" 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 + print_opt_value oc "DW_AT_type" sr.subrange_type print_ref; + print_opt_value oc "DW_AT_upper_bound" 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 + print_opt_value oc "DW_AT_type" st.subroutine_type print_ref; + print_flag oc "DW_AT_prototyped" 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 + print_string oc "DW_AT_name" td.typedef_name; + print_ref oc "DW_AT_type" 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_opt_value oc ut.union_name print_string + print_opt_value oc "DW_AT_byte_size" ut.union_byte_size print_uleb128; + print_opt_value oc "DW_AT_declaration" ut.union_declaration print_flag; + print_opt_value oc "DW_AT_name" ut.union_name print_string 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 + print_opt_value oc "DW_AT_artificial" up.unspecified_parameter_artificial print_flag let print_variable oc var = 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 var.variable_location print_loc; - print_string oc var.variable_name; - print_ref oc var.variable_type + print_opt_value oc "DW_AT_declaration" var.variable_declaration print_flag; + print_opt_value oc "DW_AT_external" var.variable_external print_flag; + print_opt_value oc "DW_AT_location" var.variable_location print_loc; + print_string oc "DW_AT_name" var.variable_name; + print_ref oc "DW_AT_type" var.variable_type let print_volatile_type oc vt = - print_ref oc vt.volatile_type + print_ref oc "DW_AT_type" vt.volatile_type (* Print an debug entry *) let print_entry oc entry = @@ -528,11 +536,11 @@ module DwarfPrinter(Target: DWARF_TARGET): | None -> false | Some _ -> true in let id = get_abbrev entry has_sib in - print_sleb128 oc id; + print_sleb128 oc (sprintf "Abbrev [%d] %s" id (string_of_dw_tag entry.tag)) 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); + fprintf oc " .4byte %a-%a%a\n" label lbl label !debug_start_addr print_comment "DW_AT_sibling"); begin match entry.tag with | DW_TAG_array_type arr_type -> print_array_type oc arr_type @@ -557,12 +565,7 @@ module DwarfPrinter(Target: DWARF_TARGET): | 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 entries = - List.iter (fun (_,_,_,e,_) -> compute_abbrev e) entries; - print_abbrev oc + print_sleb128 oc "End Of Children Mark" 0) entry (* Print the debug info section *) let print_debug_info oc start line_start entry = @@ -572,13 +575,13 @@ module DwarfPrinter(Target: DWARF_TARGET): print_label oc start; let debug_length_start = new_label () (* Address used for length calculation *) and debug_end = new_label () in - fprintf oc " .4byte %a-%a\n" label debug_end label debug_length_start; + fprintf oc " .4byte %a-%a%a\n" label debug_end label debug_length_start print_comment "Length of Unit"; 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 *) + fprintf oc " .2byte 0x%d%a\n" !Clflags.option_gdwarf print_comment "DWARF version number"; (* Dwarf version *) + print_addr oc "Offset Into Abbrev. Section" !abbrev_start_addr; (* Offset into the abbreviation *) + print_byte oc "Address Size (in bytes)" !Machine.config.Machine.sizeof_ptr; (* Sizeof pointer type *) print_entry oc entry; - print_sleb128 oc 0; + print_sleb128 oc "" 0; print_label oc debug_end (* End of the debug section *) let print_location_entry oc c_low l = @@ -590,36 +593,77 @@ module DwarfPrinter(Target: DWARF_TARGET): fprintf oc " .4byte 0\n"; fprintf oc " .4byte 0\n" + let print_location_entry_abs oc l = + print_label oc (loc_to_label l.loc_id); + List.iter (fun (b,e,loc) -> + fprintf oc " .4byte %a\n" label b; + fprintf oc " .4byte %a\n" label e; + print_list_loc oc loc) l.loc; + fprintf oc " .4byte 0\n"; + fprintf oc " .4byte 0\n" + + let print_location_list oc (c_low,l) = - List.iter (print_location_entry oc c_low) l + let f = match c_low with + | Some s -> print_location_entry oc s + | None -> print_location_entry_abs oc in + List.iter f l + + let list_opt l f = + match l with + | [] -> () + | _ -> f () let print_diab_entries oc entries = let abbrev_start = new_label () in - abbrev_start_addr := abbrev_start; - print_debug_abbrev oc entries; - List.iter (fun (s,d,l,e,_) -> - section oc (Section_debug_info s); - print_debug_info oc d l e) entries; + abbrev_start_addr := abbrev_start; + List.iter (fun e -> compute_abbrev e.entry) entries; + print_abbrev oc; + List.iter (fun e -> + let name = if e.section_name <> ".text" then Some e.section_name else None in + section oc (Section_debug_info name); + print_debug_info oc e.start_label e.line_label e.entry) entries; section oc Section_debug_loc; - List.iter (fun (_,_,_,_,l) -> print_location_list oc l) entries - - let print_gnu_entries oc cp loc = + List.iter (fun e -> print_location_list oc e.locs) entries + + let print_ranges oc r = + section oc Section_debug_ranges; + print_label oc !debug_ranges_addr; + List.iter (fun l -> + List.iter (fun (b,e) -> + fprintf oc " .4byte %a\n" label b; + fprintf oc " .4byte %a\n" label e) l; + fprintf oc " .4byte 0\n"; + fprintf oc " .4byte 0\n") r + + let print_gnu_entries oc cp (lpc,loc) s r = compute_abbrev cp; let line_start = new_label () and start = new_label () - and abbrev_start = new_label () in + and abbrev_start = new_label () + and range_label = new_label () in + debug_ranges_addr := range_label; abbrev_start_addr := abbrev_start; - section oc (Section_debug_info ""); + section oc (Section_debug_info None); print_debug_info oc start line_start cp; print_abbrev oc; - section oc Section_debug_loc; - print_location_list oc loc; - fprintf oc " .section .debug_line,\"\",@progbits\n"; - print_label oc line_start + list_opt loc (fun () -> + section oc Section_debug_loc; + print_location_list oc (lpc,loc)); + list_opt r (fun () -> + print_ranges oc r); + section oc (Section_debug_line None); + print_label oc line_start; + list_opt s (fun () -> + section oc Section_debug_str; + List.iter (fun (id,s) -> + print_label oc (loc_to_label id); + fprintf oc " .asciz \"%s\"\n" s) s) + (* Print the debug info and abbrev section *) let print_debug oc = function | Diab entries -> print_diab_entries oc entries - | Gnu (cp,loc) -> print_gnu_entries oc cp loc + | Gnu (cp,loc,s,r) -> print_gnu_entries oc cp loc s r end diff --git a/debug/DwarfTypes.mli b/debug/DwarfTypes.mli index ed75b3d7..a4c75201 100644 --- a/debug/DwarfTypes.mli +++ b/debug/DwarfTypes.mli @@ -36,20 +36,18 @@ type encoding = type address = int -type block = string - type location_expression = | DW_OP_plus_uconst of constant - | DW_OP_bregx of int * int32 - | DW_OP_piece of int - | DW_OP_reg of int + | DW_OP_bregx of constant * int32 + | DW_OP_piece of constant + | DW_OP_reg of constant type location_value = | LocSymbol of atom | LocRef of address | LocSimple of location_expression | LocList of location_expression list - + type data_location_value = | DataLocBlock of location_expression | DataLocRef of reference @@ -58,30 +56,62 @@ type bound_value = | BoundConst of constant | BoundRef of reference +type string_const = + | Simple_string of string + | Offset_string of reference + +type file_loc = + | Diab_file_loc of constant * constant + | Gnu_file_loc of constant * constant + +type dw_form = + | DW_FORM_addr + | DW_FORM_block2 + | DW_FORM_block4 + | DW_FORM_data2 + | DW_FORM_data4 + | DW_FORM_data8 + | DW_FORM_string + | DW_FORM_block + | DW_FORM_block1 + | DW_FORM_data1 + | DW_FORM_flag + | DW_FORM_sdata + | DW_FORM_strp + | DW_FORM_udata + | DW_FORM_ref_addr + | DW_FORM_ref1 + | DW_FORM_ref2 + | DW_FORM_ref4 + | DW_FORM_ref8 + | DW_FORM_ref_udata + | DW_FORM_ref_indirect + +type dw_range = + | Pc_pair of reference * reference (* Simple low,high pc *) + | Offset of constant (* DWARF 3 version for different range *) + | Empty (* Needed for compilation units only containing variables *) + (* Types representing the attribute information per tag value *) -type file_loc = - | Diab_file_loc of int * constant - | Gnu_file_loc of int * 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; + base_type_encoding: encoding option; + base_type_name: string_const; } type dw_tag_compile_unit = { - compile_unit_name: string; - compile_unit_low_pc: int; - compile_unit_high_pc: int; + compile_unit_name: string_const; + compile_unit_range: dw_range; + compile_unit_dir: string_const; + compile_unit_prod_name: string_const; } type dw_tag_const_type = @@ -91,24 +121,22 @@ type dw_tag_const_type = type dw_tag_enumeration_type = { - enumeration_file_loc: file_loc option; + enumeration_file_loc: file_loc option; enumeration_byte_size: constant; - enumeration_declaration: flag option; - enumeration_name: string option; + enumeration_declaration: flag option; + enumeration_name: string_const; } type dw_tag_enumerator = { - enumerator_file_loc: file_loc option; enumerator_value: constant; - enumerator_name: string; + enumerator_name: string_const; } type dw_tag_formal_parameter = { - formal_parameter_file_loc: file_loc option; formal_parameter_artificial: flag option; - formal_parameter_name: string option; + formal_parameter_name: string_const option; formal_parameter_type: reference; formal_parameter_variable_parameter: flag option; formal_parameter_location: location_value option; @@ -117,24 +145,22 @@ type dw_tag_formal_parameter = type dw_tag_label = { label_low_pc: address; - label_name: string; + label_name: string_const; } type dw_tag_lexical_block = { - lexical_block_high_pc: address option; - lexical_block_low_pc: address option; + lexical_block_range: dw_range; } 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 option; + member_name: string_const; member_type: reference; } @@ -145,21 +171,20 @@ type dw_tag_pointer_type = type dw_tag_structure_type = { - structure_file_loc: file_loc option; - structure_byte_size: constant option; - structure_declaration: flag option; - structure_name: string option; + structure_file_loc: file_loc option; + structure_byte_size: constant option; + structure_declaration: flag option; + structure_name: string_const option; } type dw_tag_subprogram = { subprogram_file_loc: file_loc; - subprogram_external: flag option; - subprogram_name: string; + subprogram_external: flag option; + subprogram_name: string_const; subprogram_prototyped: flag; - subprogram_type: reference option; - subprogram_high_pc: reference option; - subprogram_low_pc: reference option; + subprogram_type: reference option; + subprogram_range: dw_range; } type dw_tag_subrange_type = @@ -177,22 +202,21 @@ type dw_tag_subroutine_type = type dw_tag_typedef = { typedef_file_loc: file_loc option; - typedef_name: string; + typedef_name: string_const; 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 option; + union_file_loc: file_loc option; + union_byte_size: constant option; + union_declaration: flag option; + union_name: string_const option; } type dw_tag_unspecified_parameter = { - unspecified_parameter_file_loc: file_loc option; - unspecified_parameter_artificial: flag option; + unspecified_parameter_artificial: flag option; } type dw_tag_variable = @@ -200,7 +224,7 @@ type dw_tag_variable = variable_file_loc: file_loc; variable_declaration: flag option; variable_external: flag option; - variable_name: string; + variable_name: string_const; variable_type: reference; variable_location: location_value option; } @@ -244,14 +268,29 @@ type dw_entry = (* The type for the location list. *) type location_entry = { - loc: (int * int * location_value) list; + loc: (address * address * location_value) list; loc_id: reference; } -type dw_locations = int * location_entry list +type dw_locations = constant option * location_entry list + +type range_entry = (address * address) list + +type dw_ranges = range_entry list + +type dw_string = (int * string) list + +type diab_entry = + { + section_name: string; + start_label: int; + line_label: int; + entry: dw_entry; + locs: dw_locations; + } -type diab_entries = (string * int * int * dw_entry * dw_locations) list +type diab_entries = diab_entry list -type gnu_entries = dw_entry * dw_locations +type gnu_entries = dw_entry * dw_locations * dw_string * dw_ranges type debug_entries = | Diab of diab_entries @@ -263,4 +302,5 @@ module type DWARF_TARGET= val label: out_channel -> int -> unit val section: out_channel -> section_name -> unit val symbol: out_channel -> atom -> unit + val comment: string end diff --git a/debug/DwarfUtil.ml b/debug/DwarfUtil.ml index 16e446ee..3e252dd2 100644 --- a/debug/DwarfUtil.ml +++ b/debug/DwarfUtil.ml @@ -53,6 +53,30 @@ let rec entry_fold f acc entry = let acc = f acc entry.tag in List.fold_left (entry_fold f) acc entry.children +(* Return the code and the corresponding comment for a DW_FORM *) +let code_of_dw_form = function + | DW_FORM_addr -> 0x01,"DW_FORM_addr" + | DW_FORM_block2 -> 0x03,"DW_FORM_block2" + | DW_FORM_block4 -> 0x04,"DW_FORM_block4" + | DW_FORM_data2 -> 0x05,"DW_FORM_data2" + | DW_FORM_data4 -> 0x06,"DW_FORM_data4" + | DW_FORM_data8 -> 0x07,"DW_FORM_data8" + | DW_FORM_string -> 0x08,"DW_FORM_string" + | DW_FORM_block -> 0x09,"DW_FORM_block" + | DW_FORM_block1 -> 0x0a,"DW_FORM_block1" + | DW_FORM_data1 -> 0x0b,"DW_FORM_data1" + | DW_FORM_flag -> 0x0c,"DW_FORM_flag" + | DW_FORM_sdata -> 0x0d,"DW_FORM_sdata" + | DW_FORM_strp -> 0x0e,"DW_FORM_strp" + | DW_FORM_udata -> 0x0f,"DW_FORM_udata" + | DW_FORM_ref_addr -> 0x10,"DW_FORM_ref_addr" + | DW_FORM_ref1 -> 0x11,"DW_FORM_ref1" + | DW_FORM_ref2 -> 0x12,"DW_FORM_ref2" + | DW_FORM_ref4 -> 0x13,"DW_FORM_ref4" + | DW_FORM_ref8 -> 0x14,"DW_FORM_ref8" + | DW_FORM_ref_udata -> 0x15,"DW_FORM_ref_udata" + | DW_FORM_ref_indirect -> 0x16,"DW_FORM_ref_indirect" + (* Attribute form encoding *) let dw_form_addr = 0x01 let dw_form_block2 = 0x03 @@ -84,35 +108,28 @@ let dw_op_regx = 0x90 let dw_op_bregx = 0x92 let dw_op_piece = 0x93 - -(* Default corresponding encoding for the different abbreviations *) -let sibling_type_abbr = dw_form_ref4 -let file_loc_type_abbr = dw_form_data4,dw_form_udata -let type_abbr = dw_form_ref_addr -let name_type_abbr = dw_form_string -let encoding_type_abbr = dw_form_data1 -let byte_size_type_abbr = dw_form_data1 -let member_size_abbr = dw_form_udata -let high_pc_type_abbr = dw_form_addr -let low_pc_type_abbr = dw_form_addr -let stmt_list_type_abbr = dw_form_data4 -let declaration_type_abbr = dw_form_flag -let external_type_abbr = dw_form_flag -let prototyped_type_abbr = dw_form_flag -let bit_offset_type_abbr = dw_form_data1 -let comp_dir_type_abbr = dw_form_string -let language_type_abbr = dw_form_udata -let producer_type_abbr = dw_form_string -let value_type_abbr = dw_form_sdata -let artificial_type_abbr = dw_form_flag -let variable_parameter_type_abbr = dw_form_flag -let bit_size_type_abbr = dw_form_data1 -let location_ref_type_abbr = dw_form_data4 -let location_block_type_abbr = dw_form_block -let data_location_block_type_abbr = dw_form_block -let data_location_ref_type_abbr = dw_form_ref4 -let bound_const_type_abbr = dw_form_udata -let bound_ref_type_abbr=dw_form_ref4 +(* Tag to string function *) +let string_of_dw_tag = function + | DW_TAG_array_type _ -> "DW_TAG_array_type" + | DW_TAG_compile_unit _ -> "DW_TAG_compile_unit" + | DW_TAG_base_type _ -> "DW_TAG_base_type" + | DW_TAG_const_type _ -> "DW_TAG_const_type" + | DW_TAG_enumeration_type _ -> "DW_TAG_enumeration_type" + | DW_TAG_enumerator _ -> "DW_TAG_enumerator" + | DW_TAG_formal_parameter _ -> "DW_TAG_formal_parameter" + | DW_TAG_label _ -> "DW_TAG_label" + | DW_TAG_lexical_block _ -> "DW_TAG_lexical_block" + | DW_TAG_member _ -> "DW_TAG_member" + | DW_TAG_pointer_type _ -> "DW_TAG_pointer_type" + | DW_TAG_structure_type _ -> "DW_TAG_structure_type" + | DW_TAG_subprogram _ -> "DW_TAG_subprogram" + | DW_TAG_subrange_type _ -> "DW_TAG_subrange_type" + | DW_TAG_subroutine_type _ -> "DW_TAG_subroutine_type" + | DW_TAG_typedef _ -> "DW_TAG_typedef" + | DW_TAG_union_type _ -> "DW_TAG_union_type" + | DW_TAG_unspecified_parameter _ -> "DW_TAG_unspecified_parameter" + | DW_TAG_variable _ -> "DW_TAG_variable" + | DW_TAG_volatile_type _ -> "DW_TAG_volatile_type" (* Sizeof functions for the encoding of uleb128 and sleb128 *) let sizeof_uleb128 value = diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml index 2258f948..56a318fe 100644 --- a/debug/Dwarfgen.ml +++ b/debug/Dwarfgen.ml @@ -50,398 +50,483 @@ let rec mmap_opt f env = function | None -> tl',env2 end -(* 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) +module type TARGET = + sig + val file_loc: string * int -> file_loc + val string_entry: string -> string_const + end -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 file_loc_opt file = function - | None -> None - | Some (f,l) -> - try - Some (file (f,l)) - with Not_found -> None - -let typedef_to_entry file id t = - let i = get_opt_val t.typ in - let td = { - typedef_file_loc = file_loc_opt file t.typedef_file_loc; - typedef_name = t.typedef_name; - typedef_type = i; - } in - new_entry id (DW_TAG_typedef td) +type dwarf_accu = + { + typs: IntSet.t; + locs: location_entry list; + ranges: int * dw_ranges + } + +let (=<<) acc t = + {acc with typs = IntSet.add t acc.typs;} + +let (<=<) acc loc = + {acc with locs = loc@acc.locs;} + +let (>>=) acc r = + {acc with ranges = r;} + +let empty_accu = + { + typs = IntSet.empty; + locs = []; + ranges = 0,[] + } + +module Dwarfgenaux (Target: TARGET) = + struct + + include Target + + let name_opt n = if n <> "" then Some (string_entry n) else None + + (* 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 = string_entry (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 = string_entry (typ_to_string (TFloat (f.float_kind,[]))); + } in + new_entry id (DW_TAG_base_type float) -let pointer_to_entry id p = - let p = {pointer_type = p.pts} in - new_entry id (DW_TAG_pointer_type p) + let void_to_entry id = + let void = { + base_type_byte_size = 0; + base_type_encoding = None; + base_type_name = string_entry "void"; + } in + new_entry id (DW_TAG_base_type void) + + let file_loc_opt = function + | None -> None + | Some (f,l) -> + try + Some (file_loc (f,l)) + with Not_found -> None + + let typedef_to_entry id t = + let i = get_opt_val t.typ in + let td = { + typedef_file_loc = file_loc_opt t.typedef_file_loc; + typedef_name = string_entry t.typedef_name; + typedef_type = i; + } in + new_entry id (DW_TAG_typedef td) -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 file 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 = file_loc_opt file 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; - formal_parameter_location = None; + 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 = arr.arr_type; } 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 = - (match mem.cfd_byte_offset with - | None -> None - | Some s -> Some (DataLocBlock (DW_OP_plus_uconst s))); - member_declaration = None; - member_name = Some (mem.cfd_name); - member_type = mem.cfd_typ; - } in - new_entry (next_id ()) (DW_TAG_member mem) - -let struct_to_entry file id s = - let tag = { - structure_file_loc = file_loc_opt file s.ct_file_loc; - structure_byte_size = s.ct_sizeof; - structure_declaration = if s.ct_declaration then Some s.ct_declaration else None; - 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 file id s = - let tag = { - union_file_loc = file_loc_opt file s.ct_file_loc; - union_byte_size = s.ct_sizeof; - union_declaration = if s.ct_declaration then Some s.ct_declaration else None; - 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 file id s = - match s.ct_sou with - | Struct -> struct_to_entry file id s - | Union -> union_to_entry file id s - -let infotype_to_entry file 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 file id c - | EnumType e -> enum_to_entry file id e - | FunctionType f -> fun_type_to_entry id f - | Typedef t -> typedef_to_entry file id t - | ConstType c -> const_to_entry id c - | VolatileType v -> volatile_to_entry id v - | Void -> void_to_entry id - -let needs_types id d = - let add_type id d = - if not (IntSet.mem id d) then - IntSet.add id d,true - else - d,false in - let t = Hashtbl.find types id in - match t with - | IntegerType _ - | FloatType _ - | Void - | EnumType _ -> d,false - | Typedef t -> - add_type (get_opt_val t.typ) d - | PointerType p -> - add_type p.pts d - | ArrayType arr -> - add_type arr.arr_type d - | ConstType c -> - add_type c.cst_type d - | VolatileType v -> - add_type v.vol_type d - | FunctionType f -> - let d,c = match f.fun_return_type with - | Some t -> add_type t d - | None -> d,false in - List.fold_left (fun (d,c) p -> - let d,c' = add_type p.param_type d in - d,c||c') (d,c) f.fun_params - | CompositeType c -> - List.fold_left (fun (d,c) f -> - let d,c' = add_type f.cfd_typ d in - d,c||c') (d,false) c.ct_members - -let gen_types file needed = - let rec aux d = - let d,c = IntSet.fold (fun id (d,c) -> - let d,c' = needs_types id d in - d,c||c') d (d,false) in - if c then - aux d - else - d in - let typs = aux needed in - List.rev (Hashtbl.fold (fun id t acc -> - if IntSet.mem id typs then - (infotype_to_entry file id t)::acc - else - acc) types []) - -let global_variable_to_entry file acc id v = - let loc = match v.gvar_atom with - | Some a when StringSet.mem (extern_atom a) !printed_vars -> - Some (LocSymbol a) - | _ -> None in - let var = { - variable_file_loc = file 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 = loc; - } in - new_entry id (DW_TAG_variable var),IntSet.add v.gvar_type acc - -let gen_splitlong op_hi op_lo = - let op_piece = DW_OP_piece 4 in - op_piece::op_hi@(op_piece::op_lo) - -let translate_function_loc a = function - | BA_addrstack (ofs) -> - let ofs = camlint_of_coqint ofs in - Some (LocSimple (DW_OP_bregx (a,ofs))),[] - | BA_splitlong (BA_addrstack hi,BA_addrstack lo)-> - let hi = camlint_of_coqint hi - and lo = camlint_of_coqint lo in - if lo = Int32.add hi 4l then - Some (LocSimple (DW_OP_bregx (a,hi))),[] + 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_value = Int64.to_int (e.enumerator_const); + enumerator_name = string_entry 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 = file_loc_opt e.enum_file_loc; + enumeration_byte_size = bs; + enumeration_declaration = Some false; + enumeration_name = string_entry 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_artificial = None; + } in + [new_entry (next_id ()) (DW_TAG_unspecified_parameter u)] else - let op_hi = [DW_OP_bregx (a,hi)] - and op_lo = [DW_OP_bregx (a,lo)] in - Some (LocList (gen_splitlong op_hi op_lo)),[] - | _ -> None,[] - -let range_entry_loc (sp,l) = - let rec aux = function - | BA i -> [DW_OP_reg i] - | BA_addrstack ofs -> - let ofs = camlint_of_coqint ofs in - [DW_OP_bregx (sp,ofs)] - | BA_splitlong (hi,lo) -> - let hi = aux hi - and lo = aux lo in - gen_splitlong hi lo - | _ -> assert false in - match aux l with - | [] -> assert false - | [a] -> LocSimple a - | a::rest -> LocList (a::rest) - -let location_entry f_id atom = - try - begin - match (Hashtbl.find var_locations (f_id,atom)) with - | FunctionLoc (a,r) -> - translate_function_loc a r - | RangeLoc l -> - let l = List.rev_map (fun i -> - let hi = get_opt_val i.range_start - and lo = get_opt_val i.range_end in - let hi = Hashtbl.find label_translation (f_id,hi) - and lo = Hashtbl.find label_translation (f_id,lo) in - hi,lo,range_entry_loc i.var_loc) l in - let id = next_id () in - Some (LocRef id),[{loc = l;loc_id = id;}] - end - with Not_found -> None,[] - -let function_parameter_to_entry f_id (acc,bcc) p = - let loc,loc_list = location_entry f_id (get_opt_val p.parameter_atom) in - let p = { - formal_parameter_file_loc = None; - formal_parameter_artificial = None; - formal_parameter_name = Some p.parameter_name; - formal_parameter_type = p.parameter_type; - formal_parameter_variable_parameter = None; - formal_parameter_location = loc; - } in - new_entry (next_id ()) (DW_TAG_formal_parameter p),(IntSet.add p.formal_parameter_type acc,loc_list@bcc) - -let rec local_variable_to_entry file f_id (acc,bcc) v id = - match v.lvar_atom with - | None -> None,(acc,bcc) - | Some loc -> - let loc,loc_list = location_entry f_id loc in + List.map (fun p -> + let fp = { + formal_parameter_artificial = None; + formal_parameter_name = name_opt p.param_name; + formal_parameter_type = p.param_type; + formal_parameter_variable_parameter = None; + formal_parameter_location = None; + } in + new_entry (next_id ()) (DW_TAG_formal_parameter fp)) f.fun_params; + in + 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_byte_size = mem.cfd_byte_size; + member_bit_offset = mem.cfd_bit_offset; + member_bit_size = mem.cfd_bit_size; + member_data_member_location = + (match mem.cfd_byte_offset with + | None -> None + | Some s -> Some (DataLocBlock (DW_OP_plus_uconst s))); + member_declaration = None; + member_name = string_entry 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 = file_loc_opt s.ct_file_loc; + structure_byte_size = s.ct_sizeof; + structure_declaration = if s.ct_declaration then Some s.ct_declaration else None; + structure_name = name_opt s.ct_name; + } 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 = file_loc_opt s.ct_file_loc; + union_byte_size = s.ct_sizeof; + union_declaration = if s.ct_declaration then Some s.ct_declaration else None; + union_name = name_opt s.ct_name; + } 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 needs_types id d = + let add_type id d = + if not (IntSet.mem id d) then + IntSet.add id d,true + else + d,false in + let t = Hashtbl.find types id in + match t with + | IntegerType _ + | FloatType _ + | Void + | EnumType _ -> d,false + | Typedef t -> + add_type (get_opt_val t.typ) d + | PointerType p -> + add_type p.pts d + | ArrayType arr -> + add_type arr.arr_type d + | ConstType c -> + add_type c.cst_type d + | VolatileType v -> + add_type v.vol_type d + | FunctionType f -> + let d,c = match f.fun_return_type with + | Some t -> add_type t d + | None -> d,false in + List.fold_left (fun (d,c) p -> + let d,c' = add_type p.param_type d in + d,c||c') (d,c) f.fun_params + | CompositeType c -> + List.fold_left (fun (d,c) f -> + let d,c' = add_type f.cfd_typ d in + d,c||c') (d,false) c.ct_members + + let gen_types needed = + let rec aux d = + let d,c = IntSet.fold (fun id (d,c) -> + let d,c' = needs_types id d in + d,c||c') d (d,false) in + if c then + aux d + else + d in + let typs = aux needed in + List.rev (Hashtbl.fold (fun id t acc -> + if IntSet.mem id typs then + (infotype_to_entry id t)::acc + else + acc) types []) + + let global_variable_to_entry acc id v = + let loc = match v.gvar_atom with + | Some a when StringSet.mem (extern_atom a) !printed_vars -> + Some (LocSymbol a) + | _ -> None in let var = { - variable_file_loc = file v.lvar_file_loc; - variable_declaration = None; - variable_external = None; - variable_name = v.lvar_name; - variable_type = v.lvar_type; + variable_file_loc = file_loc v.gvar_file_loc; + variable_declaration = Some v.gvar_declaration; + variable_external = Some v.gvar_external; + variable_name = string_entry v.gvar_name; + variable_type = v.gvar_type; variable_location = loc; } in - Some (new_entry id (DW_TAG_variable var)),(IntSet.add v.lvar_type acc,loc_list@bcc) - -and scope_to_entry file f_id acc sc id = - let l_pc,h_pc = try - let r = Hashtbl.find scope_ranges id in - let lbl l = match l with - | Some l -> Some (Hashtbl.find label_translation (f_id,l)) - | None -> None in - begin - match r with - | [] -> None,None - | [a] -> lbl a.start_addr, lbl a.end_addr - | a::rest -> lbl (List.hd (List.rev rest)).start_addr,lbl a.end_addr - end - with Not_found -> None,None in - let scope = { - lexical_block_high_pc = h_pc; - lexical_block_low_pc = l_pc; - } in - let vars,acc = mmap_opt (local_to_entry file f_id) acc sc.scope_variables in - let entry = new_entry id (DW_TAG_lexical_block scope) in - add_children entry vars,acc - -and local_to_entry file f_id acc id = - match Hashtbl.find local_variables id with - | LocalVariable v -> local_variable_to_entry file f_id acc v id - | Scope v -> let s,acc = - (scope_to_entry file f_id acc v id) in - Some s,acc - -let fun_scope_to_entries file f_id acc id = - match id with - | None -> [],acc - | Some id -> - let sc = Hashtbl.find local_variables id in - (match sc with - | Scope sc ->mmap_opt (local_to_entry file f_id) acc sc.scope_variables - | _ -> assert false) - -let function_to_entry file (acc,bcc) id f = - let f_tag = { - subprogram_file_loc = file 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_id = get_opt_val f.fun_atom in - let acc = match f.fun_return_type with Some s -> IntSet.add s acc | None -> acc in - let f_entry = new_entry id (DW_TAG_subprogram f_tag) in - let params,(acc,bcc) = mmap (function_parameter_to_entry f_id) (acc,bcc) f.fun_parameter in - let vars,(acc,bcc) = fun_scope_to_entries file f_id (acc,bcc) f.fun_scope in - add_children f_entry (params@vars),(acc,bcc) - -let definition_to_entry file (acc,bcc) id t = - match t with - | GlobalVariable g -> let e,acc = global_variable_to_entry file acc id g in - e,(acc,bcc) - | Function f -> function_to_entry file (acc,bcc) id f + let acc = acc =<< v.gvar_type in + new_entry id (DW_TAG_variable var),acc + + let gen_splitlong op_hi op_lo = + let op_piece = DW_OP_piece 4 in + op_piece::op_hi@(op_piece::op_lo) + + let translate_function_loc a = function + | BA_addrstack (ofs) -> + let ofs = camlint_of_coqint ofs in + Some (LocSimple (DW_OP_bregx (a,ofs))),[] + | BA_splitlong (BA_addrstack hi,BA_addrstack lo)-> + let hi = camlint_of_coqint hi + and lo = camlint_of_coqint lo in + if lo = Int32.add hi 4l then + Some (LocSimple (DW_OP_bregx (a,hi))),[] + else + let op_hi = [DW_OP_bregx (a,hi)] + and op_lo = [DW_OP_bregx (a,lo)] in + Some (LocList (gen_splitlong op_hi op_lo)),[] + | _ -> None,[] + + let range_entry_loc (sp,l) = + let rec aux = function + | BA i -> [DW_OP_reg i] + | BA_addrstack ofs -> + let ofs = camlint_of_coqint ofs in + [DW_OP_bregx (sp,ofs)] + | BA_splitlong (hi,lo) -> + let hi = aux hi + and lo = aux lo in + gen_splitlong hi lo + | _ -> assert false in + match aux l with + | [] -> assert false + | [a] -> LocSimple a + | a::rest -> LocList (a::rest) + + let location_entry f_id atom = + try + begin + match (Hashtbl.find var_locations (f_id,atom)) with + | FunctionLoc (a,r) -> + translate_function_loc a r + | RangeLoc l -> + let l = List.rev_map (fun i -> + let hi = get_opt_val i.range_start + and lo = get_opt_val i.range_end in + let hi = Hashtbl.find label_translation (f_id,hi) + and lo = Hashtbl.find label_translation (f_id,lo) in + hi,lo,range_entry_loc i.var_loc) l in + let id = next_id () in + Some (LocRef id),[{loc = l;loc_id = id;}] + end + with Not_found -> None,[] + + let function_parameter_to_entry f_id acc p = + let loc,loc_list = location_entry f_id (get_opt_val p.parameter_atom) in + let p = { + formal_parameter_artificial = None; + formal_parameter_name = name_opt p.parameter_name; + formal_parameter_type = p.parameter_type; + formal_parameter_variable_parameter = None; + formal_parameter_location = loc; + } in + let acc = (acc =<< p.formal_parameter_type) <=< loc_list in + new_entry (next_id ()) (DW_TAG_formal_parameter p),acc + + let scope_range f_id id (o,dwr) = + try + let r = Hashtbl.find scope_ranges id in + let lbl l h = match l,h with + | Some l,Some h-> + let l = (Hashtbl.find label_translation (f_id,l)) + and h = (Hashtbl.find label_translation (f_id,h)) in + l,h + | _ -> raise Not_found in + begin + match r with + | [] -> Empty,(o,dwr) + | [a] -> + let l,h = lbl a.start_addr a.end_addr in + Pc_pair (l,h),(o,dwr) + | a::rest -> + if !Clflags.option_gdwarf > 2 then + let r = List.map (fun e -> lbl e.start_addr e.end_addr) r in + (Offset o), (o + 2 + 4 * (List.length r),r::dwr) + else + let l,h = lbl (List.hd (List.rev rest)).start_addr a.end_addr in + Pc_pair (l,h),(o,dwr) + end + with Not_found -> Empty,(o,dwr) + + let rec local_variable_to_entry f_id acc v id = + match v.lvar_atom with + | None -> None,acc + | Some loc -> + let loc,loc_list = location_entry f_id loc in + let var = { + variable_file_loc = file_loc v.lvar_file_loc; + variable_declaration = None; + variable_external = None; + variable_name = string_entry v.lvar_name; + variable_type = v.lvar_type; + variable_location = loc; + } in + let acc = (acc =<< v.lvar_type) <=< loc_list in + Some (new_entry id (DW_TAG_variable var)),acc + + and scope_to_entry f_id acc sc id = + let r,dwr = scope_range f_id id acc.ranges in + let scope = { + lexical_block_range = r; + } in + let vars,acc = mmap_opt (local_to_entry f_id) acc sc.scope_variables in + let entry = new_entry id (DW_TAG_lexical_block scope) in + add_children entry vars,(acc >>= dwr) + + and local_to_entry f_id acc id = + match Hashtbl.find local_variables id with + | LocalVariable v -> local_variable_to_entry f_id acc v id + | Scope v -> let s,acc = (scope_to_entry f_id acc v id) in + Some s,acc + + let fun_scope_to_entries f_id acc id = + match id with + | None -> [],acc + | Some id -> + let sc = Hashtbl.find local_variables id in + (match sc with + | Scope sc -> mmap_opt (local_to_entry f_id) acc sc.scope_variables + | _ -> assert false) + + let function_to_entry acc id f = + let r = match f.fun_low_pc, f.fun_high_pc with + | Some l,Some h -> Pc_pair (l,h) + | _ -> Empty in + let f_tag = { + subprogram_file_loc = file_loc f.fun_file_loc; + subprogram_external = Some f.fun_external; + subprogram_name = string_entry f.fun_name; + subprogram_prototyped = true; + subprogram_type = f.fun_return_type; + subprogram_range = r; + } in + let f_id = get_opt_val f.fun_atom in + let acc = match f.fun_return_type with Some s -> acc =<< s | None -> acc in + let f_entry = new_entry id (DW_TAG_subprogram f_tag) in + let params,acc = mmap (function_parameter_to_entry f_id) acc f.fun_parameter in + let vars,acc = fun_scope_to_entries f_id acc f.fun_scope in + add_children f_entry (params@vars),acc + + let definition_to_entry acc id t = + match t with + | GlobalVariable g -> global_variable_to_entry acc id g + | Function f -> function_to_entry acc id f + + end module StringMap = Map.Make(String) let diab_file_loc sec (f,l) = Diab_file_loc (Hashtbl.find filenum (sec,f),l) +let prod_name = + let version_string = + if Version.buildnr <> "" && Version.tag <> "" then + Printf.sprintf "%s, Build: %s, Tag: %s" Version.version Version.buildnr Version.tag + else + Version.version in + Printf.sprintf "AbsInt Angewandte Informatik GmbH:CompCert Version %s:(%s,%s,%s,%s)" + version_string Configuration.arch Configuration.system Configuration.abi Configuration.model + +let diab_gen_compilation_section s defs acc = + let module Gen = Dwarfgenaux(struct + let file_loc = diab_file_loc s + let string_entry s = Simple_string s + end) in + let defs,accu = List.fold_left (fun (acc,bcc) (id,t) -> + let t,bcc = Gen.definition_to_entry bcc id t in + t::acc,bcc) ([],empty_accu) defs in + let low_pc = Hashtbl.find compilation_section_start s + and line_start,debug_start,_ = Hashtbl.find diab_additional s + and high_pc = Hashtbl.find compilation_section_end s in + let cp = { + compile_unit_name = Simple_string !file_name; + compile_unit_range = Pc_pair (low_pc,high_pc); + compile_unit_dir = Simple_string (Sys.getcwd ()); + compile_unit_prod_name = Simple_string prod_name + } in + let cp = new_entry (next_id ()) (DW_TAG_compile_unit cp) in + let cp = add_children cp ((Gen.gen_types accu.typs) @ defs) in + { + section_name = s; + start_label = debug_start; + line_label = line_start; + entry = cp; + locs = Some low_pc,accu.locs; + }::acc + let gen_diab_debug_info sec_name var_section : debug_entries = let defs = Hashtbl.fold (fun id t acc -> let s = match t with @@ -449,38 +534,60 @@ let gen_diab_debug_info sec_name var_section : debug_entries = | Function f -> sec_name (get_opt_val f.fun_atom) in let old = try StringMap.find s acc with Not_found -> [] in StringMap.add s ((id,t)::old) acc) definitions StringMap.empty in - let entries = StringMap.fold (fun s defs acc -> - let defs,(ty,locs) = List.fold_left (fun (acc,bcc) (id,t) -> - let t,bcc = definition_to_entry (diab_file_loc s) bcc id t in - t::acc,bcc) ([],(IntSet.empty,[])) defs in - let low_pc = Hashtbl.find compilation_section_start s - and line_start,debug_start,_ = Hashtbl.find diab_additional s - and high_pc = Hashtbl.find compilation_section_end s in - let cp = { - compile_unit_name = !file_name; - compile_unit_low_pc = low_pc; - compile_unit_high_pc = high_pc; - } in - let cp = new_entry (next_id ()) (DW_TAG_compile_unit cp) in - let cp = add_children cp ((gen_types (diab_file_loc s) ty) @ defs) in - (s,debug_start,line_start,cp,(low_pc,locs))::acc) defs [] in + let entries = StringMap.fold diab_gen_compilation_section defs [] in Diab entries let gnu_file_loc (f,l) = - Gnu_file_loc ((fst (Hashtbl.find Fileinfo.filename_info f),l)) + Gnu_file_loc ((fst (Hashtbl.find Fileinfo.filename_info f),l)) + +let string_table: (string,int) Hashtbl.t = Hashtbl.create 7 + +let gnu_string_entry s = + if String.length s < 4 || Configuration.system = "cygwin" then (*Cygwin does not use the debug_str seciton *) + Simple_string s + else + try + Offset_string (Hashtbl.find string_table s) + with Not_found -> + let id = next_id () in + Hashtbl.add string_table s id; + Offset_string id + let gen_gnu_debug_info sec_name var_section : debug_entries = - let low_pc = Hashtbl.find compilation_section_start ".text" - and high_pc = Hashtbl.find compilation_section_end ".text" in - let defs,(ty,locs) = Hashtbl.fold (fun id t (acc,bcc) -> - let t,bcc = definition_to_entry gnu_file_loc bcc id t in - t::acc,bcc) definitions ([],(IntSet.empty,[])) in - let types = gen_types gnu_file_loc ty in + let r,dwr,low_pc = + try if !Clflags.option_gdwarf > 3 then + let pcs = Hashtbl.fold (fun s low acc -> + (low,Hashtbl.find compilation_section_end s)::acc) compilation_section_start [] in + match pcs with + | [] -> Empty,(0,[]),None + | [(l,h)] -> Pc_pair (l,h),(0,[]),Some l + | _ -> Offset 0,(2 + 4 * (List.length pcs),[pcs]),None + else + let l = Hashtbl.find compilation_section_start ".text" + and h = Hashtbl.find compilation_section_end ".text" in + Pc_pair(l,h),(0,[]),Some l + with Not_found -> Empty,(0,[]),None in + let accu = empty_accu >>= dwr in + let module Gen = Dwarfgenaux (struct + let file_loc = gnu_file_loc + let string_entry = gnu_string_entry + end) in + let defs,accu,sec = Hashtbl.fold (fun id t (acc,bcc,sec) -> + let s = match t with + | GlobalVariable _ -> var_section + | Function f -> sec_name (get_opt_val f.fun_atom) in + let t,bcc = Gen.definition_to_entry bcc id t in + t::acc,bcc,StringSet.add s sec) definitions ([],accu,StringSet.empty) in + let types = Gen.gen_types accu.typs in let cp = { - compile_unit_name = !file_name; - compile_unit_low_pc = low_pc; - compile_unit_high_pc = high_pc; + compile_unit_name = gnu_string_entry !file_name; + compile_unit_range = r; + compile_unit_dir = gnu_string_entry (Sys.getcwd ()); + compile_unit_prod_name = gnu_string_entry prod_name; } in let cp = new_entry (next_id ()) (DW_TAG_compile_unit cp) in let cp = add_children cp (types@defs) in - Gnu (cp,(low_pc,locs)) + let loc_pc = if StringSet.cardinal sec > 1 then None else low_pc in + let string_table = Hashtbl.fold (fun s i acc -> (i,s)::acc) string_table [] in + Gnu (cp,(loc_pc,accu.locs),string_table,snd accu.ranges) |