]>
Commit | Line | Data |
---|---|---|
3666a048 | 1 | # Copyright 2010-2021 Free Software Foundation, Inc. |
810cfdbb YQ |
2 | |
3 | # This program is free software; you can redistribute it and/or modify | |
4 | # it under the terms of the GNU General Public License as published by | |
5 | # the Free Software Foundation; either version 3 of the License, or | |
6 | # (at your option) any later version. | |
7 | # | |
8 | # This program is distributed in the hope that it will be useful, | |
9 | # but WITHOUT ANY WARRANTY; without even the implied warranty of | |
10 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
11 | # GNU General Public License for more details. | |
12 | # | |
13 | # You should have received a copy of the GNU General Public License | |
14 | # along with this program. If not, see <http://www.gnu.org/licenses/>. | |
15 | ||
16 | # Return true if the target supports DWARF-2 and uses gas. | |
17 | # For now pick a sampling of likely targets. | |
18 | proc dwarf2_support {} { | |
ec64c9aa YQ |
19 | if {[istarget *-*-linux*] |
20 | || [istarget *-*-gnu*] | |
21 | || [istarget *-*-elf*] | |
22 | || [istarget *-*-openbsd*] | |
23 | || [istarget arm*-*-eabi*] | |
24 | || [istarget arm*-*-symbianelf*] | |
25 | || [istarget powerpc-*-eabi*]} { | |
26 | return 1 | |
810cfdbb YQ |
27 | } |
28 | ||
ec64c9aa | 29 | return 0 |
810cfdbb | 30 | } |
1d24041a | 31 | |
6b4646ce DE |
32 | # Build an executable from a fission-based .S file. |
33 | # This handles the extra work of splitting the .o into non-dwo and dwo | |
34 | # pieces, making sure the .dwo is available if we're using cc-with-tweaks.sh | |
35 | # to build a .dwp file. | |
36 | # The arguments and results are the same as for build_executable. | |
37 | # | |
38 | # Current restrictions: | |
39 | # - only supports one source file | |
40 | # - cannot be run on remote hosts | |
41 | ||
42 | proc build_executable_from_fission_assembler { testname executable sources options } { | |
43 | verbose -log "build_executable_from_fission_assembler $testname $executable $sources $options" | |
44 | if { [llength $sources] != 1 } { | |
45 | error "Only one source file supported." | |
46 | } | |
47 | if [is_remote host] { | |
48 | error "Remote hosts are not supported." | |
49 | } | |
50 | ||
51 | global srcdir subdir | |
52 | set source_file ${srcdir}/${subdir}/${sources} | |
53 | set root_name [file rootname [file tail $source_file]] | |
54 | set output_base [standard_output_file $root_name] | |
55 | set object_file ${output_base}.o | |
56 | set dwo_file ${output_base}.dwo | |
57 | set object_options "object $options" | |
58 | set objcopy [gdb_find_objcopy] | |
59 | ||
60 | set result [gdb_compile $source_file $object_file object $options] | |
61 | if { "$result" != "" } { | |
62 | return -1 | |
63 | } | |
64 | ||
65 | set command "$objcopy --extract-dwo $object_file $dwo_file" | |
66 | verbose -log "Executing $command" | |
67 | set result [catch "exec $command" output] | |
68 | verbose -log "objcopy --extract-dwo output: $output" | |
69 | if { $result == 1 } { | |
70 | return -1 | |
71 | } | |
72 | ||
73 | set command "$objcopy --strip-dwo $object_file" | |
74 | verbose -log "Executing $command" | |
75 | set result [catch "exec $command" output] | |
76 | verbose -log "objcopy --strip-dwo output: $output" | |
77 | if { $result == 1 } { | |
78 | return -1 | |
79 | } | |
80 | ||
8ddd5a6c | 81 | set result [gdb_compile $object_file $executable executable $options] |
6b4646ce DE |
82 | if { "$result" != "" } { |
83 | return -1 | |
84 | } | |
85 | ||
86 | return 0 | |
87 | } | |
88 | ||
876c4df9 YQ |
89 | # Return a list of expressions about function FUNC's address and length. |
90 | # The first expression is the address of function FUNC, and the second | |
91 | # one is FUNC's length. SRC is the source file having function FUNC. | |
92 | # An internal label ${func}_label must be defined inside FUNC: | |
93 | # | |
94 | # int main (void) | |
95 | # { | |
96 | # asm ("main_label: .globl main_label"); | |
97 | # return 0; | |
98 | # } | |
99 | # | |
100 | # This label is needed to compute the start address of function FUNC. | |
101 | # If the compiler is gcc, we can do the following to get function start | |
102 | # and end address too: | |
103 | # | |
104 | # asm ("func_start: .globl func_start"); | |
105 | # static void func (void) {} | |
106 | # asm ("func_end: .globl func_end"); | |
107 | # | |
108 | # however, this isn't portable, because other compilers, such as clang, | |
109 | # may not guarantee the order of global asms and function. The code | |
110 | # becomes: | |
111 | # | |
112 | # asm ("func_start: .globl func_start"); | |
113 | # asm ("func_end: .globl func_end"); | |
114 | # static void func (void) {} | |
115 | # | |
116 | ||
6a354911 | 117 | proc function_range { func src {options {debug}} } { |
876c4df9 YQ |
118 | global decimal gdb_prompt |
119 | ||
120 | set exe [standard_temp_file func_addr[pid].x] | |
121 | ||
6a354911 | 122 | gdb_compile $src $exe executable $options |
876c4df9 YQ |
123 | |
124 | gdb_exit | |
125 | gdb_start | |
126 | gdb_load "$exe" | |
127 | ||
128 | # Compute the label offset, and we can get the function start address | |
129 | # by "${func}_label - $func_label_offset". | |
130 | set func_label_offset "" | |
131 | set test "p ${func}_label - ${func}" | |
132 | gdb_test_multiple $test $test { | |
133 | -re ".* = ($decimal)\r\n$gdb_prompt $" { | |
134 | set func_label_offset $expect_out(1,string) | |
135 | } | |
136 | } | |
137 | ||
138 | # Compute the function length. | |
139 | global hex | |
140 | set func_length "" | |
141 | set test "disassemble $func" | |
142 | gdb_test_multiple $test $test { | |
143 | -re ".*$hex <\\+($decimal)>:\[^\r\n\]+\r\nEnd of assembler dump\.\r\n$gdb_prompt $" { | |
144 | set func_length $expect_out(1,string) | |
145 | } | |
146 | } | |
147 | ||
148 | # Compute the size of the last instruction. | |
03eddd80 YQ |
149 | if { $func_length == 0 } then { |
150 | set func_pattern "$func" | |
151 | } else { | |
152 | set func_pattern "$func\\+$func_length" | |
153 | } | |
876c4df9 YQ |
154 | set test "x/2i $func+$func_length" |
155 | gdb_test_multiple $test $test { | |
03eddd80 | 156 | -re ".*($hex) <$func_pattern>:\[^\r\n\]+\r\n\[ \]+($hex).*\.\r\n$gdb_prompt $" { |
876c4df9 YQ |
157 | set start $expect_out(1,string) |
158 | set end $expect_out(2,string) | |
159 | ||
160 | set func_length [expr $func_length + $end - $start] | |
161 | } | |
162 | } | |
163 | ||
164 | return [list "${func}_label - $func_label_offset" $func_length] | |
165 | } | |
166 | ||
21b0982c AB |
167 | # Extract the start, length, and end for function called NAME and |
168 | # create suitable variables in the callers scope. | |
169 | proc get_func_info { name {options {debug}} } { | |
170 | global srcdir subdir srcfile | |
171 | ||
172 | upvar 1 "${name}_start" func_start | |
173 | upvar 1 "${name}_len" func_len | |
174 | upvar 1 "${name}_end" func_end | |
175 | ||
176 | lassign [function_range ${name} \ | |
177 | [list ${srcdir}/${subdir}/$srcfile] \ | |
178 | ${options}] \ | |
179 | func_start func_len | |
180 | set func_end "$func_start + $func_len" | |
181 | } | |
182 | ||
1d24041a TT |
183 | # A DWARF assembler. |
184 | # | |
185 | # All the variables in this namespace are private to the | |
186 | # implementation. Also, any procedure whose name starts with "_" is | |
187 | # private as well. Do not use these. | |
188 | # | |
189 | # Exported functions are documented at their definition. | |
190 | # | |
191 | # In addition to the hand-written functions documented below, this | |
192 | # module automatically generates a function for each DWARF tag. For | |
193 | # most tags, two forms are made: a full name, and one with the | |
194 | # "DW_TAG_" prefix stripped. For example, you can use either | |
195 | # 'DW_TAG_compile_unit' or 'compile_unit' interchangeably. | |
196 | # | |
197 | # There are two exceptions to this rule: DW_TAG_variable and | |
198 | # DW_TAG_namespace. For these, the full name must always be used, | |
199 | # as the short name conflicts with Tcl builtins. (Should future | |
200 | # versions of Tcl or DWARF add more conflicts, this list will grow. | |
201 | # If you want to be safe you should always use the full names.) | |
202 | # | |
203 | # Each tag procedure is defined like: | |
204 | # | |
205 | # proc DW_TAG_mumble {{attrs {}} {children {}}} { ... } | |
206 | # | |
207 | # ATTRS is an optional list of attributes. | |
208 | # It is run through 'subst' in the caller's context before processing. | |
209 | # | |
210 | # Each attribute in the list has one of two forms: | |
211 | # 1. { NAME VALUE } | |
212 | # 2. { NAME VALUE FORM } | |
213 | # | |
214 | # In each case, NAME is the attribute's name. | |
215 | # This can either be the full name, like 'DW_AT_name', or a shortened | |
216 | # name, like 'name'. These are fully equivalent. | |
217 | # | |
876c4df9 YQ |
218 | # Besides DWARF standard attributes, assembler supports 'macro' attribute |
219 | # which will be substituted by one or more standard or macro attributes. | |
220 | # supported macro attributes are: | |
221 | # | |
10da644d | 222 | # - MACRO_AT_range { FUNC } |
876c4df9 | 223 | # It is substituted by DW_AT_low_pc and DW_AT_high_pc with the start and |
10da644d | 224 | # end address of function FUNC in file $srcdir/$subdir/$srcfile. |
876c4df9 | 225 | # |
10da644d | 226 | # - MACRO_AT_func { FUNC } |
876c4df9 YQ |
227 | # It is substituted by DW_AT_name with FUNC and MACRO_AT_range. |
228 | # | |
1d24041a TT |
229 | # If FORM is given, it should name a DW_FORM_ constant. |
230 | # This can either be the short form, like 'DW_FORM_addr', or a | |
231 | # shortened version, like 'addr'. If the form is given, VALUE | |
232 | # is its value; see below. In some cases, additional processing | |
233 | # is done; for example, DW_FORM_strp manages the .debug_str | |
234 | # section automatically. | |
235 | # | |
236 | # If FORM is 'SPECIAL_expr', then VALUE is treated as a location | |
eab9267c MW |
237 | # expression. The effective form is then DW_FORM_block or DW_FORM_exprloc |
238 | # for DWARF version >= 4, and VALUE is passed to the (internal) | |
239 | # '_location' proc to be translated. | |
1d24041a TT |
240 | # This proc implements a miniature DW_OP_ assembler. |
241 | # | |
242 | # If FORM is not given, it is guessed: | |
243 | # * If VALUE starts with the "@" character, the rest of VALUE is | |
244 | # looked up as a DWARF constant, and DW_FORM_sdata is used. For | |
245 | # example, '@DW_LANG_c89' could be used. | |
246 | # * If VALUE starts with the ":" character, then it is a label | |
247 | # reference. The rest of VALUE is taken to be the name of a label, | |
248 | # and DW_FORM_ref4 is used. See 'new_label' and 'define_label'. | |
f13a9a0c YQ |
249 | # * If VALUE starts with the "%" character, then it is a label |
250 | # reference too, but DW_FORM_ref_addr is used. | |
7d72802b TV |
251 | # * Otherwise, if the attribute name has a default form (f.i. DW_FORM_addr for |
252 | # DW_AT_low_pc), then that one is used. | |
253 | # * Otherwise, an error is reported. Either specify a form explicitly, or | |
254 | # add a default for the the attribute name in _default_form. | |
1d24041a TT |
255 | # |
256 | # CHILDREN is just Tcl code that can be used to define child DIEs. It | |
257 | # is evaluated in the caller's context. | |
258 | # | |
259 | # Currently this code is missing nice support for CFA handling, and | |
260 | # probably other things as well. | |
261 | ||
262 | namespace eval Dwarf { | |
263 | # True if the module has been initialized. | |
264 | variable _initialized 0 | |
265 | ||
266 | # Constants from dwarf2.h. | |
267 | variable _constants | |
268 | # DW_AT short names. | |
269 | variable _AT | |
270 | # DW_FORM short names. | |
271 | variable _FORM | |
272 | # DW_OP short names. | |
273 | variable _OP | |
274 | ||
275 | # The current output file. | |
276 | variable _output_file | |
277 | ||
4f22ed5c DE |
278 | # Note: The _cu_ values here also apply to type units (TUs). |
279 | # Think of a TU as a special kind of CU. | |
280 | ||
1d24041a TT |
281 | # Current CU count. |
282 | variable _cu_count | |
283 | ||
284 | # The current CU's base label. | |
285 | variable _cu_label | |
286 | ||
287 | # The current CU's version. | |
288 | variable _cu_version | |
289 | ||
290 | # The current CU's address size. | |
291 | variable _cu_addr_size | |
292 | # The current CU's offset size. | |
293 | variable _cu_offset_size | |
294 | ||
295 | # Label generation number. | |
296 | variable _label_num | |
297 | ||
298 | # The deferred output array. The index is the section name; the | |
299 | # contents hold the data for that section. | |
300 | variable _deferred_output | |
301 | ||
302 | # If empty, we should write directly to the output file. | |
303 | # Otherwise, this is the name of a section to write to. | |
304 | variable _defer | |
305 | ||
6c9e2db4 DE |
306 | # The abbrev section. Typically .debug_abbrev but can be .debug_abbrev.dwo |
307 | # for Fission. | |
308 | variable _abbrev_section | |
309 | ||
1d24041a TT |
310 | # The next available abbrev number in the current CU's abbrev |
311 | # table. | |
312 | variable _abbrev_num | |
313 | ||
314 | # The string table for this assembly. The key is the string; the | |
315 | # value is the label for that string. | |
316 | variable _strings | |
317 | ||
6ef37366 PM |
318 | # Current .debug_line unit count. |
319 | variable _line_count | |
320 | ||
321 | # Whether a file_name entry was seen. | |
322 | variable _line_saw_file | |
323 | ||
28d2bfb9 AB |
324 | # Whether a line table program has been seen. |
325 | variable _line_saw_program | |
326 | ||
327 | # A Label for line table header generation. | |
328 | variable _line_header_end_label | |
329 | ||
330 | # The address size for debug ranges section. | |
331 | variable _debug_ranges_64_bit | |
332 | ||
1d24041a TT |
333 | proc _process_one_constant {name value} { |
334 | variable _constants | |
335 | variable _AT | |
336 | variable _FORM | |
337 | variable _OP | |
338 | ||
339 | set _constants($name) $value | |
340 | ||
341 | if {![regexp "^DW_(\[A-Z\]+)_(\[A-Za-z0-9_\]+)$" $name \ | |
342 | ignore prefix name2]} { | |
343 | error "non-matching name: $name" | |
344 | } | |
345 | ||
346 | if {$name2 == "lo_user" || $name2 == "hi_user"} { | |
347 | return | |
348 | } | |
349 | ||
350 | # We only try to shorten some very common things. | |
351 | # FIXME: CFA? | |
352 | switch -exact -- $prefix { | |
353 | TAG { | |
354 | # Create two procedures for the tag. These call | |
355 | # _handle_DW_TAG with the full tag name baked in; this | |
356 | # does all the actual work. | |
357 | proc $name {{attrs {}} {children {}}} \ | |
358 | "_handle_DW_TAG $name \$attrs \$children" | |
359 | ||
360 | # Filter out ones that are known to clash. | |
361 | if {$name2 == "variable" || $name2 == "namespace"} { | |
362 | set name2 "tag_$name2" | |
363 | } | |
364 | ||
365 | if {[info commands $name2] != {}} { | |
366 | error "duplicate proc name: from $name" | |
367 | } | |
368 | ||
369 | proc $name2 {{attrs {}} {children {}}} \ | |
370 | "_handle_DW_TAG $name \$attrs \$children" | |
371 | } | |
372 | ||
373 | AT { | |
374 | set _AT($name2) $name | |
375 | } | |
376 | ||
377 | FORM { | |
378 | set _FORM($name2) $name | |
379 | } | |
380 | ||
381 | OP { | |
382 | set _OP($name2) $name | |
383 | } | |
384 | ||
385 | default { | |
386 | return | |
387 | } | |
388 | } | |
389 | } | |
390 | ||
391 | proc _read_constants {} { | |
392 | global srcdir hex decimal | |
1d24041a TT |
393 | |
394 | # DWARF name-matching regexp. | |
395 | set dwrx "DW_\[a-zA-Z0-9_\]+" | |
396 | # Whitespace regexp. | |
397 | set ws "\[ \t\]+" | |
398 | ||
399 | set fd [open [file join $srcdir .. .. include dwarf2.h]] | |
400 | while {![eof $fd]} { | |
401 | set line [gets $fd] | |
402 | if {[regexp -- "^${ws}($dwrx)${ws}=${ws}($hex|$decimal),?$" \ | |
403 | $line ignore name value ignore2]} { | |
404 | _process_one_constant $name $value | |
405 | } | |
406 | } | |
407 | close $fd | |
408 | ||
409 | set fd [open [file join $srcdir .. .. include dwarf2.def]] | |
410 | while {![eof $fd]} { | |
411 | set line [gets $fd] | |
412 | if {[regexp -- \ | |
413 | "^DW_\[A-Z_\]+${ws}\\(($dwrx),${ws}($hex|$decimal)\\)$" \ | |
414 | $line ignore name value ignore2]} { | |
415 | _process_one_constant $name $value | |
416 | } | |
417 | } | |
418 | close $fd | |
1d24041a TT |
419 | } |
420 | ||
421 | proc _quote {string} { | |
422 | # FIXME | |
423 | return "\"${string}\\0\"" | |
424 | } | |
425 | ||
b6807d98 TT |
426 | proc _nz_quote {string} { |
427 | # For now, no quoting is done. | |
428 | return "\"${string}\"" | |
429 | } | |
430 | ||
1d24041a TT |
431 | proc _handle_DW_FORM {form value} { |
432 | switch -exact -- $form { | |
433 | DW_FORM_string { | |
434 | _op .ascii [_quote $value] | |
435 | } | |
436 | ||
437 | DW_FORM_flag_present { | |
438 | # We don't need to emit anything. | |
439 | } | |
440 | ||
441 | DW_FORM_data4 - | |
442 | DW_FORM_ref4 { | |
443 | _op .4byte $value | |
444 | } | |
445 | ||
446 | DW_FORM_ref_addr { | |
447 | variable _cu_offset_size | |
448 | variable _cu_version | |
449 | variable _cu_addr_size | |
450 | ||
451 | if {$_cu_version == 2} { | |
452 | set size $_cu_addr_size | |
453 | } else { | |
454 | set size $_cu_offset_size | |
455 | } | |
456 | ||
457 | _op .${size}byte $value | |
458 | } | |
459 | ||
6ef37366 PM |
460 | DW_FORM_sec_offset { |
461 | variable _cu_offset_size | |
462 | _op .${_cu_offset_size}byte $value | |
463 | } | |
464 | ||
1d24041a TT |
465 | DW_FORM_ref1 - |
466 | DW_FORM_flag - | |
467 | DW_FORM_data1 { | |
468 | _op .byte $value | |
469 | } | |
470 | ||
471 | DW_FORM_sdata { | |
472 | _op .sleb128 $value | |
473 | } | |
474 | ||
475 | DW_FORM_ref_udata - | |
476 | DW_FORM_udata { | |
477 | _op .uleb128 $value | |
478 | } | |
479 | ||
480 | DW_FORM_addr { | |
481 | variable _cu_addr_size | |
482 | ||
483 | _op .${_cu_addr_size}byte $value | |
484 | } | |
485 | ||
486 | DW_FORM_data2 - | |
487 | DW_FORM_ref2 { | |
488 | _op .2byte $value | |
489 | } | |
490 | ||
491 | DW_FORM_data8 - | |
492 | DW_FORM_ref8 - | |
493 | DW_FORM_ref_sig8 { | |
494 | _op .8byte $value | |
495 | } | |
496 | ||
0224619f JK |
497 | DW_FORM_data16 { |
498 | _op .8byte $value | |
499 | } | |
500 | ||
1d24041a TT |
501 | DW_FORM_strp { |
502 | variable _strings | |
503 | variable _cu_offset_size | |
504 | ||
505 | if {![info exists _strings($value)]} { | |
506 | set _strings($value) [new_label strp] | |
507 | _defer_output .debug_string { | |
508 | define_label $_strings($value) | |
509 | _op .ascii [_quote $value] | |
510 | } | |
511 | } | |
512 | ||
513 | _op .${_cu_offset_size}byte $_strings($value) "strp: $value" | |
514 | } | |
515 | ||
516 | SPECIAL_expr { | |
517 | set l1 [new_label "expr_start"] | |
518 | set l2 [new_label "expr_end"] | |
519 | _op .uleb128 "$l2 - $l1" "expression" | |
520 | define_label $l1 | |
521 | _location $value | |
522 | define_label $l2 | |
523 | } | |
524 | ||
b6807d98 TT |
525 | DW_FORM_block1 { |
526 | set len [string length $value] | |
527 | if {$len > 255} { | |
528 | error "DW_FORM_block1 length too long" | |
529 | } | |
530 | _op .byte $len | |
531 | _op .ascii [_nz_quote $value] | |
532 | } | |
533 | ||
1d24041a TT |
534 | DW_FORM_block2 - |
535 | DW_FORM_block4 - | |
536 | ||
537 | DW_FORM_block - | |
1d24041a TT |
538 | |
539 | DW_FORM_ref2 - | |
540 | DW_FORM_indirect - | |
1d24041a TT |
541 | DW_FORM_exprloc - |
542 | ||
cf532bd1 | 543 | DW_FORM_strx - |
15f18d14 AT |
544 | DW_FORM_strx1 - |
545 | DW_FORM_strx2 - | |
546 | DW_FORM_strx3 - | |
547 | DW_FORM_strx4 - | |
cf532bd1 | 548 | |
1d24041a TT |
549 | DW_FORM_GNU_addr_index - |
550 | DW_FORM_GNU_str_index - | |
551 | DW_FORM_GNU_ref_alt - | |
552 | DW_FORM_GNU_strp_alt - | |
553 | ||
554 | default { | |
555 | error "unhandled form $form" | |
556 | } | |
557 | } | |
558 | } | |
559 | ||
560 | proc _guess_form {value varname} { | |
561 | upvar $varname new_value | |
562 | ||
563 | switch -exact -- [string range $value 0 0] { | |
564 | @ { | |
565 | # Constant reference. | |
566 | variable _constants | |
567 | ||
568 | set new_value $_constants([string range $value 1 end]) | |
569 | # Just the simplest. | |
570 | return DW_FORM_sdata | |
571 | } | |
572 | ||
573 | : { | |
574 | # Label reference. | |
575 | variable _cu_label | |
576 | ||
577 | set new_value "[string range $value 1 end] - $_cu_label" | |
578 | ||
579 | return DW_FORM_ref4 | |
580 | } | |
581 | ||
f13a9a0c | 582 | % { |
456ba0fa TV |
583 | # Label reference, an offset from .debug_info. |
584 | set new_value "[string range $value 1 end]" | |
f13a9a0c YQ |
585 | |
586 | return DW_FORM_ref_addr | |
587 | } | |
588 | ||
1d24041a | 589 | default { |
7d72802b TV |
590 | return "" |
591 | } | |
592 | } | |
593 | } | |
594 | ||
595 | proc _default_form { attr } { | |
596 | switch -exact -- $attr { | |
597 | DW_AT_low_pc { | |
598 | return DW_FORM_addr | |
599 | } | |
600 | DW_AT_producer - | |
601 | DW_AT_comp_dir - | |
602 | DW_AT_linkage_name - | |
603 | DW_AT_MIPS_linkage_name - | |
604 | DW_AT_name { | |
1d24041a TT |
605 | return DW_FORM_string |
606 | } | |
607 | } | |
7d72802b | 608 | return "" |
1d24041a TT |
609 | } |
610 | ||
611 | # Map NAME to its canonical form. | |
612 | proc _map_name {name ary} { | |
613 | variable $ary | |
614 | ||
615 | if {[info exists ${ary}($name)]} { | |
616 | set name [set ${ary}($name)] | |
617 | } | |
618 | ||
619 | return $name | |
620 | } | |
621 | ||
02ad9cf1 YQ |
622 | proc _handle_attribute { attr_name attr_value attr_form } { |
623 | variable _abbrev_section | |
624 | variable _constants | |
8cd6d968 | 625 | variable _cu_version |
02ad9cf1 YQ |
626 | |
627 | _handle_DW_FORM $attr_form $attr_value | |
628 | ||
629 | _defer_output $_abbrev_section { | |
8cd6d968 MW |
630 | if { $attr_form eq "SPECIAL_expr" } { |
631 | if { $_cu_version < 4 } { | |
632 | set attr_form_comment "DW_FORM_block" | |
633 | } else { | |
634 | set attr_form_comment "DW_FORM_exprloc" | |
635 | } | |
636 | } else { | |
637 | set attr_form_comment $attr_form | |
638 | } | |
02ad9cf1 | 639 | _op .uleb128 $_constants($attr_name) $attr_name |
8cd6d968 | 640 | _op .uleb128 $_constants($attr_form) $attr_form_comment |
02ad9cf1 YQ |
641 | } |
642 | } | |
643 | ||
876c4df9 YQ |
644 | # Handle macro attribute MACRO_AT_range. |
645 | ||
646 | proc _handle_macro_at_range { attr_value } { | |
10da644d TV |
647 | if {[llength $attr_value] != 1} { |
648 | error "usage: MACRO_AT_range { func }" | |
876c4df9 YQ |
649 | } |
650 | ||
651 | set func [lindex $attr_value 0] | |
10da644d TV |
652 | global srcdir subdir srcfile |
653 | set src ${srcdir}/${subdir}/${srcfile} | |
876c4df9 YQ |
654 | set result [function_range $func $src] |
655 | ||
656 | _handle_attribute DW_AT_low_pc [lindex $result 0] \ | |
657 | DW_FORM_addr | |
658 | _handle_attribute DW_AT_high_pc \ | |
659 | "[lindex $result 0] + [lindex $result 1]" DW_FORM_addr | |
660 | } | |
661 | ||
662 | # Handle macro attribute MACRO_AT_func. | |
663 | ||
664 | proc _handle_macro_at_func { attr_value } { | |
10da644d | 665 | if {[llength $attr_value] != 1} { |
876c4df9 YQ |
666 | error "usage: MACRO_AT_func { func file }" |
667 | } | |
668 | _handle_attribute DW_AT_name [lindex $attr_value 0] DW_FORM_string | |
669 | _handle_macro_at_range $attr_value | |
670 | } | |
671 | ||
1d24041a | 672 | proc _handle_DW_TAG {tag_name {attrs {}} {children {}}} { |
6c9e2db4 | 673 | variable _abbrev_section |
1d24041a TT |
674 | variable _abbrev_num |
675 | variable _constants | |
676 | ||
677 | set has_children [expr {[string length $children] > 0}] | |
678 | set my_abbrev [incr _abbrev_num] | |
679 | ||
680 | # We somewhat wastefully emit a new abbrev entry for each tag. | |
681 | # There's no reason for this other than laziness. | |
6c9e2db4 | 682 | _defer_output $_abbrev_section { |
1d24041a TT |
683 | _op .uleb128 $my_abbrev "Abbrev start" |
684 | _op .uleb128 $_constants($tag_name) $tag_name | |
685 | _op .byte $has_children "has_children" | |
686 | } | |
687 | ||
688 | _op .uleb128 $my_abbrev "Abbrev ($tag_name)" | |
689 | ||
690 | foreach attr $attrs { | |
691 | set attr_name [_map_name [lindex $attr 0] _AT] | |
2223449a KB |
692 | |
693 | # When the length of ATTR is greater than 2, the last | |
694 | # element of the list must be a form. The second through | |
695 | # the penultimate elements are joined together and | |
696 | # evaluated using subst. This allows constructs such as | |
697 | # [gdb_target_symbol foo] to be used. | |
698 | ||
699 | if {[llength $attr] > 2} { | |
700 | set attr_value [uplevel 2 [list subst [join [lrange $attr 1 end-1]]]] | |
701 | } else { | |
702 | set attr_value [uplevel 2 [list subst [lindex $attr 1]]] | |
703 | } | |
876c4df9 YQ |
704 | |
705 | if { [string equal "MACRO_AT_func" $attr_name] } { | |
706 | _handle_macro_at_func $attr_value | |
707 | } elseif { [string equal "MACRO_AT_range" $attr_name] } { | |
708 | _handle_macro_at_range $attr_value | |
1d24041a | 709 | } else { |
876c4df9 | 710 | if {[llength $attr] > 2} { |
f13a9a0c YQ |
711 | set attr_form [uplevel 2 [list subst [lindex $attr end]]] |
712 | ||
713 | if { [string index $attr_value 0] == ":" } { | |
714 | # It is a label, get its value. | |
715 | _guess_form $attr_value attr_value | |
716 | } | |
876c4df9 YQ |
717 | } else { |
718 | set attr_form [_guess_form $attr_value attr_value] | |
7d72802b TV |
719 | if { $attr_form eq "" } { |
720 | set attr_form [_default_form $attr_name] | |
721 | } | |
722 | if { $attr_form eq "" } { | |
723 | error "No form for $attr_name $attr_value" | |
724 | } | |
876c4df9 YQ |
725 | } |
726 | set attr_form [_map_name $attr_form _FORM] | |
1d24041a | 727 | |
876c4df9 YQ |
728 | _handle_attribute $attr_name $attr_value $attr_form |
729 | } | |
1d24041a TT |
730 | } |
731 | ||
6c9e2db4 | 732 | _defer_output $_abbrev_section { |
1d24041a | 733 | # Terminator. |
c40907bf TV |
734 | _op .byte 0x0 "DW_AT - Terminator" |
735 | _op .byte 0x0 "DW_FORM - Terminator" | |
1d24041a TT |
736 | } |
737 | ||
738 | if {$has_children} { | |
739 | uplevel 2 $children | |
740 | ||
741 | # Terminate children. | |
742 | _op .byte 0x0 "Terminate children" | |
743 | } | |
744 | } | |
745 | ||
746 | proc _emit {string} { | |
747 | variable _output_file | |
748 | variable _defer | |
749 | variable _deferred_output | |
750 | ||
751 | if {$_defer == ""} { | |
752 | puts $_output_file $string | |
753 | } else { | |
754 | append _deferred_output($_defer) ${string}\n | |
755 | } | |
756 | } | |
757 | ||
dc294be5 TT |
758 | proc _section {name {flags ""} {type ""}} { |
759 | if {$flags == "" && $type == ""} { | |
760 | _emit " .section $name" | |
761 | } elseif {$type == ""} { | |
762 | _emit " .section $name, \"$flags\"" | |
763 | } else { | |
764 | _emit " .section $name, \"$flags\", %$type" | |
765 | } | |
1d24041a TT |
766 | } |
767 | ||
dc294be5 TT |
768 | # SECTION_SPEC is a list of arguments to _section. |
769 | proc _defer_output {section_spec body} { | |
1d24041a TT |
770 | variable _defer |
771 | variable _deferred_output | |
772 | ||
773 | set old_defer $_defer | |
dc294be5 | 774 | set _defer [lindex $section_spec 0] |
1d24041a TT |
775 | |
776 | if {![info exists _deferred_output($_defer)]} { | |
777 | set _deferred_output($_defer) "" | |
dc294be5 | 778 | eval _section $section_spec |
1d24041a TT |
779 | } |
780 | ||
781 | uplevel $body | |
782 | ||
783 | set _defer $old_defer | |
784 | } | |
785 | ||
786 | proc _defer_to_string {body} { | |
787 | variable _defer | |
788 | variable _deferred_output | |
789 | ||
790 | set old_defer $_defer | |
791 | set _defer temp | |
792 | ||
793 | set _deferred_output($_defer) "" | |
794 | ||
795 | uplevel $body | |
796 | ||
797 | set result $_deferred_output($_defer) | |
798 | unset _deferred_output($_defer) | |
799 | ||
800 | set _defer $old_defer | |
801 | return $result | |
802 | } | |
803 | ||
804 | proc _write_deferred_output {} { | |
805 | variable _output_file | |
806 | variable _deferred_output | |
807 | ||
808 | foreach section [array names _deferred_output] { | |
809 | # The data already has a newline. | |
810 | puts -nonewline $_output_file $_deferred_output($section) | |
811 | } | |
812 | ||
813 | # Save some memory. | |
814 | unset _deferred_output | |
815 | } | |
816 | ||
817 | proc _op {name value {comment ""}} { | |
818 | set text " ${name} ${value}" | |
819 | if {$comment != ""} { | |
820 | # Try to make stuff line up nicely. | |
821 | while {[string length $text] < 40} { | |
822 | append text " " | |
823 | } | |
824 | append text "/* ${comment} */" | |
825 | } | |
826 | _emit $text | |
827 | } | |
828 | ||
829 | proc _compute_label {name} { | |
830 | return ".L${name}" | |
831 | } | |
832 | ||
833 | # Return a name suitable for use as a label. If BASE_NAME is | |
834 | # specified, it is incorporated into the label name; this is to | |
835 | # make debugging the generated assembler easier. If BASE_NAME is | |
836 | # not specified a generic default is used. This proc does not | |
837 | # define the label; see 'define_label'. 'new_label' attempts to | |
838 | # ensure that label names are unique. | |
839 | proc new_label {{base_name label}} { | |
840 | variable _label_num | |
841 | ||
842 | return [_compute_label ${base_name}[incr _label_num]] | |
843 | } | |
844 | ||
845 | # Define a label named NAME. Ordinarily, NAME comes from a call | |
846 | # to 'new_label', but this is not required. | |
847 | proc define_label {name} { | |
848 | _emit "${name}:" | |
849 | } | |
850 | ||
1d24041a TT |
851 | # A higher-level interface to label handling. |
852 | # | |
853 | # ARGS is a list of label descriptors. Each one is either a | |
854 | # single element, or a list of two elements -- a name and some | |
855 | # text. For each descriptor, 'new_label' is invoked. If the list | |
856 | # form is used, the second element in the list is passed as an | |
857 | # argument. The label name is used to define a variable in the | |
858 | # enclosing scope; this can be used to refer to the label later. | |
859 | # The label name is also used to define a new proc whose name is | |
860 | # the label name plus a trailing ":". This proc takes a body as | |
861 | # an argument and can be used to define the label at that point; | |
862 | # then the body, if any, is evaluated in the caller's context. | |
863 | # | |
864 | # For example: | |
865 | # | |
866 | # declare_labels int_label | |
867 | # something { ... $int_label } ;# refer to the label | |
868 | # int_label: constant { ... } ;# define the label | |
869 | proc declare_labels {args} { | |
870 | foreach arg $args { | |
871 | set name [lindex $arg 0] | |
872 | set text [lindex $arg 1] | |
873 | ||
e633b117 SM |
874 | if { $text == "" } { |
875 | set text $name | |
1d24041a TT |
876 | } |
877 | ||
e633b117 SM |
878 | upvar $name label_var |
879 | set label_var [new_label $text] | |
880 | ||
1d24041a TT |
881 | proc ${name}: {args} [format { |
882 | define_label %s | |
883 | uplevel $args | |
884 | } $label_var] | |
885 | } | |
886 | } | |
887 | ||
888 | # This is a miniature assembler for location expressions. It is | |
889 | # suitable for use in the attributes to a DIE. Its output is | |
890 | # prefixed with "=" to make it automatically use DW_FORM_block. | |
891 | # BODY is split by lines, and each line is taken to be a list. | |
892 | # (FIXME should use 'info complete' here.) | |
893 | # Each list's first element is the opcode, either short or long | |
894 | # forms are accepted. | |
895 | # FIXME argument handling | |
896 | # FIXME move docs | |
897 | proc _location {body} { | |
898 | variable _constants | |
b6807d98 | 899 | variable _cu_label |
5ac95241 | 900 | variable _cu_version |
b6807d98 | 901 | variable _cu_addr_size |
5bd1ef56 | 902 | variable _cu_offset_size |
1d24041a TT |
903 | |
904 | foreach line [split $body \n] { | |
4ff709eb TT |
905 | # Ignore blank lines, and allow embedded comments. |
906 | if {[lindex $line 0] == "" || [regexp -- {^[ \t]*#} $line]} { | |
1d24041a TT |
907 | continue |
908 | } | |
909 | set opcode [_map_name [lindex $line 0] _OP] | |
910 | _op .byte $_constants($opcode) $opcode | |
911 | ||
912 | switch -exact -- $opcode { | |
913 | DW_OP_addr { | |
1d24041a TT |
914 | _op .${_cu_addr_size}byte [lindex $line 1] |
915 | } | |
916 | ||
0fde2c53 DE |
917 | DW_OP_regx { |
918 | _op .uleb128 [lindex $line 1] | |
919 | } | |
920 | ||
4ff709eb | 921 | DW_OP_pick - |
1d24041a TT |
922 | DW_OP_const1u - |
923 | DW_OP_const1s { | |
924 | _op .byte [lindex $line 1] | |
925 | } | |
926 | ||
927 | DW_OP_const2u - | |
928 | DW_OP_const2s { | |
929 | _op .2byte [lindex $line 1] | |
930 | } | |
931 | ||
932 | DW_OP_const4u - | |
933 | DW_OP_const4s { | |
934 | _op .4byte [lindex $line 1] | |
935 | } | |
936 | ||
937 | DW_OP_const8u - | |
938 | DW_OP_const8s { | |
939 | _op .8byte [lindex $line 1] | |
940 | } | |
941 | ||
942 | DW_OP_constu { | |
943 | _op .uleb128 [lindex $line 1] | |
944 | } | |
945 | DW_OP_consts { | |
946 | _op .sleb128 [lindex $line 1] | |
947 | } | |
948 | ||
16b5a7cb AB |
949 | DW_OP_plus_uconst { |
950 | _op .uleb128 [lindex $line 1] | |
951 | } | |
952 | ||
5bd1ef56 TT |
953 | DW_OP_piece { |
954 | _op .uleb128 [lindex $line 1] | |
955 | } | |
956 | ||
16b5a7cb AB |
957 | DW_OP_bit_piece { |
958 | _op .uleb128 [lindex $line 1] | |
959 | _op .uleb128 [lindex $line 2] | |
960 | } | |
961 | ||
4ff709eb TT |
962 | DW_OP_skip - |
963 | DW_OP_bra { | |
964 | _op .2byte [lindex $line 1] | |
965 | } | |
966 | ||
f13a9a0c YQ |
967 | DW_OP_implicit_value { |
968 | set l1 [new_label "value_start"] | |
969 | set l2 [new_label "value_end"] | |
970 | _op .uleb128 "$l2 - $l1" | |
971 | define_label $l1 | |
972 | foreach value [lrange $line 1 end] { | |
973 | switch -regexp -- $value { | |
974 | {^0x[[:xdigit:]]{1,2}$} {_op .byte $value} | |
975 | {^0x[[:xdigit:]]{4}$} {_op .2byte $value} | |
976 | {^0x[[:xdigit:]]{8}$} {_op .4byte $value} | |
977 | {^0x[[:xdigit:]]{16}$} {_op .8byte $value} | |
978 | default { | |
979 | error "bad value '$value' in DW_OP_implicit_value" | |
980 | } | |
981 | } | |
982 | } | |
983 | define_label $l2 | |
984 | } | |
985 | ||
7942e96e | 986 | DW_OP_implicit_pointer - |
b6807d98 TT |
987 | DW_OP_GNU_implicit_pointer { |
988 | if {[llength $line] != 3} { | |
7942e96e | 989 | error "usage: $opcode LABEL OFFSET" |
b6807d98 TT |
990 | } |
991 | ||
992 | # Here label is a section offset. | |
993 | set label [lindex $line 1] | |
5ac95241 YQ |
994 | if { $_cu_version == 2 } { |
995 | _op .${_cu_addr_size}byte $label | |
996 | } else { | |
997 | _op .${_cu_offset_size}byte $label | |
998 | } | |
b6807d98 TT |
999 | _op .sleb128 [lindex $line 2] |
1000 | } | |
1001 | ||
ae3a7c47 KB |
1002 | DW_OP_GNU_variable_value { |
1003 | if {[llength $line] != 2} { | |
1004 | error "usage: $opcode LABEL" | |
1005 | } | |
1006 | ||
1007 | # Here label is a section offset. | |
1008 | set label [lindex $line 1] | |
1009 | if { $_cu_version == 2 } { | |
1010 | _op .${_cu_addr_size}byte $label | |
1011 | } else { | |
1012 | _op .${_cu_offset_size}byte $label | |
1013 | } | |
1014 | } | |
1015 | ||
b39a8faf YQ |
1016 | DW_OP_deref_size { |
1017 | if {[llength $line] != 2} { | |
1018 | error "usage: DW_OP_deref_size SIZE" | |
1019 | } | |
1020 | ||
1021 | _op .byte [lindex $line 1] | |
1022 | } | |
1023 | ||
5f3ff4f8 JK |
1024 | DW_OP_bregx { |
1025 | _op .uleb128 [lindex $line 1] | |
1026 | _op .sleb128 [lindex $line 2] | |
1027 | } | |
1028 | ||
1d24041a TT |
1029 | default { |
1030 | if {[llength $line] > 1} { | |
1031 | error "Unimplemented: operands in location for $opcode" | |
1032 | } | |
1033 | } | |
1034 | } | |
1035 | } | |
1036 | } | |
1037 | ||
1038 | # Emit a DWARF CU. | |
6c9e2db4 DE |
1039 | # OPTIONS is a list with an even number of elements containing |
1040 | # option-name and option-value pairs. | |
1041 | # Current options are: | |
1042 | # is_64 0|1 - boolean indicating if you want to emit 64-bit DWARF | |
1043 | # default = 0 (32-bit) | |
1044 | # version n - DWARF version number to emit | |
1045 | # default = 4 | |
054a0959 | 1046 | # addr_size n - the size of addresses in bytes: 4, 8, or default |
e630b974 | 1047 | # default = default |
6c9e2db4 DE |
1048 | # fission 0|1 - boolean indicating if generating Fission debug info |
1049 | # default = 0 | |
1d24041a TT |
1050 | # BODY is Tcl code that emits the DIEs which make up the body of |
1051 | # the CU. It is evaluated in the caller's context. | |
6c9e2db4 | 1052 | proc cu {options body} { |
eab9267c | 1053 | variable _constants |
1d24041a | 1054 | variable _cu_count |
6c9e2db4 | 1055 | variable _abbrev_section |
1d24041a TT |
1056 | variable _abbrev_num |
1057 | variable _cu_label | |
1058 | variable _cu_version | |
1059 | variable _cu_addr_size | |
1060 | variable _cu_offset_size | |
1061 | ||
6c9e2db4 DE |
1062 | # Establish the defaults. |
1063 | set is_64 0 | |
1064 | set _cu_version 4 | |
e630b974 | 1065 | set _cu_addr_size default |
6c9e2db4 DE |
1066 | set fission 0 |
1067 | set section ".debug_info" | |
1068 | set _abbrev_section ".debug_abbrev" | |
1069 | ||
1070 | foreach { name value } $options { | |
f13a9a0c | 1071 | set value [uplevel 1 "subst \"$value\""] |
6c9e2db4 DE |
1072 | switch -exact -- $name { |
1073 | is_64 { set is_64 $value } | |
1074 | version { set _cu_version $value } | |
1075 | addr_size { set _cu_addr_size $value } | |
1076 | fission { set fission $value } | |
1077 | default { error "unknown option $name" } | |
1078 | } | |
1079 | } | |
e630b974 TT |
1080 | if {$_cu_addr_size == "default"} { |
1081 | if {[is_64_target]} { | |
1082 | set _cu_addr_size 8 | |
1083 | } else { | |
1084 | set _cu_addr_size 4 | |
1085 | } | |
1086 | } | |
6c9e2db4 DE |
1087 | set _cu_offset_size [expr { $is_64 ? 8 : 4 }] |
1088 | if { $fission } { | |
1089 | set section ".debug_info.dwo" | |
1090 | set _abbrev_section ".debug_abbrev.dwo" | |
1d24041a | 1091 | } |
1d24041a | 1092 | |
eab9267c MW |
1093 | if {$_cu_version < 4} { |
1094 | set _constants(SPECIAL_expr) $_constants(DW_FORM_block) | |
1095 | } else { | |
1096 | set _constants(SPECIAL_expr) $_constants(DW_FORM_exprloc) | |
1097 | } | |
1098 | ||
6c9e2db4 | 1099 | _section $section |
1d24041a TT |
1100 | |
1101 | set cu_num [incr _cu_count] | |
1102 | set my_abbrevs [_compute_label "abbrev${cu_num}_begin"] | |
1103 | set _abbrev_num 1 | |
1104 | ||
1105 | set _cu_label [_compute_label "cu${cu_num}_begin"] | |
1106 | set start_label [_compute_label "cu${cu_num}_start"] | |
1107 | set end_label [_compute_label "cu${cu_num}_end"] | |
28d2bfb9 | 1108 | |
1d24041a TT |
1109 | define_label $_cu_label |
1110 | if {$is_64} { | |
1111 | _op .4byte 0xffffffff | |
1112 | _op .8byte "$end_label - $start_label" | |
1113 | } else { | |
1114 | _op .4byte "$end_label - $start_label" | |
1115 | } | |
1116 | define_label $start_label | |
6c9e2db4 | 1117 | _op .2byte $_cu_version Version |
41c77605 | 1118 | _op .${_cu_offset_size}byte $my_abbrevs Abbrevs |
6c9e2db4 | 1119 | _op .byte $_cu_addr_size "Pointer size" |
1d24041a | 1120 | |
6c9e2db4 | 1121 | _defer_output $_abbrev_section { |
1d24041a TT |
1122 | define_label $my_abbrevs |
1123 | } | |
1124 | ||
1125 | uplevel $body | |
1126 | ||
6c9e2db4 | 1127 | _defer_output $_abbrev_section { |
1d24041a | 1128 | # Emit the terminator. |
c40907bf | 1129 | _op .byte 0x0 "Abbrev end - Terminator" |
1d24041a TT |
1130 | } |
1131 | ||
1132 | define_label $end_label | |
1133 | } | |
1134 | ||
4f22ed5c | 1135 | # Emit a DWARF TU. |
6c9e2db4 DE |
1136 | # OPTIONS is a list with an even number of elements containing |
1137 | # option-name and option-value pairs. | |
1138 | # Current options are: | |
1139 | # is_64 0|1 - boolean indicating if you want to emit 64-bit DWARF | |
1140 | # default = 0 (32-bit) | |
1141 | # version n - DWARF version number to emit | |
1142 | # default = 4 | |
054a0959 | 1143 | # addr_size n - the size of addresses in bytes: 4, 8, or default |
e630b974 | 1144 | # default = default |
6c9e2db4 DE |
1145 | # fission 0|1 - boolean indicating if generating Fission debug info |
1146 | # default = 0 | |
4f22ed5c | 1147 | # SIGNATURE is the 64-bit signature of the type. |
6c9e2db4 DE |
1148 | # TYPE_LABEL is the label of the type defined by this TU, |
1149 | # or "" if there is no type (i.e., type stubs in Fission). | |
4f22ed5c | 1150 | # BODY is Tcl code that emits the DIEs which make up the body of |
6c9e2db4 DE |
1151 | # the TU. It is evaluated in the caller's context. |
1152 | proc tu {options signature type_label body} { | |
4f22ed5c | 1153 | variable _cu_count |
6c9e2db4 | 1154 | variable _abbrev_section |
4f22ed5c DE |
1155 | variable _abbrev_num |
1156 | variable _cu_label | |
1157 | variable _cu_version | |
1158 | variable _cu_addr_size | |
1159 | variable _cu_offset_size | |
1160 | ||
6c9e2db4 DE |
1161 | # Establish the defaults. |
1162 | set is_64 0 | |
1163 | set _cu_version 4 | |
e630b974 | 1164 | set _cu_addr_size default |
6c9e2db4 DE |
1165 | set fission 0 |
1166 | set section ".debug_types" | |
1167 | set _abbrev_section ".debug_abbrev" | |
1168 | ||
1169 | foreach { name value } $options { | |
1170 | switch -exact -- $name { | |
1171 | is_64 { set is_64 $value } | |
1172 | version { set _cu_version $value } | |
1173 | addr_size { set _cu_addr_size $value } | |
1174 | fission { set fission $value } | |
1175 | default { error "unknown option $name" } | |
1176 | } | |
1177 | } | |
e630b974 TT |
1178 | if {$_cu_addr_size == "default"} { |
1179 | if {[is_64_target]} { | |
1180 | set _cu_addr_size 8 | |
1181 | } else { | |
1182 | set _cu_addr_size 4 | |
1183 | } | |
1184 | } | |
6c9e2db4 DE |
1185 | set _cu_offset_size [expr { $is_64 ? 8 : 4 }] |
1186 | if { $fission } { | |
1187 | set section ".debug_types.dwo" | |
1188 | set _abbrev_section ".debug_abbrev.dwo" | |
4f22ed5c | 1189 | } |
4f22ed5c | 1190 | |
6c9e2db4 | 1191 | _section $section |
4f22ed5c DE |
1192 | |
1193 | set cu_num [incr _cu_count] | |
1194 | set my_abbrevs [_compute_label "abbrev${cu_num}_begin"] | |
1195 | set _abbrev_num 1 | |
1196 | ||
1197 | set _cu_label [_compute_label "cu${cu_num}_begin"] | |
1198 | set start_label [_compute_label "cu${cu_num}_start"] | |
1199 | set end_label [_compute_label "cu${cu_num}_end"] | |
1200 | ||
1201 | define_label $_cu_label | |
1202 | if {$is_64} { | |
1203 | _op .4byte 0xffffffff | |
1204 | _op .8byte "$end_label - $start_label" | |
1205 | } else { | |
1206 | _op .4byte "$end_label - $start_label" | |
1207 | } | |
1208 | define_label $start_label | |
6c9e2db4 | 1209 | _op .2byte $_cu_version Version |
41c77605 | 1210 | _op .${_cu_offset_size}byte $my_abbrevs Abbrevs |
6c9e2db4 | 1211 | _op .byte $_cu_addr_size "Pointer size" |
4f22ed5c | 1212 | _op .8byte $signature Signature |
6c9e2db4 DE |
1213 | if { $type_label != "" } { |
1214 | uplevel declare_labels $type_label | |
1215 | upvar $type_label my_type_label | |
1216 | if {$is_64} { | |
1217 | _op .8byte "$my_type_label - $_cu_label" | |
1218 | } else { | |
1219 | _op .4byte "$my_type_label - $_cu_label" | |
1220 | } | |
4f22ed5c | 1221 | } else { |
6c9e2db4 DE |
1222 | if {$is_64} { |
1223 | _op .8byte 0 | |
1224 | } else { | |
1225 | _op .4byte 0 | |
1226 | } | |
4f22ed5c DE |
1227 | } |
1228 | ||
6c9e2db4 | 1229 | _defer_output $_abbrev_section { |
4f22ed5c DE |
1230 | define_label $my_abbrevs |
1231 | } | |
1232 | ||
1233 | uplevel $body | |
1234 | ||
6c9e2db4 | 1235 | _defer_output $_abbrev_section { |
4f22ed5c | 1236 | # Emit the terminator. |
c40907bf | 1237 | _op .byte 0x0 "Abbrev end - Terminator" |
4f22ed5c DE |
1238 | } |
1239 | ||
1240 | define_label $end_label | |
1241 | } | |
1242 | ||
28d2bfb9 AB |
1243 | # Emit a DWARF .debug_ranges unit. |
1244 | # OPTIONS is a list with an even number of elements containing | |
1245 | # option-name and option-value pairs. | |
1246 | # Current options are: | |
1247 | # is_64 0|1 - boolean indicating if you want to emit 64-bit DWARF | |
1248 | # default = 0 (32-bit) | |
1249 | # | |
1250 | # BODY is Tcl code that emits the content of the .debug_ranges | |
1251 | # unit, it is evaluated in the caller's context. | |
1252 | proc ranges {options body} { | |
1253 | variable _debug_ranges_64_bit | |
1254 | ||
1255 | foreach { name value } $options { | |
1256 | switch -exact -- $name { | |
1257 | is_64 { set _debug_ranges_64_bit [subst $value] } | |
1258 | default { error "unknown option $name" } | |
1259 | } | |
1260 | } | |
1261 | ||
1262 | set section ".debug_ranges" | |
1263 | _section $section | |
1264 | ||
a1945bd4 | 1265 | proc sequence { body } { |
28d2bfb9 AB |
1266 | variable _debug_ranges_64_bit |
1267 | ||
1268 | # Emit the sequence of addresses. | |
a1945bd4 SM |
1269 | |
1270 | proc base { addr } { | |
1271 | variable _debug_ranges_64_bit | |
1272 | ||
1273 | if { $_debug_ranges_64_bit } then { | |
1274 | _op .8byte 0xffffffffffffffff "Base Marker" | |
1275 | _op .8byte $addr "Base Address" | |
1276 | } else { | |
1277 | _op .4byte 0xffffffff "Base Marker" | |
1278 | _op .4byte $addr "Base Address" | |
28d2bfb9 AB |
1279 | } |
1280 | } | |
1281 | ||
a1945bd4 SM |
1282 | proc range { start end } { |
1283 | variable _debug_ranges_64_bit | |
1284 | ||
1285 | if { $_debug_ranges_64_bit } then { | |
1286 | _op .8byte $start "Start Address" | |
1287 | _op .8byte $end "End Address" | |
1288 | } else { | |
1289 | _op .4byte $start "Start Address" | |
1290 | _op .4byte $end "End Address" | |
1291 | } | |
1292 | } | |
1293 | ||
1294 | uplevel $body | |
1295 | ||
28d2bfb9 AB |
1296 | # End of the sequence. |
1297 | if { $_debug_ranges_64_bit } then { | |
1298 | _op .8byte 0x0 "End of Sequence Marker (Part 1)" | |
1299 | _op .8byte 0x0 "End of Sequence Marker (Part 2)" | |
1300 | } else { | |
1301 | _op .4byte 0x0 "End of Sequence Marker (Part 1)" | |
1302 | _op .4byte 0x0 "End of Sequence Marker (Part 2)" | |
1303 | } | |
1304 | } | |
1305 | ||
1306 | uplevel $body | |
1307 | } | |
1308 | ||
1309 | ||
6ef37366 PM |
1310 | # Emit a DWARF .debug_line unit. |
1311 | # OPTIONS is a list with an even number of elements containing | |
1312 | # option-name and option-value pairs. | |
1313 | # Current options are: | |
1314 | # is_64 0|1 - boolean indicating if you want to emit 64-bit DWARF | |
1315 | # default = 0 (32-bit) | |
1316 | # version n - DWARF version number to emit | |
1317 | # default = 4 | |
054a0959 | 1318 | # addr_size n - the size of addresses in bytes: 4, 8, or default |
6ef37366 PM |
1319 | # default = default |
1320 | # | |
1321 | # LABEL is the label of the current unit (which is probably | |
1322 | # referenced by a DW_AT_stmt_list), or "" if there is no such | |
1323 | # label. | |
1324 | # | |
1325 | # BODY is Tcl code that emits the parts which make up the body of | |
1326 | # the line unit. It is evaluated in the caller's context. The | |
1327 | # following commands are available for the BODY section: | |
1328 | # | |
1329 | # include_dir "dirname" -- adds a new include directory | |
1330 | # | |
1331 | # file_name "file.c" idx -- adds a new file name. IDX is a | |
1332 | # 1-based index referencing an include directory or 0 for | |
1333 | # current directory. | |
1334 | ||
1335 | proc lines {options label body} { | |
1336 | variable _line_count | |
1337 | variable _line_saw_file | |
28d2bfb9 AB |
1338 | variable _line_saw_program |
1339 | variable _line_header_end_label | |
6ef37366 PM |
1340 | |
1341 | # Establish the defaults. | |
1342 | set is_64 0 | |
1343 | set _unit_version 4 | |
1344 | set _unit_addr_size default | |
d93c6db7 AB |
1345 | set _line_saw_program 0 |
1346 | set _line_saw_file 0 | |
cecf8547 | 1347 | set _default_is_stmt 1 |
6ef37366 PM |
1348 | |
1349 | foreach { name value } $options { | |
1350 | switch -exact -- $name { | |
1351 | is_64 { set is_64 $value } | |
1352 | version { set _unit_version $value } | |
1353 | addr_size { set _unit_addr_size $value } | |
cecf8547 | 1354 | default_is_stmt { set _default_is_stmt $value } |
6ef37366 PM |
1355 | default { error "unknown option $name" } |
1356 | } | |
1357 | } | |
1358 | if {$_unit_addr_size == "default"} { | |
1359 | if {[is_64_target]} { | |
1360 | set _unit_addr_size 8 | |
1361 | } else { | |
1362 | set _unit_addr_size 4 | |
1363 | } | |
1364 | } | |
1365 | ||
1366 | set unit_num [incr _line_count] | |
1367 | ||
1368 | set section ".debug_line" | |
1369 | _section $section | |
1370 | ||
1371 | if { "$label" != "" } { | |
1372 | # Define the user-provided label at this point. | |
1373 | $label: | |
1374 | } | |
1375 | ||
1376 | set unit_len_label [_compute_label "line${_line_count}_start"] | |
1377 | set unit_end_label [_compute_label "line${_line_count}_end"] | |
1378 | set header_len_label [_compute_label "line${_line_count}_header_start"] | |
28d2bfb9 | 1379 | set _line_header_end_label [_compute_label "line${_line_count}_header_end"] |
6ef37366 PM |
1380 | |
1381 | if {$is_64} { | |
1382 | _op .4byte 0xffffffff | |
1383 | _op .8byte "$unit_end_label - $unit_len_label" "unit_length" | |
1384 | } else { | |
1385 | _op .4byte "$unit_end_label - $unit_len_label" "unit_length" | |
1386 | } | |
1387 | ||
1388 | define_label $unit_len_label | |
1389 | ||
1390 | _op .2byte $_unit_version version | |
1391 | ||
1392 | if {$is_64} { | |
28d2bfb9 | 1393 | _op .8byte "$_line_header_end_label - $header_len_label" "header_length" |
6ef37366 | 1394 | } else { |
28d2bfb9 | 1395 | _op .4byte "$_line_header_end_label - $header_len_label" "header_length" |
6ef37366 PM |
1396 | } |
1397 | ||
1398 | define_label $header_len_label | |
1399 | ||
1400 | _op .byte 1 "minimum_instruction_length" | |
cecf8547 | 1401 | _op .byte $_default_is_stmt "default_is_stmt" |
6ef37366 PM |
1402 | _op .byte 1 "line_base" |
1403 | _op .byte 1 "line_range" | |
28d2bfb9 AB |
1404 | _op .byte 10 "opcode_base" |
1405 | ||
1406 | # The standard_opcode_lengths table. The number of arguments | |
1407 | # for each of the standard opcodes. Generating 9 entries here | |
1408 | # matches the use of 10 in the opcode_base above. These 9 | |
1409 | # entries match the 9 standard opcodes for DWARF2, making use | |
1410 | # of only 9 should be fine, even if we are generating DWARF3 | |
1411 | # or DWARF4. | |
1412 | _op .byte 0 "standard opcode 1" | |
1413 | _op .byte 1 "standard opcode 2" | |
1414 | _op .byte 1 "standard opcode 3" | |
1415 | _op .byte 1 "standard opcode 4" | |
1416 | _op .byte 1 "standard opcode 5" | |
1417 | _op .byte 0 "standard opcode 6" | |
1418 | _op .byte 0 "standard opcode 7" | |
1419 | _op .byte 0 "standard opcode 8" | |
1420 | _op .byte 1 "standard opcode 9" | |
6ef37366 PM |
1421 | |
1422 | proc include_dir {dirname} { | |
1423 | _op .ascii [_quote $dirname] | |
1424 | } | |
1425 | ||
1426 | proc file_name {filename diridx} { | |
1427 | variable _line_saw_file | |
1428 | if "! $_line_saw_file" { | |
1429 | # Terminate the dir list. | |
1430 | _op .byte 0 "Terminator." | |
1431 | set _line_saw_file 1 | |
1432 | } | |
1433 | ||
1434 | _op .ascii [_quote $filename] | |
1435 | _op .sleb128 $diridx | |
1436 | _op .sleb128 0 "mtime" | |
1437 | _op .sleb128 0 "length" | |
1438 | } | |
1439 | ||
28d2bfb9 AB |
1440 | proc program {statements} { |
1441 | variable _line_saw_program | |
1442 | variable _line_header_end_label | |
853772cc TV |
1443 | variable _line |
1444 | ||
1445 | set _line 1 | |
28d2bfb9 AB |
1446 | |
1447 | if "! $_line_saw_program" { | |
1448 | # Terminate the file list. | |
1449 | _op .byte 0 "Terminator." | |
1450 | define_label $_line_header_end_label | |
1451 | set _line_saw_program 1 | |
1452 | } | |
1453 | ||
1454 | proc DW_LNE_set_address {addr} { | |
1455 | _op .byte 0 | |
1456 | set start [new_label "set_address_start"] | |
1457 | set end [new_label "set_address_end"] | |
1458 | _op .uleb128 "${end} - ${start}" | |
1459 | define_label ${start} | |
1460 | _op .byte 2 | |
1461 | if {[is_64_target]} { | |
1462 | _op .8byte ${addr} | |
1463 | } else { | |
1464 | _op .4byte ${addr} | |
1465 | } | |
1466 | define_label ${end} | |
1467 | } | |
1468 | ||
1469 | proc DW_LNE_end_sequence {} { | |
853772cc | 1470 | variable _line |
28d2bfb9 AB |
1471 | _op .byte 0 |
1472 | _op .uleb128 1 | |
1473 | _op .byte 1 | |
853772cc | 1474 | set _line 1 |
28d2bfb9 AB |
1475 | } |
1476 | ||
8f34b746 TV |
1477 | proc DW_LNE_user { len opcode } { |
1478 | set DW_LNE_lo_usr 0x80 | |
1479 | set DW_LNE_hi_usr 0xff | |
1480 | if { $DW_LNE_lo_usr <= $opcode | |
1481 | && $opcode <= $DW_LNE_hi_usr } { | |
1482 | _op .byte 0 | |
1483 | _op .uleb128 $len | |
1484 | _op .byte $opcode | |
1485 | for {set i 1} {$i < $len} {incr i} { | |
1486 | _op .byte 0 | |
1487 | } | |
1488 | } else { | |
1489 | error "unknown vendor specific extended opcode: $opcode" | |
1490 | } | |
1491 | } | |
1492 | ||
28d2bfb9 AB |
1493 | proc DW_LNS_copy {} { |
1494 | _op .byte 1 | |
1495 | } | |
1496 | ||
cecf8547 AB |
1497 | proc DW_LNS_negate_stmt {} { |
1498 | _op .byte 6 | |
1499 | } | |
1500 | ||
28d2bfb9 AB |
1501 | proc DW_LNS_advance_pc {offset} { |
1502 | _op .byte 2 | |
1503 | _op .uleb128 ${offset} | |
1504 | } | |
1505 | ||
1506 | proc DW_LNS_advance_line {offset} { | |
853772cc | 1507 | variable _line |
28d2bfb9 AB |
1508 | _op .byte 3 |
1509 | _op .sleb128 ${offset} | |
853772cc TV |
1510 | set _line [expr $_line + $offset] |
1511 | } | |
1512 | ||
1513 | # A pseudo line number program instruction, that can be used instead | |
1514 | # of DW_LNS_advance_line. Rather than writing: | |
1515 | # {DW_LNS_advance_line [expr $line1 - 1]} | |
1516 | # {DW_LNS_advance_line [expr $line2 - $line1]} | |
1517 | # {DW_LNS_advance_line [expr $line3 - $line2]} | |
1518 | # we can just write: | |
1519 | # {line $line1} | |
1520 | # {line $line2} | |
1521 | # {line $line3} | |
1522 | proc line {line} { | |
1523 | variable _line | |
1524 | set offset [expr $line - $_line] | |
1525 | DW_LNS_advance_line $offset | |
28d2bfb9 AB |
1526 | } |
1527 | ||
34e9a9fa AB |
1528 | proc DW_LNS_set_file {num} { |
1529 | _op .byte 4 | |
1530 | _op .sleb128 ${num} | |
1531 | } | |
1532 | ||
28d2bfb9 AB |
1533 | foreach statement $statements { |
1534 | uplevel 1 $statement | |
1535 | } | |
1536 | } | |
1537 | ||
6ef37366 PM |
1538 | uplevel $body |
1539 | ||
1540 | rename include_dir "" | |
1541 | rename file_name "" | |
1542 | ||
1543 | # Terminate dir list if we saw no files. | |
1544 | if "! $_line_saw_file" { | |
1545 | _op .byte 0 "Terminator." | |
1546 | } | |
1547 | ||
1548 | # Terminate the file list. | |
28d2bfb9 AB |
1549 | if "! $_line_saw_program" { |
1550 | _op .byte 0 "Terminator." | |
1551 | define_label $_line_header_end_label | |
1552 | } | |
6ef37366 | 1553 | |
6ef37366 PM |
1554 | define_label $unit_end_label |
1555 | } | |
1556 | ||
1d24041a TT |
1557 | proc _empty_array {name} { |
1558 | upvar $name the_array | |
1559 | ||
1560 | catch {unset the_array} | |
1561 | set the_array(_) {} | |
1562 | unset the_array(_) | |
1563 | } | |
1564 | ||
dc294be5 TT |
1565 | # Emit a .gnu_debugaltlink section with the given file name and |
1566 | # build-id. The buildid should be represented as a hexadecimal | |
1567 | # string, like "ffeeddcc". | |
1568 | proc gnu_debugaltlink {filename buildid} { | |
1569 | _defer_output .gnu_debugaltlink { | |
1570 | _op .ascii [_quote $filename] | |
1571 | foreach {a b} [split $buildid {}] { | |
1572 | _op .byte 0x$a$b | |
1573 | } | |
1574 | } | |
1575 | } | |
1576 | ||
1577 | proc _note {type name hexdata} { | |
1578 | set namelen [expr [string length $name] + 1] | |
1579 | ||
1580 | # Name size. | |
1581 | _op .4byte $namelen | |
1582 | # Data size. | |
1583 | _op .4byte [expr [string length $hexdata] / 2] | |
1584 | # Type. | |
1585 | _op .4byte $type | |
1586 | # The name. | |
1587 | _op .ascii [_quote $name] | |
1588 | # Alignment. | |
1589 | set align 2 | |
340c2830 | 1590 | set total [expr {($namelen + (1 << $align) - 1) & -(1 << $align)}] |
dc294be5 TT |
1591 | for {set i $namelen} {$i < $total} {incr i} { |
1592 | _op .byte 0 | |
1593 | } | |
1594 | # The data. | |
1595 | foreach {a b} [split $hexdata {}] { | |
1596 | _op .byte 0x$a$b | |
1597 | } | |
1598 | } | |
1599 | ||
1600 | # Emit a note section holding the given build-id. | |
1601 | proc build_id {buildid} { | |
1602 | _defer_output {.note.gnu.build-id a note} { | |
1603 | # From elf/common.h. | |
1604 | set NT_GNU_BUILD_ID 3 | |
1605 | ||
1606 | _note $NT_GNU_BUILD_ID GNU $buildid | |
1607 | } | |
1608 | } | |
1609 | ||
1d24041a TT |
1610 | # The top-level interface to the DWARF assembler. |
1611 | # FILENAME is the name of the file where the generated assembly | |
1612 | # code is written. | |
1613 | # BODY is Tcl code to emit the assembly. It is evaluated via | |
1614 | # "eval" -- not uplevel as you might expect, because it is | |
1615 | # important to run the body in the Dwarf namespace. | |
1616 | # | |
1617 | # A typical invocation is something like: | |
1618 | # Dwarf::assemble $file { | |
1619 | # cu 0 2 8 { | |
1620 | # compile_unit { | |
1621 | # ... | |
1622 | # } | |
1623 | # } | |
1624 | # cu 0 2 8 { | |
1625 | # ... | |
1626 | # } | |
1627 | # } | |
1628 | proc assemble {filename body} { | |
1629 | variable _initialized | |
1630 | variable _output_file | |
1631 | variable _deferred_output | |
1632 | variable _defer | |
1633 | variable _label_num | |
1634 | variable _strings | |
d65f0a9c | 1635 | variable _cu_count |
6ef37366 PM |
1636 | variable _line_count |
1637 | variable _line_saw_file | |
28d2bfb9 AB |
1638 | variable _line_saw_program |
1639 | variable _line_header_end_label | |
1640 | variable _debug_ranges_64_bit | |
1d24041a TT |
1641 | |
1642 | if {!$_initialized} { | |
1643 | _read_constants | |
1644 | set _initialized 1 | |
1645 | } | |
1646 | ||
1647 | set _output_file [open $filename w] | |
1648 | set _cu_count 0 | |
1649 | _empty_array _deferred_output | |
1650 | set _defer "" | |
1651 | set _label_num 0 | |
1652 | _empty_array _strings | |
1653 | ||
6ef37366 PM |
1654 | set _line_count 0 |
1655 | set _line_saw_file 0 | |
28d2bfb9 AB |
1656 | set _line_saw_program 0 |
1657 | set _debug_ranges_64_bit [is_64_target] | |
6ef37366 | 1658 | |
1d24041a TT |
1659 | # Not "uplevel" here, because we want to evaluate in this |
1660 | # namespace. This is somewhat bad because it means we can't | |
1661 | # readily refer to outer variables. | |
1662 | eval $body | |
1663 | ||
1664 | _write_deferred_output | |
1665 | ||
1666 | catch {close $_output_file} | |
1667 | set _output_file {} | |
1668 | } | |
1669 | } |