1 # Copyright 2010-2015 Free Software Foundation, Inc.
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.
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.
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/>.
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*]} {
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.
38 # Current restrictions:
39 # - only supports one source file
40 # - cannot be run on remote hosts
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."
48 error "Remote hosts are not supported."
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]
60 set result [gdb_compile $source_file $object_file object $options]
61 if { "$result" != "" } {
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"
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"
81 set result [gdb_compile $object_file $executable executable {nodebug}]
82 if { "$result" != "" } {
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:
96 # asm ("main_label: .globl main_label");
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:
104 # asm ("func_start: .globl func_start");
105 # static void func (void) {}
106 # asm ("func_end: .globl func_end");
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
112 # asm ("func_start: .globl func_start");
113 # asm ("func_end: .globl func_end");
114 # static void func (void) {}
117 proc function_range { func src } {
118 global decimal gdb_prompt
120 set exe [standard_temp_file func_addr[pid].x]
122 gdb_compile $src $exe executable {debug}
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)
138 # Compute the function 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)
148 # Compute the size of the last instruction.
149 if { $func_length == 0 } then {
150 set func_pattern "$func"
152 set func_pattern "$func\\+$func_length"
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)
160 set func_length [expr $func_length + $end - $start]
164 return [list "${func}_label - $func_label_offset" $func_length]
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.
173 # Exported functions are documented at their definition.
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.
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.)
187 # Each tag procedure is defined like:
189 # proc DW_TAG_mumble {{attrs {}} {children {}}} { ... }
191 # ATTRS is an optional list of attributes.
192 # It is run through 'subst' in the caller's context before processing.
194 # Each attribute in the list has one of two forms:
196 # 2. { NAME VALUE FORM }
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.
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:
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.
210 # - MACRO_AT_func { FUNC FILE }
211 # It is substituted by DW_AT_name with FUNC and MACRO_AT_range.
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.
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.
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 # * Otherwise, VALUE is taken to be a string and DW_FORM_string is
233 # used. In order to prevent bugs where a numeric value is given but
234 # no form is specified, it is an error if the value looks like a number
235 # (using Tcl's "string is integer") and no form is provided.
236 # More form-guessing functionality may be added.
238 # CHILDREN is just Tcl code that can be used to define child DIEs. It
239 # is evaluated in the caller's context.
241 # Currently this code is missing nice support for CFA handling, and
242 # probably other things as well.
244 namespace eval Dwarf {
245 # True if the module has been initialized.
246 variable _initialized 0
248 # Constants from dwarf2.h.
252 # DW_FORM short names.
257 # The current output file.
258 variable _output_file
260 # Note: The _cu_ values here also apply to type units (TUs).
261 # Think of a TU as a special kind of CU.
266 # The current CU's base label.
269 # The current CU's version.
272 # The current CU's address size.
273 variable _cu_addr_size
274 # The current CU's offset size.
275 variable _cu_offset_size
277 # Label generation number.
280 # The deferred output array. The index is the section name; the
281 # contents hold the data for that section.
282 variable _deferred_output
284 # If empty, we should write directly to the output file.
285 # Otherwise, this is the name of a section to write to.
288 # The abbrev section. Typically .debug_abbrev but can be .debug_abbrev.dwo
290 variable _abbrev_section
292 # The next available abbrev number in the current CU's abbrev
296 # The string table for this assembly. The key is the string; the
297 # value is the label for that string.
300 proc _process_one_constant {name value} {
306 set _constants($name) $value
308 if {![regexp "^DW_(\[A-Z\]+)_(\[A-Za-z0-9_\]+)$" $name \
309 ignore prefix name2]} {
310 error "non-matching name: $name"
313 if {$name2 == "lo_user" || $name2 == "hi_user"} {
317 # We only try to shorten some very common things.
319 switch -exact -- $prefix {
321 # Create two procedures for the tag. These call
322 # _handle_DW_TAG with the full tag name baked in; this
323 # does all the actual work.
324 proc $name {{attrs {}} {children {}}} \
325 "_handle_DW_TAG $name \$attrs \$children"
327 # Filter out ones that are known to clash.
328 if {$name2 == "variable" || $name2 == "namespace"} {
329 set name2 "tag_$name2"
332 if {[info commands $name2] != {}} {
333 error "duplicate proc name: from $name"
336 proc $name2 {{attrs {}} {children {}}} \
337 "_handle_DW_TAG $name \$attrs \$children"
341 set _AT($name2) $name
345 set _FORM($name2) $name
349 set _OP($name2) $name
358 proc _read_constants {} {
359 global srcdir hex decimal
362 # DWARF name-matching regexp.
363 set dwrx "DW_\[a-zA-Z0-9_\]+"
367 set fd [open [file join $srcdir .. .. include dwarf2.h]]
370 if {[regexp -- "^${ws}($dwrx)${ws}=${ws}($hex|$decimal),?$" \
371 $line ignore name value ignore2]} {
372 _process_one_constant $name $value
377 set fd [open [file join $srcdir .. .. include dwarf2.def]]
381 "^DW_\[A-Z_\]+${ws}\\(($dwrx),${ws}($hex|$decimal)\\)$" \
382 $line ignore name value ignore2]} {
383 _process_one_constant $name $value
388 set _constants(SPECIAL_expr) $_constants(DW_FORM_block)
391 proc _quote {string} {
393 return "\"${string}\\0\""
396 proc _nz_quote {string} {
397 # For now, no quoting is done.
398 return "\"${string}\""
401 proc _handle_DW_FORM {form value} {
402 switch -exact -- $form {
404 _op .ascii [_quote $value]
407 DW_FORM_flag_present {
408 # We don't need to emit anything.
417 variable _cu_offset_size
419 variable _cu_addr_size
421 if {$_cu_version == 2} {
422 set size $_cu_addr_size
424 set size $_cu_offset_size
427 _op .${size}byte $value
446 variable _cu_addr_size
448 _op .${_cu_addr_size}byte $value
464 variable _cu_offset_size
466 if {![info exists _strings($value)]} {
467 set _strings($value) [new_label strp]
468 _defer_output .debug_string {
469 define_label $_strings($value)
470 _op .ascii [_quote $value]
474 _op .${_cu_offset_size}byte $_strings($value) "strp: $value"
478 set l1 [new_label "expr_start"]
479 set l2 [new_label "expr_end"]
480 _op .uleb128 "$l2 - $l1" "expression"
487 set len [string length $value]
489 error "DW_FORM_block1 length too long"
492 _op .ascii [_nz_quote $value]
505 DW_FORM_GNU_addr_index -
506 DW_FORM_GNU_str_index -
507 DW_FORM_GNU_ref_alt -
508 DW_FORM_GNU_strp_alt -
511 error "unhandled form $form"
516 proc _guess_form {value varname} {
517 upvar $varname new_value
519 switch -exact -- [string range $value 0 0] {
521 # Constant reference.
524 set new_value $_constants([string range $value 1 end])
533 set new_value "[string range $value 1 end] - $_cu_label"
539 return DW_FORM_string
544 # Map NAME to its canonical form.
545 proc _map_name {name ary} {
548 if {[info exists ${ary}($name)]} {
549 set name [set ${ary}($name)]
555 proc _handle_attribute { attr_name attr_value attr_form } {
556 variable _abbrev_section
559 _handle_DW_FORM $attr_form $attr_value
561 _defer_output $_abbrev_section {
562 _op .uleb128 $_constants($attr_name) $attr_name
563 _op .uleb128 $_constants($attr_form) $attr_form
567 # Handle macro attribute MACRO_AT_range.
569 proc _handle_macro_at_range { attr_value } {
570 if {[llength $attr_value] != 2} {
571 error "usage: MACRO_AT_range { func file }"
574 set func [lindex $attr_value 0]
575 set src [lindex $attr_value 1]
576 set result [function_range $func $src]
578 _handle_attribute DW_AT_low_pc [lindex $result 0] \
580 _handle_attribute DW_AT_high_pc \
581 "[lindex $result 0] + [lindex $result 1]" DW_FORM_addr
584 # Handle macro attribute MACRO_AT_func.
586 proc _handle_macro_at_func { attr_value } {
587 if {[llength $attr_value] != 2} {
588 error "usage: MACRO_AT_func { func file }"
590 _handle_attribute DW_AT_name [lindex $attr_value 0] DW_FORM_string
591 _handle_macro_at_range $attr_value
594 proc _handle_DW_TAG {tag_name {attrs {}} {children {}}} {
595 variable _abbrev_section
599 set has_children [expr {[string length $children] > 0}]
600 set my_abbrev [incr _abbrev_num]
602 # We somewhat wastefully emit a new abbrev entry for each tag.
603 # There's no reason for this other than laziness.
604 _defer_output $_abbrev_section {
605 _op .uleb128 $my_abbrev "Abbrev start"
606 _op .uleb128 $_constants($tag_name) $tag_name
607 _op .byte $has_children "has_children"
610 _op .uleb128 $my_abbrev "Abbrev ($tag_name)"
612 foreach attr $attrs {
613 set attr_name [_map_name [lindex $attr 0] _AT]
614 set attr_value [uplevel 2 [list subst [lindex $attr 1]]]
616 if { [string equal "MACRO_AT_func" $attr_name] } {
617 _handle_macro_at_func $attr_value
618 } elseif { [string equal "MACRO_AT_range" $attr_name] } {
619 _handle_macro_at_range $attr_value
621 if {[llength $attr] > 2} {
622 set attr_form [lindex $attr 2]
624 # If the value looks like an integer, a form is required.
625 if [string is integer $attr_value] {
626 error "Integer value requires a form"
628 set attr_form [_guess_form $attr_value attr_value]
630 set attr_form [_map_name $attr_form _FORM]
632 _handle_attribute $attr_name $attr_value $attr_form
636 _defer_output $_abbrev_section {
638 _op .byte 0x0 Terminator
639 _op .byte 0x0 Terminator
645 # Terminate children.
646 _op .byte 0x0 "Terminate children"
650 proc _emit {string} {
651 variable _output_file
653 variable _deferred_output
656 puts $_output_file $string
658 append _deferred_output($_defer) ${string}\n
662 proc _section {name {flags ""} {type ""}} {
663 if {$flags == "" && $type == ""} {
664 _emit " .section $name"
665 } elseif {$type == ""} {
666 _emit " .section $name, \"$flags\""
668 _emit " .section $name, \"$flags\", %$type"
672 # SECTION_SPEC is a list of arguments to _section.
673 proc _defer_output {section_spec body} {
675 variable _deferred_output
677 set old_defer $_defer
678 set _defer [lindex $section_spec 0]
680 if {![info exists _deferred_output($_defer)]} {
681 set _deferred_output($_defer) ""
682 eval _section $section_spec
687 set _defer $old_defer
690 proc _defer_to_string {body} {
692 variable _deferred_output
694 set old_defer $_defer
697 set _deferred_output($_defer) ""
701 set result $_deferred_output($_defer)
702 unset _deferred_output($_defer)
704 set _defer $old_defer
708 proc _write_deferred_output {} {
709 variable _output_file
710 variable _deferred_output
712 foreach section [array names _deferred_output] {
713 # The data already has a newline.
714 puts -nonewline $_output_file $_deferred_output($section)
718 unset _deferred_output
721 proc _op {name value {comment ""}} {
722 set text " ${name} ${value}"
723 if {$comment != ""} {
724 # Try to make stuff line up nicely.
725 while {[string length $text] < 40} {
728 append text "/* ${comment} */"
733 proc _compute_label {name} {
737 # Return a name suitable for use as a label. If BASE_NAME is
738 # specified, it is incorporated into the label name; this is to
739 # make debugging the generated assembler easier. If BASE_NAME is
740 # not specified a generic default is used. This proc does not
741 # define the label; see 'define_label'. 'new_label' attempts to
742 # ensure that label names are unique.
743 proc new_label {{base_name label}} {
746 return [_compute_label ${base_name}[incr _label_num]]
749 # Define a label named NAME. Ordinarily, NAME comes from a call
750 # to 'new_label', but this is not required.
751 proc define_label {name} {
755 # Declare a global label. This is typically used to refer to
756 # labels defined in other files, for example a function defined in
764 # A higher-level interface to label handling.
766 # ARGS is a list of label descriptors. Each one is either a
767 # single element, or a list of two elements -- a name and some
768 # text. For each descriptor, 'new_label' is invoked. If the list
769 # form is used, the second element in the list is passed as an
770 # argument. The label name is used to define a variable in the
771 # enclosing scope; this can be used to refer to the label later.
772 # The label name is also used to define a new proc whose name is
773 # the label name plus a trailing ":". This proc takes a body as
774 # an argument and can be used to define the label at that point;
775 # then the body, if any, is evaluated in the caller's context.
779 # declare_labels int_label
780 # something { ... $int_label } ;# refer to the label
781 # int_label: constant { ... } ;# define the label
782 proc declare_labels {args} {
784 set name [lindex $arg 0]
785 set text [lindex $arg 1]
787 upvar $name label_var
789 set label_var [new_label]
791 set label_var [new_label $text]
794 proc ${name}: {args} [format {
801 # This is a miniature assembler for location expressions. It is
802 # suitable for use in the attributes to a DIE. Its output is
803 # prefixed with "=" to make it automatically use DW_FORM_block.
804 # BODY is split by lines, and each line is taken to be a list.
805 # (FIXME should use 'info complete' here.)
806 # Each list's first element is the opcode, either short or long
807 # forms are accepted.
808 # FIXME argument handling
810 proc _location {body} {
813 variable _cu_addr_size
814 variable _cu_offset_size
816 foreach line [split $body \n] {
817 # Ignore blank lines, and allow embedded comments.
818 if {[lindex $line 0] == "" || [regexp -- {^[ \t]*#} $line]} {
821 set opcode [_map_name [lindex $line 0] _OP]
822 _op .byte $_constants($opcode) $opcode
824 switch -exact -- $opcode {
826 _op .${_cu_addr_size}byte [lindex $line 1]
832 _op .byte [lindex $line 1]
837 _op .2byte [lindex $line 1]
842 _op .4byte [lindex $line 1]
847 _op .8byte [lindex $line 1]
851 _op .uleb128 [lindex $line 1]
854 _op .sleb128 [lindex $line 1]
858 _op .uleb128 [lindex $line 1]
862 _op .uleb128 [lindex $line 1]
866 _op .uleb128 [lindex $line 1]
867 _op .uleb128 [lindex $line 2]
872 _op .2byte [lindex $line 1]
875 DW_OP_GNU_implicit_pointer {
876 if {[llength $line] != 3} {
877 error "usage: DW_OP_GNU_implicit_pointer LABEL OFFSET"
880 # Here label is a section offset.
881 set label [lindex $line 1]
882 _op .${_cu_offset_size}byte $label
883 _op .sleb128 [lindex $line 2]
887 if {[llength $line] != 2} {
888 error "usage: DW_OP_deref_size SIZE"
891 _op .byte [lindex $line 1]
895 if {[llength $line] > 1} {
896 error "Unimplemented: operands in location for $opcode"
904 # OPTIONS is a list with an even number of elements containing
905 # option-name and option-value pairs.
906 # Current options are:
907 # is_64 0|1 - boolean indicating if you want to emit 64-bit DWARF
908 # default = 0 (32-bit)
909 # version n - DWARF version number to emit
911 # addr_size n - the size of addresses, 32, 64, or default
913 # fission 0|1 - boolean indicating if generating Fission debug info
915 # BODY is Tcl code that emits the DIEs which make up the body of
916 # the CU. It is evaluated in the caller's context.
917 proc cu {options body} {
919 variable _abbrev_section
923 variable _cu_addr_size
924 variable _cu_offset_size
926 # Establish the defaults.
929 set _cu_addr_size default
931 set section ".debug_info"
932 set _abbrev_section ".debug_abbrev"
934 foreach { name value } $options {
935 switch -exact -- $name {
936 is_64 { set is_64 $value }
937 version { set _cu_version $value }
938 addr_size { set _cu_addr_size $value }
939 fission { set fission $value }
940 default { error "unknown option $name" }
943 if {$_cu_addr_size == "default"} {
944 if {[is_64_target]} {
950 set _cu_offset_size [expr { $is_64 ? 8 : 4 }]
952 set section ".debug_info.dwo"
953 set _abbrev_section ".debug_abbrev.dwo"
958 set cu_num [incr _cu_count]
959 set my_abbrevs [_compute_label "abbrev${cu_num}_begin"]
962 set _cu_label [_compute_label "cu${cu_num}_begin"]
963 set start_label [_compute_label "cu${cu_num}_start"]
964 set end_label [_compute_label "cu${cu_num}_end"]
966 define_label $_cu_label
968 _op .4byte 0xffffffff
969 _op .8byte "$end_label - $start_label"
971 _op .4byte "$end_label - $start_label"
973 define_label $start_label
974 _op .2byte $_cu_version Version
975 _op .${_cu_offset_size}byte $my_abbrevs Abbrevs
976 _op .byte $_cu_addr_size "Pointer size"
978 _defer_output $_abbrev_section {
979 define_label $my_abbrevs
984 _defer_output $_abbrev_section {
985 # Emit the terminator.
986 _op .byte 0x0 Terminator
987 _op .byte 0x0 Terminator
990 define_label $end_label
994 # OPTIONS is a list with an even number of elements containing
995 # option-name and option-value pairs.
996 # Current options are:
997 # is_64 0|1 - boolean indicating if you want to emit 64-bit DWARF
998 # default = 0 (32-bit)
999 # version n - DWARF version number to emit
1001 # addr_size n - the size of addresses, 32, 64, or default
1003 # fission 0|1 - boolean indicating if generating Fission debug info
1005 # SIGNATURE is the 64-bit signature of the type.
1006 # TYPE_LABEL is the label of the type defined by this TU,
1007 # or "" if there is no type (i.e., type stubs in Fission).
1008 # BODY is Tcl code that emits the DIEs which make up the body of
1009 # the TU. It is evaluated in the caller's context.
1010 proc tu {options signature type_label body} {
1012 variable _abbrev_section
1013 variable _abbrev_num
1015 variable _cu_version
1016 variable _cu_addr_size
1017 variable _cu_offset_size
1019 # Establish the defaults.
1022 set _cu_addr_size default
1024 set section ".debug_types"
1025 set _abbrev_section ".debug_abbrev"
1027 foreach { name value } $options {
1028 switch -exact -- $name {
1029 is_64 { set is_64 $value }
1030 version { set _cu_version $value }
1031 addr_size { set _cu_addr_size $value }
1032 fission { set fission $value }
1033 default { error "unknown option $name" }
1036 if {$_cu_addr_size == "default"} {
1037 if {[is_64_target]} {
1043 set _cu_offset_size [expr { $is_64 ? 8 : 4 }]
1045 set section ".debug_types.dwo"
1046 set _abbrev_section ".debug_abbrev.dwo"
1051 set cu_num [incr _cu_count]
1052 set my_abbrevs [_compute_label "abbrev${cu_num}_begin"]
1055 set _cu_label [_compute_label "cu${cu_num}_begin"]
1056 set start_label [_compute_label "cu${cu_num}_start"]
1057 set end_label [_compute_label "cu${cu_num}_end"]
1059 define_label $_cu_label
1061 _op .4byte 0xffffffff
1062 _op .8byte "$end_label - $start_label"
1064 _op .4byte "$end_label - $start_label"
1066 define_label $start_label
1067 _op .2byte $_cu_version Version
1068 _op .${_cu_offset_size}byte $my_abbrevs Abbrevs
1069 _op .byte $_cu_addr_size "Pointer size"
1070 _op .8byte $signature Signature
1071 if { $type_label != "" } {
1072 uplevel declare_labels $type_label
1073 upvar $type_label my_type_label
1075 _op .8byte "$my_type_label - $_cu_label"
1077 _op .4byte "$my_type_label - $_cu_label"
1087 _defer_output $_abbrev_section {
1088 define_label $my_abbrevs
1093 _defer_output $_abbrev_section {
1094 # Emit the terminator.
1095 _op .byte 0x0 Terminator
1096 _op .byte 0x0 Terminator
1099 define_label $end_label
1102 proc _empty_array {name} {
1103 upvar $name the_array
1105 catch {unset the_array}
1110 # Emit a .gnu_debugaltlink section with the given file name and
1111 # build-id. The buildid should be represented as a hexadecimal
1112 # string, like "ffeeddcc".
1113 proc gnu_debugaltlink {filename buildid} {
1114 _defer_output .gnu_debugaltlink {
1115 _op .ascii [_quote $filename]
1116 foreach {a b} [split $buildid {}] {
1122 proc _note {type name hexdata} {
1123 set namelen [expr [string length $name] + 1]
1128 _op .4byte [expr [string length $hexdata] / 2]
1132 _op .ascii [_quote $name]
1135 set total [expr {($namelen + (1 << $align) - 1) & (-1 << $align)}]
1136 for {set i $namelen} {$i < $total} {incr i} {
1140 foreach {a b} [split $hexdata {}] {
1145 # Emit a note section holding the given build-id.
1146 proc build_id {buildid} {
1147 _defer_output {.note.gnu.build-id a note} {
1148 # From elf/common.h.
1149 set NT_GNU_BUILD_ID 3
1151 _note $NT_GNU_BUILD_ID GNU $buildid
1155 # The top-level interface to the DWARF assembler.
1156 # FILENAME is the name of the file where the generated assembly
1158 # BODY is Tcl code to emit the assembly. It is evaluated via
1159 # "eval" -- not uplevel as you might expect, because it is
1160 # important to run the body in the Dwarf namespace.
1162 # A typical invocation is something like:
1163 # Dwarf::assemble $file {
1173 proc assemble {filename body} {
1174 variable _initialized
1175 variable _output_file
1176 variable _deferred_output
1182 if {!$_initialized} {
1187 set _output_file [open $filename w]
1189 _empty_array _deferred_output
1192 _empty_array _strings
1194 # Not "uplevel" here, because we want to evaluate in this
1195 # namespace. This is somewhat bad because it means we can't
1196 # readily refer to outer variables.
1199 _write_deferred_output
1201 catch {close $_output_file}