1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
|
(* *********************************************************************)
(* *)
(* The Compcert verified compiler *)
(* *)
(* Bernhard Schommer, AbsInt Angewandte Informatik GmbH *)
(* *)
(* AbsInt Angewandte Informatik GmbH. All rights reserved. This file *)
(* is distributed under the terms of the INRIA Non-Commercial *)
(* License Agreement. *)
(* *)
(* *********************************************************************)
open C
open Cprint
open DwarfTypes
open DwarfUtil
open Machine
(* Functions to translate a C Ast into Dwarf 2 debugging information *)
(* Hashtable from type name to entry id *)
let type_table: (string, int) Hashtbl.t = Hashtbl.create 7
(* Hashtable from typedefname to entry id *)
let defined_types_table: (string, int) Hashtbl.t = Hashtbl.create 7
let typ_to_string (ty: typ) =
let buf = Buffer.create 7 in
let chan = Format.formatter_of_buffer buf in
typ chan ty;
Format.pp_print_flush chan ();
Buffer.contents buf
let rec mmap f env = function
| [] -> ([],env)
| hd :: tl ->
let (hd',env1) = f env hd in
let (tl', env2) = mmap f env1 tl in
(hd' :: tl', env2)
let rec type_to_dwarf (typ: typ): int * dw_entry list =
let typ_string = typ_to_string typ in
try
Hashtbl.find type_table typ_string,[]
with Not_found ->
let attr_to_dw attr_list id entries =
List.fold_left (fun (id,entry) attr ->
match attr with
| AConst -> let const_tag = DW_TAG_const_type ({const_type = id;}) in
let const_entry = new_entry const_tag in
const_entry.id,const_entry::entry
| AVolatile -> let volatile_tag = DW_TAG_volatile_type ({volatile_type = id;}) in
let volatile_entry = new_entry volatile_tag in
volatile_entry.id,volatile_entry::entry
| ARestrict
| AAlignas _
| Attr _ -> id,entry) (id,entries) (List.rev attr_list) in
let attr_to_dw_tag attr_list tag =
let entry = new_entry tag in
attr_to_dw attr_list entry.id [entry] in
let id,entries =
match typ with
| TVoid at -> let void = {
base_type_byte_size = 0;
base_type_encoding = None;
base_type_name = "void";
} in
attr_to_dw_tag at (DW_TAG_base_type void)
| TInt (k,at) ->
let byte_size,encoding,name =
(match k with
| IBool -> 1,DW_ATE_boolean,"_Bool"
| IChar -> 1,(if !config.char_signed then DW_ATE_signed_char else DW_ATE_unsigned_char),"char"
| ISChar -> 1,DW_ATE_signed_char,"signed char"
| IUChar -> 1,DW_ATE_unsigned_char,"unsigned char"
| IInt -> !config.sizeof_int,DW_ATE_signed,"signed int"
| IUInt -> !config.sizeof_int,DW_ATE_unsigned,"unsigned int"
| IShort -> !config.sizeof_short,DW_ATE_signed,"signed short"
| IUShort -> !config.sizeof_short,DW_ATE_unsigned,"unsigned short"
| ILong -> !config.sizeof_long, DW_ATE_signed,"long"
| IULong -> !config.sizeof_long, DW_ATE_unsigned,"unsigned long"
| ILongLong -> !config.sizeof_longlong, DW_ATE_signed,"long long"
| IULongLong -> !config.sizeof_longlong, DW_ATE_unsigned,"unsigned long long")in
let int = {
base_type_byte_size = byte_size;
base_type_encoding = Some encoding;
base_type_name = name;} in
attr_to_dw_tag at (DW_TAG_base_type int)
| TFloat (k,at) ->
let byte_size,name =
(match k with
| FFloat -> !config.sizeof_float,"float"
| FDouble -> !config.sizeof_double,"double"
| FLongDouble -> !config.sizeof_longdouble,"long double") in
let float = {
base_type_byte_size = byte_size;
base_type_encoding = Some DW_ATE_float;
base_type_name = name;
} in
attr_to_dw_tag at (DW_TAG_base_type float)
| TPtr (t,at) ->
let t,e = type_to_dwarf t in
let pointer = {pointer_type = t;} in
let t,e2 = attr_to_dw_tag at (DW_TAG_pointer_type pointer) in
t,e2@e
| TFun (rt,args,_,at) ->
let ret,et = (match rt with
| TVoid _ -> None,[] (* Void return *)
| _ -> let ret,et = type_to_dwarf rt in
Some ret,et) in
let prototyped,children,others =
(match args with
| None ->
let u = {
unspecified_parameter_file_loc = None;
unspecified_parameter_artificial = None;
} in
let u = new_entry (DW_TAG_unspecified_parameter u) in
false,[u],[]
| Some [] -> true,[],[]
| Some l ->
let c,e = mmap (fun acc (_,t) ->
let t,e = type_to_dwarf t in
let fp =
{
formal_parameter_file_loc = None;
formal_parameter_artificial = None;
formal_parameter_location = None;
formal_parameter_name = None;
formal_parameter_segment = None;
formal_parameter_type = t;
formal_parameter_variable_parameter = None;
} in
let entry = new_entry (DW_TAG_formal_parameter fp) in
entry,(e@acc)) [] l in
true,c,e) in
let s = {
subroutine_type = ret;
subroutine_prototyped = prototyped;
} in
let s = new_entry (DW_TAG_subroutine_type s) in
let s = add_children s children in
attr_to_dw at s.id ((s::others)@et)
| TStruct (i,at)
| TUnion (i,at)
| TEnum (i,at)
| TNamed (i,at) ->
let t = Hashtbl.find defined_types_table i.name in
attr_to_dw at t []
| TArray (child,size,at) ->
let size_to_subrange s =
let b = (match s with
| None -> None
| Some i ->
let i = Int64.to_int i in
Some (BoundConst i)) in
let s = {
subrange_type = None;
subrange_upper_bound = b;
} in
new_entry (DW_TAG_subrange_type s) in
let rec aux t =
(match t with
| TArray (child,size,_) ->
let sub = size_to_subrange size in
let t,c,e = aux child in
t,sub::c,e
| _ -> let t,e = type_to_dwarf t in
t,[],e) in
let t,children,e = aux child in
let sub = size_to_subrange size in
let children = List.rev (sub::children) in
let arr = {
array_type_file_loc = None;
array_type = t;
} in
let arr = new_entry (DW_TAG_array_type arr) in
let arr = add_children arr children in
attr_to_dw at arr.id (arr::e)
in
Hashtbl.add type_table typ_string id;
id,entries
|
