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