1 # Copyright 2010-2021 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 powerpc-*-eabi*]} {
31 # Build an executable from a fission-based .S file.
32 # This handles the extra work of splitting the .o into non-dwo and dwo
33 # pieces, making sure the .dwo is available if we're using cc-with-tweaks.sh
34 # to build a .dwp file.
35 # The arguments and results are the same as for build_executable.
37 # Current restrictions:
38 # - only supports one source file
39 # - cannot be run on remote hosts
41 proc build_executable_from_fission_assembler { testname executable sources options } {
42 verbose -log "build_executable_from_fission_assembler $testname $executable $sources $options"
43 if { [llength $sources] != 1 } {
44 error "Only one source file supported."
47 error "Remote hosts are not supported."
51 set source_file ${srcdir}/${subdir}/${sources}
52 set root_name [file rootname [file tail $source_file]]
53 set output_base [standard_output_file $root_name]
54 set object_file ${output_base}.o
55 set dwo_file ${output_base}.dwo
56 set object_options "object $options"
57 set objcopy [gdb_find_objcopy]
59 set result [gdb_compile $source_file $object_file object $options]
60 if { "$result" != "" } {
64 set command "$objcopy --extract-dwo $object_file $dwo_file"
65 verbose -log "Executing $command"
66 set result [catch "exec $command" output]
67 verbose -log "objcopy --extract-dwo output: $output"
72 set command "$objcopy --strip-dwo $object_file"
73 verbose -log "Executing $command"
74 set result [catch "exec $command" output]
75 verbose -log "objcopy --strip-dwo output: $output"
80 set result [gdb_compile $object_file $executable executable $options]
81 if { "$result" != "" } {
88 # Return a list of expressions about function FUNC's address and length.
89 # The first expression is the address of function FUNC, and the second
90 # one is FUNC's length. SRC is the source file having function FUNC.
91 # An internal label ${func}_label must be defined inside FUNC:
95 # asm ("main_label: .globl main_label");
99 # This label is needed to compute the start address of function FUNC.
100 # If the compiler is gcc, we can do the following to get function start
101 # and end address too:
103 # asm ("func_start: .globl func_start");
104 # static void func (void) {}
105 # asm ("func_end: .globl func_end");
107 # however, this isn't portable, because other compilers, such as clang,
108 # may not guarantee the order of global asms and function. The code
111 # asm ("func_start: .globl func_start");
112 # asm ("func_end: .globl func_end");
113 # static void func (void) {}
116 proc function_range { func src {options {debug}} } {
117 global decimal gdb_prompt
119 set exe [standard_temp_file func_addr[pid].x]
121 gdb_compile $src $exe executable $options
127 # Compute the label offset, and we can get the function start address
128 # by "${func}_label - $func_label_offset".
129 set func_label_offset ""
130 set test "p ${func}_label - ${func}"
131 gdb_test_multiple $test $test {
132 -re ".* = ($decimal)\r\n$gdb_prompt $" {
133 set func_label_offset $expect_out(1,string)
137 # Compute the function length.
140 set test "disassemble $func"
141 gdb_test_multiple $test $test {
142 -re ".*$hex <\\+($decimal)>:\[^\r\n\]+\r\nEnd of assembler dump\.\r\n$gdb_prompt $" {
143 set func_length $expect_out(1,string)
147 # Compute the size of the last instruction.
148 if { $func_length == 0 } then {
149 set func_pattern "$func"
151 set func_pattern "$func\\+$func_length"
153 set test "x/2i $func+$func_length"
154 gdb_test_multiple $test $test {
155 -re ".*($hex) <$func_pattern>:\[^\r\n\]+\r\n\[ \]+($hex).*\.\r\n$gdb_prompt $" {
156 set start $expect_out(1,string)
157 set end $expect_out(2,string)
159 set func_length [expr $func_length + $end - $start]
163 return [list "${func}_label - $func_label_offset" $func_length]
166 # Extract the start, length, and end for function called NAME and
167 # create suitable variables in the callers scope.
168 proc get_func_info { name {options {debug}} } {
169 global srcdir subdir srcfile
171 upvar 1 "${name}_start" func_start
172 upvar 1 "${name}_len" func_len
173 upvar 1 "${name}_end" func_end
175 lassign [function_range ${name} \
176 [list ${srcdir}/${subdir}/$srcfile] \
179 set func_end "$func_start + $func_len"
184 # All the variables in this namespace are private to the
185 # implementation. Also, any procedure whose name starts with "_" is
186 # private as well. Do not use these.
188 # Exported functions are documented at their definition.
190 # In addition to the hand-written functions documented below, this
191 # module automatically generates a function for each DWARF tag. For
192 # most tags, two forms are made: a full name, and one with the
193 # "DW_TAG_" prefix stripped. For example, you can use either
194 # 'DW_TAG_compile_unit' or 'compile_unit' interchangeably.
196 # There are two exceptions to this rule: DW_TAG_variable and
197 # DW_TAG_namespace. For these, the full name must always be used,
198 # as the short name conflicts with Tcl builtins. (Should future
199 # versions of Tcl or DWARF add more conflicts, this list will grow.
200 # If you want to be safe you should always use the full names.)
202 # Each tag procedure is defined like:
204 # proc DW_TAG_mumble {{attrs {}} {children {}}} { ... }
206 # ATTRS is an optional list of attributes.
207 # It is run through 'subst' in the caller's context before processing.
209 # Each attribute in the list has one of two forms:
211 # 2. { NAME VALUE FORM }
213 # In each case, NAME is the attribute's name.
214 # This can either be the full name, like 'DW_AT_name', or a shortened
215 # name, like 'name'. These are fully equivalent.
217 # Besides DWARF standard attributes, assembler supports 'macro' attribute
218 # which will be substituted by one or more standard or macro attributes.
219 # supported macro attributes are:
221 # - MACRO_AT_range { FUNC }
222 # It is substituted by DW_AT_low_pc and DW_AT_high_pc with the start and
223 # end address of function FUNC in file $srcdir/$subdir/$srcfile.
225 # - MACRO_AT_func { FUNC }
226 # It is substituted by DW_AT_name with FUNC and MACRO_AT_range.
228 # If FORM is given, it should name a DW_FORM_ constant.
229 # This can either be the short form, like 'DW_FORM_addr', or a
230 # shortened version, like 'addr'. If the form is given, VALUE
231 # is its value; see below. In some cases, additional processing
232 # is done; for example, DW_FORM_strp manages the .debug_str
233 # section automatically.
235 # If FORM is 'SPECIAL_expr', then VALUE is treated as a location
236 # expression. The effective form is then DW_FORM_block or DW_FORM_exprloc
237 # for DWARF version >= 4, and VALUE is passed to the (internal)
238 # '_location' proc to be translated.
239 # This proc implements a miniature DW_OP_ assembler.
241 # If FORM is not given, it is guessed:
242 # * If VALUE starts with the "@" character, the rest of VALUE is
243 # looked up as a DWARF constant, and DW_FORM_sdata is used. For
244 # example, '@DW_LANG_c89' could be used.
245 # * If VALUE starts with the ":" character, then it is a label
246 # reference. The rest of VALUE is taken to be the name of a label,
247 # and DW_FORM_ref4 is used. See 'new_label' and 'define_label'.
248 # * If VALUE starts with the "%" character, then it is a label
249 # reference too, but DW_FORM_ref_addr is used.
250 # * Otherwise, if the attribute name has a default form (f.i. DW_FORM_addr for
251 # DW_AT_low_pc), then that one is used.
252 # * Otherwise, an error is reported. Either specify a form explicitly, or
253 # add a default for the the attribute name in _default_form.
255 # CHILDREN is just Tcl code that can be used to define child DIEs. It
256 # is evaluated in the caller's context.
258 # Currently this code is missing nice support for CFA handling, and
259 # probably other things as well.
261 namespace eval Dwarf {
262 # True if the module has been initialized.
263 variable _initialized 0
265 # Constants from dwarf2.h.
269 # DW_FORM short names.
274 # The current output file.
275 variable _output_file
277 # Note: The _cu_ values here also apply to type units (TUs).
278 # Think of a TU as a special kind of CU.
283 # The current CU's base label.
286 # The current CU's version.
289 # The current CU's address size.
290 variable _cu_addr_size
291 # The current CU's offset size.
292 variable _cu_offset_size
294 # Label generation number.
297 # The deferred output array. The index is the section name; the
298 # contents hold the data for that section.
299 variable _deferred_output
301 # If empty, we should write directly to the output file.
302 # Otherwise, this is the name of a section to write to.
305 # The abbrev section. Typically .debug_abbrev but can be .debug_abbrev.dwo
307 variable _abbrev_section
309 # The next available abbrev number in the current CU's abbrev
313 # The string table for this assembly. The key is the string; the
314 # value is the label for that string.
317 # Current .debug_line unit count.
320 # Whether a file_name entry was seen.
321 variable _line_saw_file
323 # Whether a line table program has been seen.
324 variable _line_saw_program
326 # A Label for line table header generation.
327 variable _line_header_end_label
329 # The address size for debug ranges section.
330 variable _debug_ranges_64_bit
332 proc _process_one_constant {name value} {
338 set _constants($name) $value
340 if {![regexp "^DW_(\[A-Z\]+)_(\[A-Za-z0-9_\]+)$" $name \
341 ignore prefix name2]} {
342 error "non-matching name: $name"
345 if {$name2 == "lo_user" || $name2 == "hi_user"} {
349 # We only try to shorten some very common things.
351 switch -exact -- $prefix {
353 # Create two procedures for the tag. These call
354 # _handle_DW_TAG with the full tag name baked in; this
355 # does all the actual work.
356 proc $name {{attrs {}} {children {}}} \
357 "_handle_DW_TAG $name \$attrs \$children"
359 # Filter out ones that are known to clash.
360 if {$name2 == "variable" || $name2 == "namespace"} {
361 set name2 "tag_$name2"
364 if {[info commands $name2] != {}} {
365 error "duplicate proc name: from $name"
368 proc $name2 {{attrs {}} {children {}}} \
369 "_handle_DW_TAG $name \$attrs \$children"
373 set _AT($name2) $name
377 set _FORM($name2) $name
381 set _OP($name2) $name
390 proc _read_constants {} {
391 global srcdir hex decimal
393 # DWARF name-matching regexp.
394 set dwrx "DW_\[a-zA-Z0-9_\]+"
398 set fd [open [file join $srcdir .. .. include dwarf2.h]]
401 if {[regexp -- "^${ws}($dwrx)${ws}=${ws}($hex|$decimal),?$" \
402 $line ignore name value ignore2]} {
403 _process_one_constant $name $value
408 set fd [open [file join $srcdir .. .. include dwarf2.def]]
412 "^DW_\[A-Z_\]+${ws}\\(($dwrx),${ws}($hex|$decimal)\\)$" \
413 $line ignore name value ignore2]} {
414 _process_one_constant $name $value
420 proc _quote {string} {
422 return "\"${string}\\0\""
425 proc _nz_quote {string} {
426 # For now, no quoting is done.
427 return "\"${string}\""
430 proc _handle_DW_FORM {form value} {
431 switch -exact -- $form {
433 _op .ascii [_quote $value]
436 DW_FORM_flag_present {
437 # We don't need to emit anything.
446 variable _cu_offset_size
448 variable _cu_addr_size
450 if {$_cu_version == 2} {
451 set size $_cu_addr_size
453 set size $_cu_offset_size
456 _op .${size}byte $value
459 DW_FORM_GNU_ref_alt -
460 DW_FORM_GNU_strp_alt -
462 variable _cu_offset_size
463 _op .${_cu_offset_size}byte $value
484 variable _cu_addr_size
486 _op .${_cu_addr_size}byte $value
506 variable _cu_offset_size
508 if {![info exists _strings($value)]} {
509 set _strings($value) [new_label strp]
510 _defer_output .debug_str {
511 define_label $_strings($value)
512 _op .ascii [_quote $value]
516 _op .${_cu_offset_size}byte $_strings($value) "strp: $value"
521 variable _cu_addr_size
522 variable _cu_offset_size
524 set l1 [new_label "expr_start"]
525 set l2 [new_label "expr_end"]
526 _op .uleb128 "$l2 - $l1" "expression"
528 _location $value $_cu_version $_cu_addr_size $_cu_offset_size
533 set len [string length $value]
535 error "DW_FORM_block1 length too long"
538 _op .ascii [_nz_quote $value]
556 DW_FORM_GNU_addr_index -
557 DW_FORM_GNU_str_index -
560 error "unhandled form $form"
565 proc _guess_form {value varname} {
566 upvar $varname new_value
568 switch -exact -- [string range $value 0 0] {
570 # Constant reference.
573 set new_value $_constants([string range $value 1 end])
582 set new_value "[string range $value 1 end] - $_cu_label"
588 # Label reference, an offset from .debug_info.
589 set new_value "[string range $value 1 end]"
591 return DW_FORM_ref_addr
600 proc _default_form { attr } {
601 switch -exact -- $attr {
608 DW_AT_MIPS_linkage_name -
610 return DW_FORM_string
616 # Map NAME to its canonical form.
617 proc _map_name {name ary} {
620 if {[info exists ${ary}($name)]} {
621 set name [set ${ary}($name)]
627 proc _handle_attribute { attr_name attr_value attr_form } {
628 variable _abbrev_section
632 _handle_DW_FORM $attr_form $attr_value
634 _defer_output $_abbrev_section {
635 if { $attr_form eq "SPECIAL_expr" } {
636 if { $_cu_version < 4 } {
637 set attr_form_comment "DW_FORM_block"
639 set attr_form_comment "DW_FORM_exprloc"
642 set attr_form_comment $attr_form
644 _op .uleb128 $_constants($attr_name) $attr_name
645 _op .uleb128 $_constants($attr_form) $attr_form_comment
649 # Handle macro attribute MACRO_AT_range.
651 proc _handle_macro_at_range { attr_value } {
652 if {[llength $attr_value] != 1} {
653 error "usage: MACRO_AT_range { func }"
656 set func [lindex $attr_value 0]
657 global srcdir subdir srcfile
658 set src ${srcdir}/${subdir}/${srcfile}
659 set result [function_range $func $src]
661 _handle_attribute DW_AT_low_pc [lindex $result 0] \
663 _handle_attribute DW_AT_high_pc \
664 "[lindex $result 0] + [lindex $result 1]" DW_FORM_addr
667 # Handle macro attribute MACRO_AT_func.
669 proc _handle_macro_at_func { attr_value } {
670 if {[llength $attr_value] != 1} {
671 error "usage: MACRO_AT_func { func file }"
673 _handle_attribute DW_AT_name [lindex $attr_value 0] DW_FORM_string
674 _handle_macro_at_range $attr_value
677 proc _handle_DW_TAG {tag_name {attrs {}} {children {}}} {
678 variable _abbrev_section
682 set has_children [expr {[string length $children] > 0}]
683 set my_abbrev [incr _abbrev_num]
685 # We somewhat wastefully emit a new abbrev entry for each tag.
686 # There's no reason for this other than laziness.
687 _defer_output $_abbrev_section {
688 _op .uleb128 $my_abbrev "Abbrev start"
689 _op .uleb128 $_constants($tag_name) $tag_name
690 _op .byte $has_children "has_children"
693 _op .uleb128 $my_abbrev "Abbrev ($tag_name)"
695 foreach attr $attrs {
696 set attr_name [_map_name [lindex $attr 0] _AT]
698 # When the length of ATTR is greater than 2, the last
699 # element of the list must be a form. The second through
700 # the penultimate elements are joined together and
701 # evaluated using subst. This allows constructs such as
702 # [gdb_target_symbol foo] to be used.
704 if {[llength $attr] > 2} {
705 set attr_value [uplevel 2 [list subst [join [lrange $attr 1 end-1]]]]
707 set attr_value [uplevel 2 [list subst [lindex $attr 1]]]
710 if { [string equal "MACRO_AT_func" $attr_name] } {
711 _handle_macro_at_func $attr_value
712 } elseif { [string equal "MACRO_AT_range" $attr_name] } {
713 _handle_macro_at_range $attr_value
715 if {[llength $attr] > 2} {
716 set attr_form [uplevel 2 [list subst [lindex $attr end]]]
718 if { [string index $attr_value 0] == ":" } {
719 # It is a label, get its value.
720 _guess_form $attr_value attr_value
723 set attr_form [_guess_form $attr_value attr_value]
724 if { $attr_form eq "" } {
725 set attr_form [_default_form $attr_name]
727 if { $attr_form eq "" } {
728 error "No form for $attr_name $attr_value"
731 set attr_form [_map_name $attr_form _FORM]
733 _handle_attribute $attr_name $attr_value $attr_form
737 _defer_output $_abbrev_section {
739 _op .byte 0x0 "DW_AT - Terminator"
740 _op .byte 0x0 "DW_FORM - Terminator"
746 # Terminate children.
747 _op .byte 0x0 "Terminate children"
751 proc _emit {string} {
752 variable _output_file
754 variable _deferred_output
757 puts $_output_file $string
759 append _deferred_output($_defer) ${string}\n
763 proc _section {name {flags ""} {type ""}} {
764 if {$flags == "" && $type == ""} {
765 _emit " .section $name"
766 } elseif {$type == ""} {
767 _emit " .section $name, \"$flags\""
769 _emit " .section $name, \"$flags\", %$type"
773 # SECTION_SPEC is a list of arguments to _section.
774 proc _defer_output {section_spec body} {
776 variable _deferred_output
778 set old_defer $_defer
779 set _defer [lindex $section_spec 0]
781 if {![info exists _deferred_output($_defer)]} {
782 set _deferred_output($_defer) ""
783 eval _section $section_spec
788 set _defer $old_defer
791 proc _defer_to_string {body} {
793 variable _deferred_output
795 set old_defer $_defer
798 set _deferred_output($_defer) ""
802 set result $_deferred_output($_defer)
803 unset _deferred_output($_defer)
805 set _defer $old_defer
809 proc _write_deferred_output {} {
810 variable _output_file
811 variable _deferred_output
813 foreach section [array names _deferred_output] {
814 # The data already has a newline.
815 puts -nonewline $_output_file $_deferred_output($section)
819 unset _deferred_output
822 proc _op {name value {comment ""}} {
823 set text " ${name} ${value}"
824 if {$comment != ""} {
825 # Try to make stuff line up nicely.
826 while {[string length $text] < 40} {
829 append text "/* ${comment} */"
834 proc _compute_label {name} {
838 # Return a name suitable for use as a label. If BASE_NAME is
839 # specified, it is incorporated into the label name; this is to
840 # make debugging the generated assembler easier. If BASE_NAME is
841 # not specified a generic default is used. This proc does not
842 # define the label; see 'define_label'. 'new_label' attempts to
843 # ensure that label names are unique.
844 proc new_label {{base_name label}} {
847 return [_compute_label ${base_name}[incr _label_num]]
850 # Define a label named NAME. Ordinarily, NAME comes from a call
851 # to 'new_label', but this is not required.
852 proc define_label {name} {
856 # A higher-level interface to label handling.
858 # ARGS is a list of label descriptors. Each one is either a
859 # single element, or a list of two elements -- a name and some
860 # text. For each descriptor, 'new_label' is invoked. If the list
861 # form is used, the second element in the list is passed as an
862 # argument. The label name is used to define a variable in the
863 # enclosing scope; this can be used to refer to the label later.
864 # The label name is also used to define a new proc whose name is
865 # the label name plus a trailing ":". This proc takes a body as
866 # an argument and can be used to define the label at that point;
867 # then the body, if any, is evaluated in the caller's context.
871 # declare_labels int_label
872 # something { ... $int_label } ;# refer to the label
873 # int_label: constant { ... } ;# define the label
874 proc declare_labels {args} {
876 set name [lindex $arg 0]
877 set text [lindex $arg 1]
883 upvar $name label_var
884 set label_var [new_label $text]
886 proc ${name}: {args} [format {
893 # This is a miniature assembler for location expressions. It is
894 # suitable for use in the attributes to a DIE. Its output is
895 # prefixed with "=" to make it automatically use DW_FORM_block.
897 # BODY is split by lines, and each line is taken to be a list.
899 # DWARF_VERSION is the DWARF version for the section where the location
900 # description is found.
902 # ADDR_SIZE is the length in bytes (4 or 8) of an address on the target
903 # machine (typically found in the header of the section where the location
904 # description is found).
906 # OFFSET_SIZE is the length in bytes (4 or 8) of an offset into a DWARF
907 # section. This typically depends on whether 32-bit or 64-bit DWARF is
908 # used, as indicated in the header of the section where the location
909 # description is found.
911 # (FIXME should use 'info complete' here.)
912 # Each list's first element is the opcode, either short or long
913 # forms are accepted.
914 # FIXME argument handling
916 proc _location { body dwarf_version addr_size offset_size } {
919 foreach line [split $body \n] {
920 # Ignore blank lines, and allow embedded comments.
921 if {[lindex $line 0] == "" || [regexp -- {^[ \t]*#} $line]} {
924 set opcode [_map_name [lindex $line 0] _OP]
925 _op .byte $_constants($opcode) $opcode
927 switch -exact -- $opcode {
929 _op .${addr_size}byte [lindex $line 1]
933 _op .uleb128 [lindex $line 1]
939 _op .byte [lindex $line 1]
944 _op .2byte [lindex $line 1]
949 _op .4byte [lindex $line 1]
954 _op .8byte [lindex $line 1]
958 _op .uleb128 [lindex $line 1]
961 _op .sleb128 [lindex $line 1]
965 _op .uleb128 [lindex $line 1]
969 _op .uleb128 [lindex $line 1]
973 _op .uleb128 [lindex $line 1]
974 _op .uleb128 [lindex $line 2]
979 _op .2byte [lindex $line 1]
982 DW_OP_implicit_value {
983 set l1 [new_label "value_start"]
984 set l2 [new_label "value_end"]
985 _op .uleb128 "$l2 - $l1"
987 foreach value [lrange $line 1 end] {
988 switch -regexp -- $value {
989 {^0x[[:xdigit:]]{1,2}$} {_op .byte $value}
990 {^0x[[:xdigit:]]{4}$} {_op .2byte $value}
991 {^0x[[:xdigit:]]{8}$} {_op .4byte $value}
992 {^0x[[:xdigit:]]{16}$} {_op .8byte $value}
994 error "bad value '$value' in DW_OP_implicit_value"
1001 DW_OP_implicit_pointer -
1002 DW_OP_GNU_implicit_pointer {
1003 if {[llength $line] != 3} {
1004 error "usage: $opcode LABEL OFFSET"
1007 # Here label is a section offset.
1008 set label [lindex $line 1]
1009 if { $dwarf_version == 2 } {
1010 _op .${addr_size}byte $label
1012 _op .${offset_size}byte $label
1014 _op .sleb128 [lindex $line 2]
1017 DW_OP_GNU_variable_value {
1018 if {[llength $line] != 2} {
1019 error "usage: $opcode LABEL"
1022 # Here label is a section offset.
1023 set label [lindex $line 1]
1024 if { $dwarf_version == 2 } {
1025 _op .${addr_size}byte $label
1027 _op .${offset_size}byte $label
1032 if {[llength $line] != 2} {
1033 error "usage: DW_OP_deref_size SIZE"
1036 _op .byte [lindex $line 1]
1040 _op .uleb128 [lindex $line 1]
1041 _op .sleb128 [lindex $line 2]
1045 if {[llength $line] > 1} {
1046 error "Unimplemented: operands in location for $opcode"
1054 # OPTIONS is a list with an even number of elements containing
1055 # option-name and option-value pairs.
1056 # Current options are:
1057 # is_64 0|1 - boolean indicating if you want to emit 64-bit DWARF
1058 # default = 0 (32-bit)
1059 # version n - DWARF version number to emit
1061 # addr_size n - the size of addresses in bytes: 4, 8, or default
1063 # fission 0|1 - boolean indicating if generating Fission debug info
1065 # BODY is Tcl code that emits the DIEs which make up the body of
1066 # the CU. It is evaluated in the caller's context.
1067 proc cu {options body} {
1070 variable _abbrev_section
1071 variable _abbrev_num
1073 variable _cu_version
1074 variable _cu_addr_size
1075 variable _cu_offset_size
1077 # Establish the defaults.
1080 set _cu_addr_size default
1082 set section ".debug_info"
1083 set _abbrev_section ".debug_abbrev"
1085 foreach { name value } $options {
1086 set value [uplevel 1 "subst \"$value\""]
1087 switch -exact -- $name {
1088 is_64 { set is_64 $value }
1089 version { set _cu_version $value }
1090 addr_size { set _cu_addr_size $value }
1091 fission { set fission $value }
1092 default { error "unknown option $name" }
1095 if {$_cu_addr_size == "default"} {
1096 if {[is_64_target]} {
1102 set _cu_offset_size [expr { $is_64 ? 8 : 4 }]
1104 set section ".debug_info.dwo"
1105 set _abbrev_section ".debug_abbrev.dwo"
1108 if {$_cu_version < 4} {
1109 set _constants(SPECIAL_expr) $_constants(DW_FORM_block)
1111 set _constants(SPECIAL_expr) $_constants(DW_FORM_exprloc)
1116 set cu_num [incr _cu_count]
1117 set my_abbrevs [_compute_label "abbrev${cu_num}_begin"]
1120 set _cu_label [_compute_label "cu${cu_num}_begin"]
1121 set start_label [_compute_label "cu${cu_num}_start"]
1122 set end_label [_compute_label "cu${cu_num}_end"]
1124 define_label $_cu_label
1126 _op .4byte 0xffffffff
1127 _op .8byte "$end_label - $start_label"
1129 _op .4byte "$end_label - $start_label"
1131 define_label $start_label
1132 _op .2byte $_cu_version Version
1134 # The CU header for DWARF 4 and 5 are slightly different.
1135 if { $_cu_version == 5 } {
1136 _op .byte 0x1 "DW_UT_compile"
1137 _op .byte $_cu_addr_size "Pointer size"
1138 _op .${_cu_offset_size}byte $my_abbrevs Abbrevs
1140 _op .${_cu_offset_size}byte $my_abbrevs Abbrevs
1141 _op .byte $_cu_addr_size "Pointer size"
1144 _defer_output $_abbrev_section {
1145 define_label $my_abbrevs
1150 _defer_output $_abbrev_section {
1151 # Emit the terminator.
1152 _op .byte 0x0 "Abbrev end - Terminator"
1155 define_label $end_label
1159 # OPTIONS is a list with an even number of elements containing
1160 # option-name and option-value pairs.
1161 # Current options are:
1162 # is_64 0|1 - boolean indicating if you want to emit 64-bit DWARF
1163 # default = 0 (32-bit)
1164 # version n - DWARF version number to emit
1166 # addr_size n - the size of addresses in bytes: 4, 8, or default
1168 # fission 0|1 - boolean indicating if generating Fission debug info
1170 # SIGNATURE is the 64-bit signature of the type.
1171 # TYPE_LABEL is the label of the type defined by this TU,
1172 # or "" if there is no type (i.e., type stubs in Fission).
1173 # BODY is Tcl code that emits the DIEs which make up the body of
1174 # the TU. It is evaluated in the caller's context.
1175 proc tu {options signature type_label body} {
1177 variable _abbrev_section
1178 variable _abbrev_num
1180 variable _cu_version
1181 variable _cu_addr_size
1182 variable _cu_offset_size
1184 # Establish the defaults.
1187 set _cu_addr_size default
1189 set section ".debug_types"
1190 set _abbrev_section ".debug_abbrev"
1192 foreach { name value } $options {
1193 switch -exact -- $name {
1194 is_64 { set is_64 $value }
1195 version { set _cu_version $value }
1196 addr_size { set _cu_addr_size $value }
1197 fission { set fission $value }
1198 default { error "unknown option $name" }
1201 if {$_cu_addr_size == "default"} {
1202 if {[is_64_target]} {
1208 set _cu_offset_size [expr { $is_64 ? 8 : 4 }]
1210 set section ".debug_types.dwo"
1211 set _abbrev_section ".debug_abbrev.dwo"
1216 set cu_num [incr _cu_count]
1217 set my_abbrevs [_compute_label "abbrev${cu_num}_begin"]
1220 set _cu_label [_compute_label "cu${cu_num}_begin"]
1221 set start_label [_compute_label "cu${cu_num}_start"]
1222 set end_label [_compute_label "cu${cu_num}_end"]
1224 define_label $_cu_label
1226 _op .4byte 0xffffffff
1227 _op .8byte "$end_label - $start_label"
1229 _op .4byte "$end_label - $start_label"
1231 define_label $start_label
1232 _op .2byte $_cu_version Version
1233 _op .${_cu_offset_size}byte $my_abbrevs Abbrevs
1234 _op .byte $_cu_addr_size "Pointer size"
1235 _op .8byte $signature Signature
1236 if { $type_label != "" } {
1237 uplevel declare_labels $type_label
1238 upvar $type_label my_type_label
1240 _op .8byte "$my_type_label - $_cu_label"
1242 _op .4byte "$my_type_label - $_cu_label"
1252 _defer_output $_abbrev_section {
1253 define_label $my_abbrevs
1258 _defer_output $_abbrev_section {
1259 # Emit the terminator.
1260 _op .byte 0x0 "Abbrev end - Terminator"
1263 define_label $end_label
1266 # Emit a DWARF .debug_ranges unit.
1267 # OPTIONS is a list with an even number of elements containing
1268 # option-name and option-value pairs.
1269 # Current options are:
1270 # is_64 0|1 - boolean indicating if you want to emit 64-bit DWARF
1271 # default = 0 (32-bit)
1273 # BODY is Tcl code that emits the content of the .debug_ranges
1274 # unit, it is evaluated in the caller's context.
1275 proc ranges {options body} {
1276 variable _debug_ranges_64_bit
1278 foreach { name value } $options {
1279 switch -exact -- $name {
1280 is_64 { set _debug_ranges_64_bit [subst $value] }
1281 default { error "unknown option $name" }
1285 set section ".debug_ranges"
1288 proc sequence { body } {
1289 variable _debug_ranges_64_bit
1291 # Emit the sequence of addresses.
1293 proc base { addr } {
1294 variable _debug_ranges_64_bit
1296 if { $_debug_ranges_64_bit } then {
1297 _op .8byte 0xffffffffffffffff "Base Marker"
1298 _op .8byte $addr "Base Address"
1300 _op .4byte 0xffffffff "Base Marker"
1301 _op .4byte $addr "Base Address"
1305 proc range { start end } {
1306 variable _debug_ranges_64_bit
1308 if { $_debug_ranges_64_bit } then {
1309 _op .8byte $start "Start Address"
1310 _op .8byte $end "End Address"
1312 _op .4byte $start "Start Address"
1313 _op .4byte $end "End Address"
1319 # End of the sequence.
1320 if { $_debug_ranges_64_bit } then {
1321 _op .8byte 0x0 "End of Sequence Marker (Part 1)"
1322 _op .8byte 0x0 "End of Sequence Marker (Part 2)"
1324 _op .4byte 0x0 "End of Sequence Marker (Part 1)"
1325 _op .4byte 0x0 "End of Sequence Marker (Part 2)"
1332 # Emit a DWARF .debug_rnglists section.
1334 # The target address size is based on the current target's address size.
1336 # There is one mandatory positional argument, BODY, which must be Tcl code
1337 # that emits the content of the section. It is evaluated in the caller's
1340 # The following option can be used:
1342 # - -is-64 true|false: Whether to use 64-bit DWARF instead of 32-bit DWARF.
1343 # The default is 32-bit.
1345 proc rnglists { args } {
1346 variable _debug_rnglists_addr_size
1347 variable _debug_rnglists_offset_size
1348 variable _debug_rnglists_is_64_dwarf
1350 parse_args {{"is-64" "false"}}
1352 if { [llength $args] != 1 } {
1353 error "rnglists proc expects one positional argument (body)"
1359 set _debug_rnglists_addr_size 8
1361 set _debug_rnglists_addr_size 4
1365 set _debug_rnglists_offset_size 8
1366 set _debug_rnglists_is_64_dwarf true
1368 set _debug_rnglists_offset_size 4
1369 set _debug_rnglists_is_64_dwarf false
1372 _section ".debug_rnglists"
1374 # Count of tables in the section.
1375 variable _debug_rnglists_table_count 0
1377 # Compute the label name for list at index LIST_IDX, for the current
1380 proc _compute_list_label { list_idx } {
1381 variable _debug_rnglists_table_count
1383 return ".Lrnglists_table_${_debug_rnglists_table_count}_list_${list_idx}"
1386 # Generate one table (header + offset array + range lists).
1388 # Accepts one positional argument, BODY. BODY may call the LIST_
1389 # procedure to generate rnglists.
1391 # The -post-header-label option can be used to define a label just after
1392 # the header of the table. This is the label that a DW_AT_rnglists_base
1393 # attribute will usually refer to.
1395 # The `-with-offset-array true|false` option can be used to control
1396 # whether the headers of the location list tables have an array of
1397 # offset. The default is true.
1399 proc table { args } {
1400 variable _debug_rnglists_table_count
1401 variable _debug_rnglists_addr_size
1402 variable _debug_rnglists_offset_size
1403 variable _debug_rnglists_is_64_dwarf
1406 {post-header-label ""}
1407 {with-offset-array true}
1410 if { [llength $args] != 1 } {
1411 error "table proc expects one positional argument (body)"
1416 # Generate one range list.
1418 # BODY may call the various procs defined below to generate list entries.
1419 # They correspond to the range list entry kinds described in section 2.17.3
1420 # of the DWARF 5 spec.
1422 # To define a label pointing to the beginning of the list, use
1423 # the conventional way of declaring and defining labels:
1425 # declare_labels the_list
1431 proc list_ { body } {
1432 variable _debug_rnglists_list_count
1434 # Define a label for this list. It is used to build the offset
1436 set list_label [_compute_list_label $_debug_rnglists_list_count]
1437 define_label $list_label
1439 # Emit a DW_RLE_start_end entry.
1441 proc start_end { start end } {
1442 variable _debug_rnglists_addr_size
1444 _op .byte 0x06 "DW_RLE_start_end"
1445 _op .${_debug_rnglists_addr_size}byte $start "start"
1446 _op .${_debug_rnglists_addr_size}byte $end "end"
1452 _op .byte 0x00 "DW_RLE_end_of_list"
1454 incr _debug_rnglists_list_count
1457 # Count of lists in the table.
1458 variable _debug_rnglists_list_count 0
1460 # Generate the lists ops first, because we need to know how many
1461 # lists there are to generate the header and offset table.
1462 set lists_ops [_defer_to_string {
1466 set post_unit_len_label \
1467 [_compute_label "rnglists_table_${_debug_rnglists_table_count}_post_unit_len"]
1468 set post_header_label \
1469 [_compute_label "rnglists_table_${_debug_rnglists_table_count}_post_header"]
1470 set table_end_label \
1471 [_compute_label "rnglists_table_${_debug_rnglists_table_count}_end"]
1473 # Emit the table header.
1474 if { $_debug_rnglists_is_64_dwarf } {
1475 _op .4byte 0xffffffff "unit length 1/2"
1476 _op .8byte "$table_end_label - $post_unit_len_label" "unit length 2/2"
1478 _op .4byte "$table_end_label - $post_unit_len_label" "unit length"
1481 define_label $post_unit_len_label
1483 _op .2byte 5 "dwarf version"
1484 _op .byte $_debug_rnglists_addr_size "address size"
1485 _op .byte 0 "segment selector size"
1487 if { ${with-offset-array} } {
1488 _op .4byte "$_debug_rnglists_list_count" "offset entry count"
1490 _op .4byte 0 "offset entry count"
1493 define_label $post_header_label
1495 # Define the user post-header label, if provided.
1496 if { ${post-header-label} != "" } {
1497 define_label ${post-header-label}
1500 # Emit the offset array.
1501 if { ${with-offset-array} } {
1502 for {set list_idx 0} {$list_idx < $_debug_rnglists_list_count} {incr list_idx} {
1503 set list_label [_compute_list_label $list_idx]
1504 _op .${_debug_rnglists_offset_size}byte "$list_label - $post_header_label" "offset of list $list_idx"
1508 # Emit the actual list data.
1511 define_label $table_end_label
1513 incr _debug_rnglists_table_count
1519 # Emit a DWARF .debug_loclists section.
1521 # The target address size is based on the current target's address size.
1523 # There is one mandatory positional argument, BODY, which must be Tcl code
1524 # that emits the content of the section. It is evaluated in the caller's
1527 # The following option can be used:
1529 # - -is-64 true|false: Whether to use 64-bit DWARF instead of 32-bit DWARF.
1530 # The default is 32-bit.
1532 proc loclists { args } {
1533 variable _debug_loclists_addr_size
1534 variable _debug_loclists_offset_size
1535 variable _debug_loclists_is_64_dwarf
1537 parse_args {{"is-64" "false"}}
1539 if { [llength $args] != 1 } {
1540 error "loclists proc expects one positional argument (body)"
1546 set _debug_loclists_addr_size 8
1548 set _debug_loclists_addr_size 4
1552 set _debug_loclists_offset_size 8
1553 set _debug_loclists_is_64_dwarf true
1555 set _debug_loclists_offset_size 4
1556 set _debug_loclists_is_64_dwarf false
1559 _section ".debug_loclists"
1561 # Count of tables in the section.
1562 variable _debug_loclists_table_count 0
1564 # Compute the label name for list at index LIST_IDX, for the current
1567 proc _compute_list_label { list_idx } {
1568 variable _debug_loclists_table_count
1570 return ".Lloclists_table_${_debug_loclists_table_count}_list_${list_idx}"
1573 # Generate one table (header + offset array + location lists).
1575 # Accepts one position argument, BODY. BODY may call the LIST_
1576 # procedure to generate loclists.
1578 # The -post-header-label option can be used to define a label just after the
1579 # header of the table. This is the label that a DW_AT_loclists_base
1580 # attribute will usually refer to.
1582 # The `-with-offset-array true|false` option can be used to control
1583 # whether the headers of the location list tables have an array of
1584 # offset. The default is true.
1586 proc table { args } {
1587 variable _debug_loclists_table_count
1588 variable _debug_loclists_addr_size
1589 variable _debug_loclists_offset_size
1590 variable _debug_loclists_is_64_dwarf
1593 {post-header-label ""}
1594 {with-offset-array true}
1597 if { [llength $args] != 1 } {
1598 error "table proc expects one positional argument (body)"
1603 # Generate one location list.
1605 # BODY may call the various procs defined below to generate list
1606 # entries. They correspond to the location list entry kinds
1607 # described in section 2.6.2 of the DWARF 5 spec.
1609 # To define a label pointing to the beginning of the list, use
1610 # the conventional way of declaring and defining labels:
1612 # declare_labels the_list
1618 proc list_ { body } {
1619 variable _debug_loclists_list_count
1621 # Count the location descriptions in this list.
1622 variable _debug_loclists_locdesc_count 0
1624 # Define a label for this list. It is used to build the offset
1626 set list_label [_compute_list_label $_debug_loclists_list_count]
1627 define_label $list_label
1629 # Emit a DW_LLE_start_length entry.
1631 proc start_length { start length locdesc } {
1632 variable _debug_loclists_is_64_dwarf
1633 variable _debug_loclists_addr_size
1634 variable _debug_loclists_offset_size
1635 variable _debug_loclists_table_count
1636 variable _debug_loclists_list_count
1637 variable _debug_loclists_locdesc_count
1639 _op .byte 0x08 "DW_LLE_start_length"
1641 # Start and end of the address range.
1642 _op .${_debug_loclists_addr_size}byte $start "start"
1643 _op .uleb128 $length "length"
1645 # Length of location description.
1646 set locdesc_start_label ".Lloclists_table_${_debug_loclists_table_count}_list_${_debug_loclists_list_count}_locdesc_${_debug_loclists_locdesc_count}_start"
1647 set locdesc_end_label ".Lloclists_table_${_debug_loclists_table_count}_list_${_debug_loclists_list_count}_locdesc_${_debug_loclists_locdesc_count}_end"
1648 _op .uleb128 "$locdesc_end_label - $locdesc_start_label" "locdesc length"
1650 define_label $locdesc_start_label
1652 _location $locdesc $dwarf_version $_debug_loclists_addr_size $_debug_loclists_offset_size
1653 define_label $locdesc_end_label
1655 incr _debug_loclists_locdesc_count
1661 _op .byte 0x00 "DW_LLE_end_of_list"
1663 incr _debug_loclists_list_count
1666 # Count of lists in the table.
1667 variable _debug_loclists_list_count 0
1669 # Generate the lists ops first, because we need to know how many
1670 # lists there are to generate the header and offset table.
1671 set lists_ops [_defer_to_string {
1675 set post_unit_len_label \
1676 [_compute_label "loclists_table_${_debug_loclists_table_count}_post_unit_len"]
1677 set post_header_label \
1678 [_compute_label "loclists_table_${_debug_loclists_table_count}_post_header"]
1679 set table_end_label \
1680 [_compute_label "loclists_table_${_debug_loclists_table_count}_end"]
1682 # Emit the table header.
1683 if { $_debug_loclists_is_64_dwarf } {
1684 _op .4byte 0xffffffff "unit length 1/2"
1685 _op .8byte "$table_end_label - $post_unit_len_label" "unit length 2/2"
1687 _op .4byte "$table_end_label - $post_unit_len_label" "unit length"
1690 define_label $post_unit_len_label
1692 _op .2byte 5 "DWARF version"
1693 _op .byte $_debug_loclists_addr_size "address size"
1694 _op .byte 0 "segment selector size"
1696 if { ${with-offset-array} } {
1697 _op .4byte "$_debug_loclists_list_count" "offset entry count"
1699 _op .4byte 0 "offset entry count"
1702 define_label $post_header_label
1704 # Define the user post-header label, if provided.
1705 if { ${post-header-label} != "" } {
1706 define_label ${post-header-label}
1709 # Emit the offset array.
1710 if { ${with-offset-array} } {
1711 for {set list_idx 0} {$list_idx < $_debug_loclists_list_count} {incr list_idx} {
1712 set list_label [_compute_list_label $list_idx]
1713 _op .${_debug_loclists_offset_size}byte "$list_label - $post_header_label" "offset of list $list_idx"
1717 # Emit the actual list data.
1720 define_label $table_end_label
1722 incr _debug_loclists_table_count
1728 # Emit a DWARF .debug_line unit.
1729 # OPTIONS is a list with an even number of elements containing
1730 # option-name and option-value pairs.
1731 # Current options are:
1732 # is_64 0|1 - boolean indicating if you want to emit 64-bit DWARF
1733 # default = 0 (32-bit)
1734 # version n - DWARF version number to emit
1736 # addr_size n - the size of addresses in bytes: 4, 8, or default
1739 # LABEL is the label of the current unit (which is probably
1740 # referenced by a DW_AT_stmt_list), or "" if there is no such
1743 # BODY is Tcl code that emits the parts which make up the body of
1744 # the line unit. It is evaluated in the caller's context. The
1745 # following commands are available for the BODY section:
1747 # include_dir "dirname" -- adds a new include directory
1749 # file_name "file.c" idx -- adds a new file name. IDX is a
1750 # 1-based index referencing an include directory or 0 for
1751 # current directory.
1753 proc lines {options label body} {
1754 variable _line_count
1755 variable _line_saw_file
1756 variable _line_saw_program
1757 variable _line_header_end_label
1759 # Establish the defaults.
1762 set _unit_addr_size default
1763 set _line_saw_program 0
1764 set _line_saw_file 0
1765 set _default_is_stmt 1
1767 foreach { name value } $options {
1768 switch -exact -- $name {
1769 is_64 { set is_64 $value }
1770 version { set _unit_version $value }
1771 addr_size { set _unit_addr_size $value }
1772 default_is_stmt { set _default_is_stmt $value }
1773 default { error "unknown option $name" }
1776 if {$_unit_addr_size == "default"} {
1777 if {[is_64_target]} {
1778 set _unit_addr_size 8
1780 set _unit_addr_size 4
1784 set unit_num [incr _line_count]
1786 set section ".debug_line"
1789 if { "$label" != "" } {
1790 # Define the user-provided label at this point.
1794 set unit_len_label [_compute_label "line${_line_count}_start"]
1795 set unit_end_label [_compute_label "line${_line_count}_end"]
1796 set header_len_label [_compute_label "line${_line_count}_header_start"]
1797 set _line_header_end_label [_compute_label "line${_line_count}_header_end"]
1800 _op .4byte 0xffffffff
1801 _op .8byte "$unit_end_label - $unit_len_label" "unit_length"
1803 _op .4byte "$unit_end_label - $unit_len_label" "unit_length"
1806 define_label $unit_len_label
1808 _op .2byte $_unit_version version
1811 _op .8byte "$_line_header_end_label - $header_len_label" "header_length"
1813 _op .4byte "$_line_header_end_label - $header_len_label" "header_length"
1816 define_label $header_len_label
1818 _op .byte 1 "minimum_instruction_length"
1819 _op .byte $_default_is_stmt "default_is_stmt"
1820 _op .byte 1 "line_base"
1821 _op .byte 1 "line_range"
1822 _op .byte 10 "opcode_base"
1824 # The standard_opcode_lengths table. The number of arguments
1825 # for each of the standard opcodes. Generating 9 entries here
1826 # matches the use of 10 in the opcode_base above. These 9
1827 # entries match the 9 standard opcodes for DWARF2, making use
1828 # of only 9 should be fine, even if we are generating DWARF3
1830 _op .byte 0 "standard opcode 1"
1831 _op .byte 1 "standard opcode 2"
1832 _op .byte 1 "standard opcode 3"
1833 _op .byte 1 "standard opcode 4"
1834 _op .byte 1 "standard opcode 5"
1835 _op .byte 0 "standard opcode 6"
1836 _op .byte 0 "standard opcode 7"
1837 _op .byte 0 "standard opcode 8"
1838 _op .byte 1 "standard opcode 9"
1840 proc include_dir {dirname} {
1841 _op .ascii [_quote $dirname]
1844 proc file_name {filename diridx} {
1845 variable _line_saw_file
1846 if "! $_line_saw_file" {
1847 # Terminate the dir list.
1848 _op .byte 0 "Terminator."
1849 set _line_saw_file 1
1852 _op .ascii [_quote $filename]
1853 _op .sleb128 $diridx
1854 _op .sleb128 0 "mtime"
1855 _op .sleb128 0 "length"
1858 proc program {statements} {
1859 variable _line_saw_program
1860 variable _line_header_end_label
1865 if "! $_line_saw_program" {
1866 # Terminate the file list.
1867 _op .byte 0 "Terminator."
1868 define_label $_line_header_end_label
1869 set _line_saw_program 1
1872 proc DW_LNE_set_address {addr} {
1874 set start [new_label "set_address_start"]
1875 set end [new_label "set_address_end"]
1876 _op .uleb128 "${end} - ${start}"
1877 define_label ${start}
1879 if {[is_64_target]} {
1887 proc DW_LNE_end_sequence {} {
1895 proc DW_LNE_user { len opcode } {
1896 set DW_LNE_lo_usr 0x80
1897 set DW_LNE_hi_usr 0xff
1898 if { $DW_LNE_lo_usr <= $opcode
1899 && $opcode <= $DW_LNE_hi_usr } {
1903 for {set i 1} {$i < $len} {incr i} {
1907 error "unknown vendor specific extended opcode: $opcode"
1911 proc DW_LNS_copy {} {
1915 proc DW_LNS_negate_stmt {} {
1919 proc DW_LNS_advance_pc {offset} {
1921 _op .uleb128 ${offset}
1924 proc DW_LNS_advance_line {offset} {
1927 _op .sleb128 ${offset}
1928 set _line [expr $_line + $offset]
1931 # A pseudo line number program instruction, that can be used instead
1932 # of DW_LNS_advance_line. Rather than writing:
1933 # {DW_LNS_advance_line [expr $line1 - 1]}
1934 # {DW_LNS_advance_line [expr $line2 - $line1]}
1935 # {DW_LNS_advance_line [expr $line3 - $line2]}
1936 # we can just write:
1942 set offset [expr $line - $_line]
1943 DW_LNS_advance_line $offset
1946 proc DW_LNS_set_file {num} {
1951 foreach statement $statements {
1952 uplevel 1 $statement
1958 rename include_dir ""
1961 # Terminate dir list if we saw no files.
1962 if "! $_line_saw_file" {
1963 _op .byte 0 "Terminator."
1966 # Terminate the file list.
1967 if "! $_line_saw_program" {
1968 _op .byte 0 "Terminator."
1969 define_label $_line_header_end_label
1972 define_label $unit_end_label
1975 proc _empty_array {name} {
1976 upvar $name the_array
1978 catch {unset the_array}
1983 # Emit a .gnu_debugaltlink section with the given file name and
1984 # build-id. The buildid should be represented as a hexadecimal
1985 # string, like "ffeeddcc".
1986 proc gnu_debugaltlink {filename buildid} {
1987 _defer_output .gnu_debugaltlink {
1988 _op .ascii [_quote $filename]
1989 foreach {a b} [split $buildid {}] {
1995 proc _note {type name hexdata} {
1996 set namelen [expr [string length $name] + 1]
2001 _op .4byte [expr [string length $hexdata] / 2]
2005 _op .ascii [_quote $name]
2008 set total [expr {($namelen + (1 << $align) - 1) & -(1 << $align)}]
2009 for {set i $namelen} {$i < $total} {incr i} {
2013 foreach {a b} [split $hexdata {}] {
2018 # Emit a note section holding the given build-id.
2019 proc build_id {buildid} {
2020 _defer_output {.note.gnu.build-id a note} {
2021 # From elf/common.h.
2022 set NT_GNU_BUILD_ID 3
2024 _note $NT_GNU_BUILD_ID GNU $buildid
2028 # The top-level interface to the DWARF assembler.
2029 # FILENAME is the name of the file where the generated assembly
2031 # BODY is Tcl code to emit the assembly. It is evaluated via
2032 # "eval" -- not uplevel as you might expect, because it is
2033 # important to run the body in the Dwarf namespace.
2035 # A typical invocation is something like:
2036 # Dwarf::assemble $file {
2046 proc assemble {filename body} {
2047 variable _initialized
2048 variable _output_file
2049 variable _deferred_output
2054 variable _line_count
2055 variable _line_saw_file
2056 variable _line_saw_program
2057 variable _line_header_end_label
2058 variable _debug_ranges_64_bit
2060 if {!$_initialized} {
2065 set _output_file [open $filename w]
2067 _empty_array _deferred_output
2070 _empty_array _strings
2073 set _line_saw_file 0
2074 set _line_saw_program 0
2075 set _debug_ranges_64_bit [is_64_target]
2077 # Not "uplevel" here, because we want to evaluate in this
2078 # namespace. This is somewhat bad because it means we can't
2079 # readily refer to outer variables.
2082 _write_deferred_output
2084 catch {close $_output_file}