1 # Copyright 2010-2020 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 $options]
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 {options {debug}} } {
118 global decimal gdb_prompt
120 set exe [standard_temp_file func_addr[pid].x]
122 gdb_compile $src $exe executable $options
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]
167 # Extract the start, length, and end for function called NAME and
168 # create suitable variables in the callers scope.
169 proc get_func_info { name {options {debug}} } {
170 global srcdir subdir srcfile
172 upvar 1 "${name}_start" func_start
173 upvar 1 "${name}_len" func_len
174 upvar 1 "${name}_end" func_end
176 lassign [function_range ${name} \
177 [list ${srcdir}/${subdir}/$srcfile] \
180 set func_end "$func_start + $func_len"
185 # All the variables in this namespace are private to the
186 # implementation. Also, any procedure whose name starts with "_" is
187 # private as well. Do not use these.
189 # Exported functions are documented at their definition.
191 # In addition to the hand-written functions documented below, this
192 # module automatically generates a function for each DWARF tag. For
193 # most tags, two forms are made: a full name, and one with the
194 # "DW_TAG_" prefix stripped. For example, you can use either
195 # 'DW_TAG_compile_unit' or 'compile_unit' interchangeably.
197 # There are two exceptions to this rule: DW_TAG_variable and
198 # DW_TAG_namespace. For these, the full name must always be used,
199 # as the short name conflicts with Tcl builtins. (Should future
200 # versions of Tcl or DWARF add more conflicts, this list will grow.
201 # If you want to be safe you should always use the full names.)
203 # Each tag procedure is defined like:
205 # proc DW_TAG_mumble {{attrs {}} {children {}}} { ... }
207 # ATTRS is an optional list of attributes.
208 # It is run through 'subst' in the caller's context before processing.
210 # Each attribute in the list has one of two forms:
212 # 2. { NAME VALUE FORM }
214 # In each case, NAME is the attribute's name.
215 # This can either be the full name, like 'DW_AT_name', or a shortened
216 # name, like 'name'. These are fully equivalent.
218 # Besides DWARF standard attributes, assembler supports 'macro' attribute
219 # which will be substituted by one or more standard or macro attributes.
220 # supported macro attributes are:
222 # - MACRO_AT_range { FUNC }
223 # It is substituted by DW_AT_low_pc and DW_AT_high_pc with the start and
224 # end address of function FUNC in file $srcdir/$subdir/$srcfile.
226 # - MACRO_AT_func { FUNC }
227 # It is substituted by DW_AT_name with FUNC and MACRO_AT_range.
229 # If FORM is given, it should name a DW_FORM_ constant.
230 # This can either be the short form, like 'DW_FORM_addr', or a
231 # shortened version, like 'addr'. If the form is given, VALUE
232 # is its value; see below. In some cases, additional processing
233 # is done; for example, DW_FORM_strp manages the .debug_str
234 # section automatically.
236 # If FORM is 'SPECIAL_expr', then VALUE is treated as a location
237 # expression. The effective form is then DW_FORM_block or DW_FORM_exprloc
238 # for DWARF version >= 4, and VALUE is passed to the (internal)
239 # '_location' proc to be translated.
240 # This proc implements a miniature DW_OP_ assembler.
242 # If FORM is not given, it is guessed:
243 # * If VALUE starts with the "@" character, the rest of VALUE is
244 # looked up as a DWARF constant, and DW_FORM_sdata is used. For
245 # example, '@DW_LANG_c89' could be used.
246 # * If VALUE starts with the ":" character, then it is a label
247 # reference. The rest of VALUE is taken to be the name of a label,
248 # and DW_FORM_ref4 is used. See 'new_label' and 'define_label'.
249 # * If VALUE starts with the "%" character, then it is a label
250 # reference too, but DW_FORM_ref_addr is used.
251 # * Otherwise, if the attribute name has a default form (f.i. DW_FORM_addr for
252 # DW_AT_low_pc), then that one is used.
253 # * Otherwise, an error is reported. Either specify a form explicitly, or
254 # add a default for the the attribute name in _default_form.
256 # CHILDREN is just Tcl code that can be used to define child DIEs. It
257 # is evaluated in the caller's context.
259 # Currently this code is missing nice support for CFA handling, and
260 # probably other things as well.
262 namespace eval Dwarf {
263 # True if the module has been initialized.
264 variable _initialized 0
266 # Constants from dwarf2.h.
270 # DW_FORM short names.
275 # The current output file.
276 variable _output_file
278 # Note: The _cu_ values here also apply to type units (TUs).
279 # Think of a TU as a special kind of CU.
284 # The current CU's base label.
287 # The current CU's version.
290 # The current CU's address size.
291 variable _cu_addr_size
292 # The current CU's offset size.
293 variable _cu_offset_size
295 # Label generation number.
298 # The deferred output array. The index is the section name; the
299 # contents hold the data for that section.
300 variable _deferred_output
302 # If empty, we should write directly to the output file.
303 # Otherwise, this is the name of a section to write to.
306 # The abbrev section. Typically .debug_abbrev but can be .debug_abbrev.dwo
308 variable _abbrev_section
310 # The next available abbrev number in the current CU's abbrev
314 # The string table for this assembly. The key is the string; the
315 # value is the label for that string.
318 # Current .debug_line unit count.
321 # Whether a file_name entry was seen.
322 variable _line_saw_file
324 # Whether a line table program has been seen.
325 variable _line_saw_program
327 # A Label for line table header generation.
328 variable _line_header_end_label
330 # The address size for debug ranges section.
331 variable _debug_ranges_64_bit
333 proc _process_one_constant {name value} {
339 set _constants($name) $value
341 if {![regexp "^DW_(\[A-Z\]+)_(\[A-Za-z0-9_\]+)$" $name \
342 ignore prefix name2]} {
343 error "non-matching name: $name"
346 if {$name2 == "lo_user" || $name2 == "hi_user"} {
350 # We only try to shorten some very common things.
352 switch -exact -- $prefix {
354 # Create two procedures for the tag. These call
355 # _handle_DW_TAG with the full tag name baked in; this
356 # does all the actual work.
357 proc $name {{attrs {}} {children {}}} \
358 "_handle_DW_TAG $name \$attrs \$children"
360 # Filter out ones that are known to clash.
361 if {$name2 == "variable" || $name2 == "namespace"} {
362 set name2 "tag_$name2"
365 if {[info commands $name2] != {}} {
366 error "duplicate proc name: from $name"
369 proc $name2 {{attrs {}} {children {}}} \
370 "_handle_DW_TAG $name \$attrs \$children"
374 set _AT($name2) $name
378 set _FORM($name2) $name
382 set _OP($name2) $name
391 proc _read_constants {} {
392 global srcdir hex decimal
394 # DWARF name-matching regexp.
395 set dwrx "DW_\[a-zA-Z0-9_\]+"
399 set fd [open [file join $srcdir .. .. include dwarf2.h]]
402 if {[regexp -- "^${ws}($dwrx)${ws}=${ws}($hex|$decimal),?$" \
403 $line ignore name value ignore2]} {
404 _process_one_constant $name $value
409 set fd [open [file join $srcdir .. .. include dwarf2.def]]
413 "^DW_\[A-Z_\]+${ws}\\(($dwrx),${ws}($hex|$decimal)\\)$" \
414 $line ignore name value ignore2]} {
415 _process_one_constant $name $value
421 proc _quote {string} {
423 return "\"${string}\\0\""
426 proc _nz_quote {string} {
427 # For now, no quoting is done.
428 return "\"${string}\""
431 proc _handle_DW_FORM {form value} {
432 switch -exact -- $form {
434 _op .ascii [_quote $value]
437 DW_FORM_flag_present {
438 # We don't need to emit anything.
447 variable _cu_offset_size
449 variable _cu_addr_size
451 if {$_cu_version == 2} {
452 set size $_cu_addr_size
454 set size $_cu_offset_size
457 _op .${size}byte $value
461 variable _cu_offset_size
462 _op .${_cu_offset_size}byte $value
481 variable _cu_addr_size
483 _op .${_cu_addr_size}byte $value
503 variable _cu_offset_size
505 if {![info exists _strings($value)]} {
506 set _strings($value) [new_label strp]
507 _defer_output .debug_string {
508 define_label $_strings($value)
509 _op .ascii [_quote $value]
513 _op .${_cu_offset_size}byte $_strings($value) "strp: $value"
517 set l1 [new_label "expr_start"]
518 set l2 [new_label "expr_end"]
519 _op .uleb128 "$l2 - $l1" "expression"
526 set len [string length $value]
528 error "DW_FORM_block1 length too long"
531 _op .ascii [_nz_quote $value]
549 DW_FORM_GNU_addr_index -
550 DW_FORM_GNU_str_index -
551 DW_FORM_GNU_ref_alt -
552 DW_FORM_GNU_strp_alt -
555 error "unhandled form $form"
560 proc _guess_form {value varname} {
561 upvar $varname new_value
563 switch -exact -- [string range $value 0 0] {
565 # Constant reference.
568 set new_value $_constants([string range $value 1 end])
577 set new_value "[string range $value 1 end] - $_cu_label"
583 # Label reference, an offset from .debug_info.
584 set new_value "[string range $value 1 end]"
586 return DW_FORM_ref_addr
595 proc _default_form { attr } {
596 switch -exact -- $attr {
603 DW_AT_MIPS_linkage_name -
605 return DW_FORM_string
611 # Map NAME to its canonical form.
612 proc _map_name {name ary} {
615 if {[info exists ${ary}($name)]} {
616 set name [set ${ary}($name)]
622 proc _handle_attribute { attr_name attr_value attr_form } {
623 variable _abbrev_section
626 _handle_DW_FORM $attr_form $attr_value
628 _defer_output $_abbrev_section {
629 _op .uleb128 $_constants($attr_name) $attr_name
630 _op .uleb128 $_constants($attr_form) $attr_form
634 # Handle macro attribute MACRO_AT_range.
636 proc _handle_macro_at_range { attr_value } {
637 if {[llength $attr_value] != 1} {
638 error "usage: MACRO_AT_range { func }"
641 set func [lindex $attr_value 0]
642 global srcdir subdir srcfile
643 set src ${srcdir}/${subdir}/${srcfile}
644 set result [function_range $func $src]
646 _handle_attribute DW_AT_low_pc [lindex $result 0] \
648 _handle_attribute DW_AT_high_pc \
649 "[lindex $result 0] + [lindex $result 1]" DW_FORM_addr
652 # Handle macro attribute MACRO_AT_func.
654 proc _handle_macro_at_func { attr_value } {
655 if {[llength $attr_value] != 1} {
656 error "usage: MACRO_AT_func { func file }"
658 _handle_attribute DW_AT_name [lindex $attr_value 0] DW_FORM_string
659 _handle_macro_at_range $attr_value
662 proc _handle_DW_TAG {tag_name {attrs {}} {children {}}} {
663 variable _abbrev_section
667 set has_children [expr {[string length $children] > 0}]
668 set my_abbrev [incr _abbrev_num]
670 # We somewhat wastefully emit a new abbrev entry for each tag.
671 # There's no reason for this other than laziness.
672 _defer_output $_abbrev_section {
673 _op .uleb128 $my_abbrev "Abbrev start"
674 _op .uleb128 $_constants($tag_name) $tag_name
675 _op .byte $has_children "has_children"
678 _op .uleb128 $my_abbrev "Abbrev ($tag_name)"
680 foreach attr $attrs {
681 set attr_name [_map_name [lindex $attr 0] _AT]
683 # When the length of ATTR is greater than 2, the last
684 # element of the list must be a form. The second through
685 # the penultimate elements are joined together and
686 # evaluated using subst. This allows constructs such as
687 # [gdb_target_symbol foo] to be used.
689 if {[llength $attr] > 2} {
690 set attr_value [uplevel 2 [list subst [join [lrange $attr 1 end-1]]]]
692 set attr_value [uplevel 2 [list subst [lindex $attr 1]]]
695 if { [string equal "MACRO_AT_func" $attr_name] } {
696 _handle_macro_at_func $attr_value
697 } elseif { [string equal "MACRO_AT_range" $attr_name] } {
698 _handle_macro_at_range $attr_value
700 if {[llength $attr] > 2} {
701 set attr_form [uplevel 2 [list subst [lindex $attr end]]]
703 if { [string index $attr_value 0] == ":" } {
704 # It is a label, get its value.
705 _guess_form $attr_value attr_value
708 set attr_form [_guess_form $attr_value attr_value]
709 if { $attr_form eq "" } {
710 set attr_form [_default_form $attr_name]
712 if { $attr_form eq "" } {
713 error "No form for $attr_name $attr_value"
716 set attr_form [_map_name $attr_form _FORM]
718 _handle_attribute $attr_name $attr_value $attr_form
722 _defer_output $_abbrev_section {
724 _op .byte 0x0 "DW_AT - Terminator"
725 _op .byte 0x0 "DW_FORM - Terminator"
731 # Terminate children.
732 _op .byte 0x0 "Terminate children"
736 proc _emit {string} {
737 variable _output_file
739 variable _deferred_output
742 puts $_output_file $string
744 append _deferred_output($_defer) ${string}\n
748 proc _section {name {flags ""} {type ""}} {
749 if {$flags == "" && $type == ""} {
750 _emit " .section $name"
751 } elseif {$type == ""} {
752 _emit " .section $name, \"$flags\""
754 _emit " .section $name, \"$flags\", %$type"
758 # SECTION_SPEC is a list of arguments to _section.
759 proc _defer_output {section_spec body} {
761 variable _deferred_output
763 set old_defer $_defer
764 set _defer [lindex $section_spec 0]
766 if {![info exists _deferred_output($_defer)]} {
767 set _deferred_output($_defer) ""
768 eval _section $section_spec
773 set _defer $old_defer
776 proc _defer_to_string {body} {
778 variable _deferred_output
780 set old_defer $_defer
783 set _deferred_output($_defer) ""
787 set result $_deferred_output($_defer)
788 unset _deferred_output($_defer)
790 set _defer $old_defer
794 proc _write_deferred_output {} {
795 variable _output_file
796 variable _deferred_output
798 foreach section [array names _deferred_output] {
799 # The data already has a newline.
800 puts -nonewline $_output_file $_deferred_output($section)
804 unset _deferred_output
807 proc _op {name value {comment ""}} {
808 set text " ${name} ${value}"
809 if {$comment != ""} {
810 # Try to make stuff line up nicely.
811 while {[string length $text] < 40} {
814 append text "/* ${comment} */"
819 proc _compute_label {name} {
823 # Return a name suitable for use as a label. If BASE_NAME is
824 # specified, it is incorporated into the label name; this is to
825 # make debugging the generated assembler easier. If BASE_NAME is
826 # not specified a generic default is used. This proc does not
827 # define the label; see 'define_label'. 'new_label' attempts to
828 # ensure that label names are unique.
829 proc new_label {{base_name label}} {
832 return [_compute_label ${base_name}[incr _label_num]]
835 # Define a label named NAME. Ordinarily, NAME comes from a call
836 # to 'new_label', but this is not required.
837 proc define_label {name} {
841 # A higher-level interface to label handling.
843 # ARGS is a list of label descriptors. Each one is either a
844 # single element, or a list of two elements -- a name and some
845 # text. For each descriptor, 'new_label' is invoked. If the list
846 # form is used, the second element in the list is passed as an
847 # argument. The label name is used to define a variable in the
848 # enclosing scope; this can be used to refer to the label later.
849 # The label name is also used to define a new proc whose name is
850 # the label name plus a trailing ":". This proc takes a body as
851 # an argument and can be used to define the label at that point;
852 # then the body, if any, is evaluated in the caller's context.
856 # declare_labels int_label
857 # something { ... $int_label } ;# refer to the label
858 # int_label: constant { ... } ;# define the label
859 proc declare_labels {args} {
861 set name [lindex $arg 0]
862 set text [lindex $arg 1]
868 upvar $name label_var
869 set label_var [new_label $text]
871 proc ${name}: {args} [format {
878 # This is a miniature assembler for location expressions. It is
879 # suitable for use in the attributes to a DIE. Its output is
880 # prefixed with "=" to make it automatically use DW_FORM_block.
881 # BODY is split by lines, and each line is taken to be a list.
882 # (FIXME should use 'info complete' here.)
883 # Each list's first element is the opcode, either short or long
884 # forms are accepted.
885 # FIXME argument handling
887 proc _location {body} {
891 variable _cu_addr_size
892 variable _cu_offset_size
894 foreach line [split $body \n] {
895 # Ignore blank lines, and allow embedded comments.
896 if {[lindex $line 0] == "" || [regexp -- {^[ \t]*#} $line]} {
899 set opcode [_map_name [lindex $line 0] _OP]
900 _op .byte $_constants($opcode) $opcode
902 switch -exact -- $opcode {
904 _op .${_cu_addr_size}byte [lindex $line 1]
908 _op .uleb128 [lindex $line 1]
914 _op .byte [lindex $line 1]
919 _op .2byte [lindex $line 1]
924 _op .4byte [lindex $line 1]
929 _op .8byte [lindex $line 1]
933 _op .uleb128 [lindex $line 1]
936 _op .sleb128 [lindex $line 1]
940 _op .uleb128 [lindex $line 1]
944 _op .uleb128 [lindex $line 1]
948 _op .uleb128 [lindex $line 1]
949 _op .uleb128 [lindex $line 2]
954 _op .2byte [lindex $line 1]
957 DW_OP_implicit_value {
958 set l1 [new_label "value_start"]
959 set l2 [new_label "value_end"]
960 _op .uleb128 "$l2 - $l1"
962 foreach value [lrange $line 1 end] {
963 switch -regexp -- $value {
964 {^0x[[:xdigit:]]{1,2}$} {_op .byte $value}
965 {^0x[[:xdigit:]]{4}$} {_op .2byte $value}
966 {^0x[[:xdigit:]]{8}$} {_op .4byte $value}
967 {^0x[[:xdigit:]]{16}$} {_op .8byte $value}
969 error "bad value '$value' in DW_OP_implicit_value"
976 DW_OP_implicit_pointer -
977 DW_OP_GNU_implicit_pointer {
978 if {[llength $line] != 3} {
979 error "usage: $opcode LABEL OFFSET"
982 # Here label is a section offset.
983 set label [lindex $line 1]
984 if { $_cu_version == 2 } {
985 _op .${_cu_addr_size}byte $label
987 _op .${_cu_offset_size}byte $label
989 _op .sleb128 [lindex $line 2]
992 DW_OP_GNU_variable_value {
993 if {[llength $line] != 2} {
994 error "usage: $opcode LABEL"
997 # Here label is a section offset.
998 set label [lindex $line 1]
999 if { $_cu_version == 2 } {
1000 _op .${_cu_addr_size}byte $label
1002 _op .${_cu_offset_size}byte $label
1007 if {[llength $line] != 2} {
1008 error "usage: DW_OP_deref_size SIZE"
1011 _op .byte [lindex $line 1]
1015 _op .uleb128 [lindex $line 1]
1016 _op .sleb128 [lindex $line 2]
1020 if {[llength $line] > 1} {
1021 error "Unimplemented: operands in location for $opcode"
1029 # OPTIONS is a list with an even number of elements containing
1030 # option-name and option-value pairs.
1031 # Current options are:
1032 # is_64 0|1 - boolean indicating if you want to emit 64-bit DWARF
1033 # default = 0 (32-bit)
1034 # version n - DWARF version number to emit
1036 # addr_size n - the size of addresses in bytes: 4, 8, or default
1038 # fission 0|1 - boolean indicating if generating Fission debug info
1040 # BODY is Tcl code that emits the DIEs which make up the body of
1041 # the CU. It is evaluated in the caller's context.
1042 proc cu {options body} {
1045 variable _abbrev_section
1046 variable _abbrev_num
1048 variable _cu_version
1049 variable _cu_addr_size
1050 variable _cu_offset_size
1052 # Establish the defaults.
1055 set _cu_addr_size default
1057 set section ".debug_info"
1058 set _abbrev_section ".debug_abbrev"
1060 foreach { name value } $options {
1061 set value [uplevel 1 "subst \"$value\""]
1062 switch -exact -- $name {
1063 is_64 { set is_64 $value }
1064 version { set _cu_version $value }
1065 addr_size { set _cu_addr_size $value }
1066 fission { set fission $value }
1067 default { error "unknown option $name" }
1070 if {$_cu_addr_size == "default"} {
1071 if {[is_64_target]} {
1077 set _cu_offset_size [expr { $is_64 ? 8 : 4 }]
1079 set section ".debug_info.dwo"
1080 set _abbrev_section ".debug_abbrev.dwo"
1083 if {$_cu_version < 4} {
1084 set _constants(SPECIAL_expr) $_constants(DW_FORM_block)
1086 set _constants(SPECIAL_expr) $_constants(DW_FORM_exprloc)
1091 set cu_num [incr _cu_count]
1092 set my_abbrevs [_compute_label "abbrev${cu_num}_begin"]
1095 set _cu_label [_compute_label "cu${cu_num}_begin"]
1096 set start_label [_compute_label "cu${cu_num}_start"]
1097 set end_label [_compute_label "cu${cu_num}_end"]
1099 define_label $_cu_label
1101 _op .4byte 0xffffffff
1102 _op .8byte "$end_label - $start_label"
1104 _op .4byte "$end_label - $start_label"
1106 define_label $start_label
1107 _op .2byte $_cu_version Version
1108 _op .${_cu_offset_size}byte $my_abbrevs Abbrevs
1109 _op .byte $_cu_addr_size "Pointer size"
1111 _defer_output $_abbrev_section {
1112 define_label $my_abbrevs
1117 _defer_output $_abbrev_section {
1118 # Emit the terminator.
1119 _op .byte 0x0 "Abbrev end - Terminator"
1122 define_label $end_label
1126 # OPTIONS is a list with an even number of elements containing
1127 # option-name and option-value pairs.
1128 # Current options are:
1129 # is_64 0|1 - boolean indicating if you want to emit 64-bit DWARF
1130 # default = 0 (32-bit)
1131 # version n - DWARF version number to emit
1133 # addr_size n - the size of addresses in bytes: 4, 8, or default
1135 # fission 0|1 - boolean indicating if generating Fission debug info
1137 # SIGNATURE is the 64-bit signature of the type.
1138 # TYPE_LABEL is the label of the type defined by this TU,
1139 # or "" if there is no type (i.e., type stubs in Fission).
1140 # BODY is Tcl code that emits the DIEs which make up the body of
1141 # the TU. It is evaluated in the caller's context.
1142 proc tu {options signature type_label body} {
1144 variable _abbrev_section
1145 variable _abbrev_num
1147 variable _cu_version
1148 variable _cu_addr_size
1149 variable _cu_offset_size
1151 # Establish the defaults.
1154 set _cu_addr_size default
1156 set section ".debug_types"
1157 set _abbrev_section ".debug_abbrev"
1159 foreach { name value } $options {
1160 switch -exact -- $name {
1161 is_64 { set is_64 $value }
1162 version { set _cu_version $value }
1163 addr_size { set _cu_addr_size $value }
1164 fission { set fission $value }
1165 default { error "unknown option $name" }
1168 if {$_cu_addr_size == "default"} {
1169 if {[is_64_target]} {
1175 set _cu_offset_size [expr { $is_64 ? 8 : 4 }]
1177 set section ".debug_types.dwo"
1178 set _abbrev_section ".debug_abbrev.dwo"
1183 set cu_num [incr _cu_count]
1184 set my_abbrevs [_compute_label "abbrev${cu_num}_begin"]
1187 set _cu_label [_compute_label "cu${cu_num}_begin"]
1188 set start_label [_compute_label "cu${cu_num}_start"]
1189 set end_label [_compute_label "cu${cu_num}_end"]
1191 define_label $_cu_label
1193 _op .4byte 0xffffffff
1194 _op .8byte "$end_label - $start_label"
1196 _op .4byte "$end_label - $start_label"
1198 define_label $start_label
1199 _op .2byte $_cu_version Version
1200 _op .${_cu_offset_size}byte $my_abbrevs Abbrevs
1201 _op .byte $_cu_addr_size "Pointer size"
1202 _op .8byte $signature Signature
1203 if { $type_label != "" } {
1204 uplevel declare_labels $type_label
1205 upvar $type_label my_type_label
1207 _op .8byte "$my_type_label - $_cu_label"
1209 _op .4byte "$my_type_label - $_cu_label"
1219 _defer_output $_abbrev_section {
1220 define_label $my_abbrevs
1225 _defer_output $_abbrev_section {
1226 # Emit the terminator.
1227 _op .byte 0x0 "Abbrev end - Terminator"
1230 define_label $end_label
1233 # Emit a DWARF .debug_ranges unit.
1234 # OPTIONS is a list with an even number of elements containing
1235 # option-name and option-value pairs.
1236 # Current options are:
1237 # is_64 0|1 - boolean indicating if you want to emit 64-bit DWARF
1238 # default = 0 (32-bit)
1240 # BODY is Tcl code that emits the content of the .debug_ranges
1241 # unit, it is evaluated in the caller's context.
1242 proc ranges {options body} {
1243 variable _debug_ranges_64_bit
1245 foreach { name value } $options {
1246 switch -exact -- $name {
1247 is_64 { set _debug_ranges_64_bit [subst $value] }
1248 default { error "unknown option $name" }
1252 set section ".debug_ranges"
1255 proc sequence { body } {
1256 variable _debug_ranges_64_bit
1258 # Emit the sequence of addresses.
1260 proc base { addr } {
1261 variable _debug_ranges_64_bit
1263 if { $_debug_ranges_64_bit } then {
1264 _op .8byte 0xffffffffffffffff "Base Marker"
1265 _op .8byte $addr "Base Address"
1267 _op .4byte 0xffffffff "Base Marker"
1268 _op .4byte $addr "Base Address"
1272 proc range { start end } {
1273 variable _debug_ranges_64_bit
1275 if { $_debug_ranges_64_bit } then {
1276 _op .8byte $start "Start Address"
1277 _op .8byte $end "End Address"
1279 _op .4byte $start "Start Address"
1280 _op .4byte $end "End Address"
1286 # End of the sequence.
1287 if { $_debug_ranges_64_bit } then {
1288 _op .8byte 0x0 "End of Sequence Marker (Part 1)"
1289 _op .8byte 0x0 "End of Sequence Marker (Part 2)"
1291 _op .4byte 0x0 "End of Sequence Marker (Part 1)"
1292 _op .4byte 0x0 "End of Sequence Marker (Part 2)"
1300 # Emit a DWARF .debug_line unit.
1301 # OPTIONS is a list with an even number of elements containing
1302 # option-name and option-value pairs.
1303 # Current options are:
1304 # is_64 0|1 - boolean indicating if you want to emit 64-bit DWARF
1305 # default = 0 (32-bit)
1306 # version n - DWARF version number to emit
1308 # addr_size n - the size of addresses in bytes: 4, 8, or default
1311 # LABEL is the label of the current unit (which is probably
1312 # referenced by a DW_AT_stmt_list), or "" if there is no such
1315 # BODY is Tcl code that emits the parts which make up the body of
1316 # the line unit. It is evaluated in the caller's context. The
1317 # following commands are available for the BODY section:
1319 # include_dir "dirname" -- adds a new include directory
1321 # file_name "file.c" idx -- adds a new file name. IDX is a
1322 # 1-based index referencing an include directory or 0 for
1323 # current directory.
1325 proc lines {options label body} {
1326 variable _line_count
1327 variable _line_saw_file
1328 variable _line_saw_program
1329 variable _line_header_end_label
1331 # Establish the defaults.
1334 set _unit_addr_size default
1335 set _line_saw_program 0
1336 set _line_saw_file 0
1337 set _default_is_stmt 1
1339 foreach { name value } $options {
1340 switch -exact -- $name {
1341 is_64 { set is_64 $value }
1342 version { set _unit_version $value }
1343 addr_size { set _unit_addr_size $value }
1344 default_is_stmt { set _default_is_stmt $value }
1345 default { error "unknown option $name" }
1348 if {$_unit_addr_size == "default"} {
1349 if {[is_64_target]} {
1350 set _unit_addr_size 8
1352 set _unit_addr_size 4
1356 set unit_num [incr _line_count]
1358 set section ".debug_line"
1361 if { "$label" != "" } {
1362 # Define the user-provided label at this point.
1366 set unit_len_label [_compute_label "line${_line_count}_start"]
1367 set unit_end_label [_compute_label "line${_line_count}_end"]
1368 set header_len_label [_compute_label "line${_line_count}_header_start"]
1369 set _line_header_end_label [_compute_label "line${_line_count}_header_end"]
1372 _op .4byte 0xffffffff
1373 _op .8byte "$unit_end_label - $unit_len_label" "unit_length"
1375 _op .4byte "$unit_end_label - $unit_len_label" "unit_length"
1378 define_label $unit_len_label
1380 _op .2byte $_unit_version version
1383 _op .8byte "$_line_header_end_label - $header_len_label" "header_length"
1385 _op .4byte "$_line_header_end_label - $header_len_label" "header_length"
1388 define_label $header_len_label
1390 _op .byte 1 "minimum_instruction_length"
1391 _op .byte $_default_is_stmt "default_is_stmt"
1392 _op .byte 1 "line_base"
1393 _op .byte 1 "line_range"
1394 _op .byte 10 "opcode_base"
1396 # The standard_opcode_lengths table. The number of arguments
1397 # for each of the standard opcodes. Generating 9 entries here
1398 # matches the use of 10 in the opcode_base above. These 9
1399 # entries match the 9 standard opcodes for DWARF2, making use
1400 # of only 9 should be fine, even if we are generating DWARF3
1402 _op .byte 0 "standard opcode 1"
1403 _op .byte 1 "standard opcode 2"
1404 _op .byte 1 "standard opcode 3"
1405 _op .byte 1 "standard opcode 4"
1406 _op .byte 1 "standard opcode 5"
1407 _op .byte 0 "standard opcode 6"
1408 _op .byte 0 "standard opcode 7"
1409 _op .byte 0 "standard opcode 8"
1410 _op .byte 1 "standard opcode 9"
1412 proc include_dir {dirname} {
1413 _op .ascii [_quote $dirname]
1416 proc file_name {filename diridx} {
1417 variable _line_saw_file
1418 if "! $_line_saw_file" {
1419 # Terminate the dir list.
1420 _op .byte 0 "Terminator."
1421 set _line_saw_file 1
1424 _op .ascii [_quote $filename]
1425 _op .sleb128 $diridx
1426 _op .sleb128 0 "mtime"
1427 _op .sleb128 0 "length"
1430 proc program {statements} {
1431 variable _line_saw_program
1432 variable _line_header_end_label
1437 if "! $_line_saw_program" {
1438 # Terminate the file list.
1439 _op .byte 0 "Terminator."
1440 define_label $_line_header_end_label
1441 set _line_saw_program 1
1444 proc DW_LNE_set_address {addr} {
1446 set start [new_label "set_address_start"]
1447 set end [new_label "set_address_end"]
1448 _op .uleb128 "${end} - ${start}"
1449 define_label ${start}
1451 if {[is_64_target]} {
1459 proc DW_LNE_end_sequence {} {
1467 proc DW_LNE_user { len opcode } {
1468 set DW_LNE_lo_usr 0x80
1469 set DW_LNE_hi_usr 0xff
1470 if { $DW_LNE_lo_usr <= $opcode
1471 && $opcode <= $DW_LNE_hi_usr } {
1475 for {set i 1} {$i < $len} {incr i} {
1479 error "unknown vendor specific extended opcode: $opcode"
1483 proc DW_LNS_copy {} {
1487 proc DW_LNS_negate_stmt {} {
1491 proc DW_LNS_advance_pc {offset} {
1493 _op .uleb128 ${offset}
1496 proc DW_LNS_advance_line {offset} {
1499 _op .sleb128 ${offset}
1500 set _line [expr $_line + $offset]
1503 # A pseudo line number program instruction, that can be used instead
1504 # of DW_LNS_advance_line. Rather than writing:
1505 # {DW_LNS_advance_line [expr $line1 - 1]}
1506 # {DW_LNS_advance_line [expr $line2 - $line1]}
1507 # {DW_LNS_advance_line [expr $line3 - $line2]}
1508 # we can just write:
1514 set offset [expr $line - $_line]
1515 DW_LNS_advance_line $offset
1518 proc DW_LNS_set_file {num} {
1523 foreach statement $statements {
1524 uplevel 1 $statement
1530 rename include_dir ""
1533 # Terminate dir list if we saw no files.
1534 if "! $_line_saw_file" {
1535 _op .byte 0 "Terminator."
1538 # Terminate the file list.
1539 if "! $_line_saw_program" {
1540 _op .byte 0 "Terminator."
1541 define_label $_line_header_end_label
1544 define_label $unit_end_label
1547 proc _empty_array {name} {
1548 upvar $name the_array
1550 catch {unset the_array}
1555 # Emit a .gnu_debugaltlink section with the given file name and
1556 # build-id. The buildid should be represented as a hexadecimal
1557 # string, like "ffeeddcc".
1558 proc gnu_debugaltlink {filename buildid} {
1559 _defer_output .gnu_debugaltlink {
1560 _op .ascii [_quote $filename]
1561 foreach {a b} [split $buildid {}] {
1567 proc _note {type name hexdata} {
1568 set namelen [expr [string length $name] + 1]
1573 _op .4byte [expr [string length $hexdata] / 2]
1577 _op .ascii [_quote $name]
1580 set total [expr {($namelen + (1 << $align) - 1) & -(1 << $align)}]
1581 for {set i $namelen} {$i < $total} {incr i} {
1585 foreach {a b} [split $hexdata {}] {
1590 # Emit a note section holding the given build-id.
1591 proc build_id {buildid} {
1592 _defer_output {.note.gnu.build-id a note} {
1593 # From elf/common.h.
1594 set NT_GNU_BUILD_ID 3
1596 _note $NT_GNU_BUILD_ID GNU $buildid
1600 # The top-level interface to the DWARF assembler.
1601 # FILENAME is the name of the file where the generated assembly
1603 # BODY is Tcl code to emit the assembly. It is evaluated via
1604 # "eval" -- not uplevel as you might expect, because it is
1605 # important to run the body in the Dwarf namespace.
1607 # A typical invocation is something like:
1608 # Dwarf::assemble $file {
1618 proc assemble {filename body} {
1619 variable _initialized
1620 variable _output_file
1621 variable _deferred_output
1626 variable _line_count
1627 variable _line_saw_file
1628 variable _line_saw_program
1629 variable _line_header_end_label
1630 variable _debug_ranges_64_bit
1632 if {!$_initialized} {
1637 set _output_file [open $filename w]
1639 _empty_array _deferred_output
1642 _empty_array _strings
1645 set _line_saw_file 0
1646 set _line_saw_program 0
1647 set _debug_ranges_64_bit [is_64_target]
1649 # Not "uplevel" here, because we want to evaluate in this
1650 # namespace. This is somewhat bad because it means we can't
1651 # readily refer to outer variables.
1654 _write_deferred_output
1656 catch {close $_output_file}