First version with computation of dwarf info from debug info.

Introduced a new dwarf generation from the information collected in
the DebugInformation and removed the old CtODwarf translation.

1 files changed, 247 insertions, 0 deletions

diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml
new file mode 100644
index 00000000..0acab05a
--- /dev/null
+++ b/debug/Dwarfgen.ml
@@ -0,0 +1,247 @@
+(* *********************************************************************)
+(*                                                                     *)
+(*              The Compcert verified compiler                         *)
+(*                                                                     *)
+(*          Bernhard Schommer, AbsInt Angewandte Informatik GmbH       *)
+(*                                                                     *)
+(*  AbsInt Angewandte Informatik GmbH. All rights reserved. This file  *)
+(*  is distributed under the terms of the INRIA Non-Commercial         *)
+(*  License Agreement.                                                 *)
+(*                                                                     *)
+(* *********************************************************************)
+
+open C
+open Cutil
+open DebugInformation
+open DwarfTypes
+open DwarfUtil
+(* Generate the dwarf DIE's from the information collected in DebugInformation *)
+
+(* Helper function to get values that must be set. *)
+let get_opt_val = function
+  | Some a -> a
+  | None -> assert false
+
+(* Functions to translate the basetypes. *)
+let int_type_to_entry id i =
+   let encoding =
+    (match i.int_kind with
+    | IBool -> DW_ATE_boolean
+    | IChar ->
+        if !Machine.config.Machine.char_signed then 
+          DW_ATE_signed_char 
+        else 
+          DW_ATE_unsigned_char
+    | IInt | ILong | ILongLong | IShort | ISChar -> DW_ATE_signed
+    | _ -> DW_ATE_unsigned)in
+  let int = {
+    base_type_byte_size = sizeof_ikind i.int_kind;
+    base_type_encoding = Some encoding;
+    base_type_name = typ_to_string (TInt (i.int_kind,[]));} in
+  new_entry id (DW_TAG_base_type int)
+
+let float_type_to_entry id f = 
+  let byte_size = sizeof_fkind f.float_kind in
+  let float = {
+    base_type_byte_size = byte_size;
+    base_type_encoding = Some DW_ATE_float;
+    base_type_name = typ_to_string (TFloat (f.float_kind,[]));
+  } in
+  new_entry id (DW_TAG_base_type float)
+
+let void_to_entry id =
+  let void = {
+    base_type_byte_size = 0;
+    base_type_encoding = None;
+    base_type_name = "void";
+  } in
+  new_entry id (DW_TAG_base_type void)
+
+let typedef_to_entry id t =
+  let i = get_opt_val t.typ in
+  let td = {
+    typedef_file_loc = t.typedef_file_loc;
+    typedef_name = t.typedef_name;
+    typedef_type = i;
+  } in
+  new_entry id (DW_TAG_typedef td) 
+
+let pointer_to_entry id p =
+  let p = {pointer_type = p.pts} in
+  new_entry id (DW_TAG_pointer_type p)
+
+let array_to_entry id arr =
+  let arr_tag = {
+    array_type_file_loc = None;
+    array_type = arr.arr_type;
+  } in
+  let arr_entry = new_entry id (DW_TAG_array_type arr_tag) in
+  let children = List.map (fun a ->
+    let r = match a with
+    | None -> None
+    | Some i ->
+        let bound = Int64.to_int (Int64.sub i Int64.one) in
+        Some (BoundConst bound) in
+    let s = {
+       subrange_type = None;
+       subrange_upper_bound = r;
+    } in
+    new_entry (next_id ()) (DW_TAG_subrange_type s)) arr.arr_size in
+  add_children arr_entry children
+
+let const_to_entry id c =
+  new_entry id (DW_TAG_const_type ({const_type = c.cst_type}))
+
+let volatile_to_entry id v =
+  new_entry id (DW_TAG_volatile_type ({volatile_type = v.vol_type}))
+
+let enum_to_entry id e =
+  let enumerator_to_entry e =
+    let tag =
+      {
+       enumerator_file_loc = None;
+       enumerator_value = Int64.to_int (e.enumerator_const);
+       enumerator_name = e.enumerator_name;
+     } in
+    new_entry (next_id ()) (DW_TAG_enumerator tag) in
+  let bs = sizeof_ikind enum_ikind in
+  let enum = {
+    enumeration_file_loc = e.enum_file_loc;
+    enumeration_byte_size = bs;
+    enumeration_declaration = Some false;
+    enumeration_name = Some e.enum_name;
+  } in
+  let enum = new_entry id (DW_TAG_enumeration_type enum) in
+  let child = List.map enumerator_to_entry e.enum_enumerators in
+  add_children enum child
+
+let fun_type_to_entry id f =
+  let children = if f.fun_prototyped then
+    let u = {
+      unspecified_parameter_file_loc = None;
+      unspecified_parameter_artificial = None;
+    } in
+    [new_entry (next_id ()) (DW_TAG_unspecified_parameter u)]
+  else
+    List.map (fun p ->
+      let fp = {
+        formal_parameter_file_loc = None;
+        formal_parameter_artificial = None;
+        formal_parameter_name = if p.param_name <> "" then Some p.param_name else None;
+        formal_parameter_type = p.param_type;
+        formal_parameter_variable_parameter = None;
+      } in
+      new_entry (next_id ()) (DW_TAG_formal_parameter fp)) f.fun_params;
+  in
+  let s = {
+    subroutine_type = f.fun_return_type;
+    subroutine_prototyped = f.fun_prototyped
+  } in
+  let s = new_entry id (DW_TAG_subroutine_type s) in
+  add_children s children
+
+let member_to_entry mem =
+  let mem = {
+    member_file_loc = None;
+    member_byte_size = mem.cfd_byte_size;
+    member_bit_offset = mem.cfd_bit_offset;
+    member_bit_size = mem.cfd_bit_size;
+    member_data_member_location = Some (DataLocBlock [DW_OP_plus_uconst (get_opt_val mem.cfd_byte_offset)]);
+    member_declaration = None;
+    member_name = Some (mem.cfd_name);
+    member_type = mem.cfd_typ;
+  } in
+  new_entry (next_id ()) (DW_TAG_member mem)
+
+let struct_to_entry id s =
+  let tag = {
+     structure_file_loc = s.ct_file_loc;
+     structure_byte_size = s.ct_sizeof;
+     structure_declaration = Some s.ct_declaration;
+     structure_name = if s.ct_name <> "" then Some s.ct_name else None;
+  } in
+  let entry = new_entry id (DW_TAG_structure_type tag) in
+  let child = List.map member_to_entry s.ct_members in
+  add_children entry child
+
+let union_to_entry id s =
+  let tag = {
+    union_file_loc = s.ct_file_loc;
+    union_byte_size = s.ct_sizeof;
+    union_declaration = Some s.ct_declaration;
+    union_name = if s.ct_name <> "" then Some s.ct_name else None;
+  } in
+  let entry = new_entry id (DW_TAG_union_type tag) in
+  let child = List.map member_to_entry s.ct_members in
+  add_children entry child
+
+let composite_to_entry id s =
+  match s.ct_sou with
+  | Struct -> struct_to_entry id s
+  | Union -> union_to_entry id s
+
+let infotype_to_entry id = function
+  | IntegerType i -> int_type_to_entry id i
+  | FloatType f -> float_type_to_entry id f
+  | PointerType p -> pointer_to_entry id p
+  | ArrayType arr -> array_to_entry id arr
+  | CompositeType c -> composite_to_entry id c
+  | EnumType e -> enum_to_entry id e
+  | FunctionType f -> fun_type_to_entry id f
+  | Typedef t -> typedef_to_entry id t
+  | ConstType c -> const_to_entry id c
+  | VolatileType v -> volatile_to_entry id v
+  | Void -> void_to_entry id
+
+let gen_types () =
+  List.rev (Hashtbl.fold (fun id t acc -> (infotype_to_entry id t)::acc) types [])
+
+let global_variable_to_entry id v =
+  let var = {
+    variable_file_loc = v.gvar_file_loc;
+    variable_declaration = Some v.gvar_declaration;
+    variable_external = Some v.gvar_external;
+    variable_name = v.gvar_name;
+    variable_type = v.gvar_type;
+    variable_location = match v.gvar_atom with Some a -> Some (LocSymbol a) | None -> None;
+  } in
+  new_entry id (DW_TAG_variable var)
+
+let function_parameter_to_entry p =
+  let p = {
+    formal_parameter_file_loc = None;
+    formal_parameter_artificial = None;
+    formal_parameter_name = Some p.parameter_name;
+    formal_parameter_type = p.parameter_type;
+    formal_parameter_variable_parameter = None;
+  } in
+  new_entry (next_id ()) (DW_TAG_formal_parameter p)
+
+let function_to_entry id f =
+  let f_tag = {
+    subprogram_file_loc = f.fun_file_loc;
+    subprogram_external = Some f.fun_external;
+    subprogram_name = f.fun_name;
+    subprogram_prototyped = true;
+    subprogram_type = f.fun_return_type;
+    subprogram_high_pc = f.fun_high_pc;
+    subprogram_low_pc = f.fun_low_pc;
+  } in
+ let f_entry =  new_entry id (DW_TAG_subprogram f_tag) in
+ let child = List.map function_parameter_to_entry f.fun_parameter in
+ add_children f_entry child
+     
+let definition_to_entry id t =
+  match t with
+  | GlobalVariable g -> global_variable_to_entry id g
+  | Function f -> function_to_entry id f
+
+let gen_defs () =
+  List.rev (Hashtbl.fold (fun id t acc -> (definition_to_entry id t)::acc) definitions [])
+
+let gen_debug_info () =
+  let cp =  {
+    compile_unit_name = !file_name;
+  } in
+  let cp = new_entry (next_id ()) (DW_TAG_compile_unit cp) in
+  add_children cp ((gen_types ()) @ (gen_defs ()))