diff options
Diffstat (limited to '')
| -rw-r--r-- | testsuite/lib/dwarf.exp | 1674 |
1 files changed, 1674 insertions, 0 deletions
diff --git a/testsuite/lib/dwarf.exp b/testsuite/lib/dwarf.exp new file mode 100644 index 0000000..4dbbc6c --- /dev/null +++ b/testsuite/lib/dwarf.exp @@ -0,0 +1,1674 @@ +# Copyright 2010-2020 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see <http://www.gnu.org/licenses/>. + +# This was copied from the git://sourceware.org/git/binutils-gdb.git +# repository, file gdb/testsuite/lib/dwarf.exp + +# Return true if the target supports DWARF-2 and uses gas. +# For now pick a sampling of likely targets. +proc dwarf2_support {} { + if {[istarget *-*-linux*] + || [istarget *-*-gnu*] + || [istarget *-*-elf*] + || [istarget *-*-openbsd*] + || [istarget arm*-*-eabi*] + || [istarget arm*-*-symbianelf*] + || [istarget powerpc-*-eabi*]} { + return 1 + } + + return 0 +} + +# Build an executable from a fission-based .S file. +# This handles the extra work of splitting the .o into non-dwo and dwo +# pieces, making sure the .dwo is available if we're using cc-with-tweaks.sh +# to build a .dwp file. +# The arguments and results are the same as for build_executable. +# +# Current restrictions: +# - only supports one source file +# - cannot be run on remote hosts + +proc build_executable_from_fission_assembler { testname executable sources options } { + verbose -log "build_executable_from_fission_assembler $testname $executable $sources $options" + if { [llength $sources] != 1 } { + error "Only one source file supported." + } + if [is_remote host] { + error "Remote hosts are not supported." + } + + global srcdir subdir + set source_file ${srcdir}/${subdir}/${sources} + set root_name [file rootname [file tail $source_file]] + set output_base [standard_output_file $root_name] + set object_file ${output_base}.o + set dwo_file ${output_base}.dwo + set object_options "object $options" + set objcopy [gdb_find_objcopy] + + set result [gdb_compile $source_file $object_file object $options] + if { "$result" != "" } { + return -1 + } + + set command "$objcopy --extract-dwo $object_file $dwo_file" + verbose -log "Executing $command" + set result [catch "exec $command" output] + verbose -log "objcopy --extract-dwo output: $output" + if { $result == 1 } { + return -1 + } + + set command "$objcopy --strip-dwo $object_file" + verbose -log "Executing $command" + set result [catch "exec $command" output] + verbose -log "objcopy --strip-dwo output: $output" + if { $result == 1 } { + return -1 + } + + set result [gdb_compile $object_file $executable executable $options] + if { "$result" != "" } { + return -1 + } + + return 0 +} + +# Return a list of expressions about function FUNC's address and length. +# The first expression is the address of function FUNC, and the second +# one is FUNC's length. SRC is the source file having function FUNC. +# An internal label ${func}_label must be defined inside FUNC: +# +# int main (void) +# { +# asm ("main_label: .globl main_label"); +# return 0; +# } +# +# This label is needed to compute the start address of function FUNC. +# If the compiler is gcc, we can do the following to get function start +# and end address too: +# +# asm ("func_start: .globl func_start"); +# static void func (void) {} +# asm ("func_end: .globl func_end"); +# +# however, this isn't portable, because other compilers, such as clang, +# may not guarantee the order of global asms and function. The code +# becomes: +# +# asm ("func_start: .globl func_start"); +# asm ("func_end: .globl func_end"); +# static void func (void) {} +# + +proc function_range { func src {options {debug}} } { + global decimal gdb_prompt + + set exe [standard_temp_file func_addr[pid].x] + + gdb_compile $src $exe executable $options + + gdb_exit + gdb_start + gdb_load "$exe" + + # Compute the label offset, and we can get the function start address + # by "${func}_label - $func_label_offset". + set func_label_offset "" + set test "p ${func}_label - ${func}" + gdb_test_multiple $test $test { + -re ".* = ($decimal)\r\n$gdb_prompt $" { + set func_label_offset $expect_out(1,string) + } + } + + # Compute the function length. + global hex + set func_length "" + set test "disassemble $func" + gdb_test_multiple $test $test { + -re ".*$hex <\\+($decimal)>:\[^\r\n\]+\r\nEnd of assembler dump\.\r\n$gdb_prompt $" { + set func_length $expect_out(1,string) + } + } + + # Compute the size of the last instruction. + if { $func_length == 0 } then { + set func_pattern "$func" + } else { + set func_pattern "$func\\+$func_length" + } + set test "x/2i $func+$func_length" + gdb_test_multiple $test $test { + -re ".*($hex) <$func_pattern>:\[^\r\n\]+\r\n\[ \]+($hex).*\.\r\n$gdb_prompt $" { + set start $expect_out(1,string) + set end $expect_out(2,string) + + set func_length [expr $func_length + $end - $start] + } + } + + return [list "${func}_label - $func_label_offset" $func_length] +} + +# Extract the start, length, and end for function called NAME and +# create suitable variables in the callers scope. +proc get_func_info { name {options {debug}} } { + global srcdir subdir srcfile + + upvar 1 "${name}_start" func_start + upvar 1 "${name}_len" func_len + upvar 1 "${name}_end" func_end + + lassign [function_range ${name} \ + [list ${srcdir}/${subdir}/$srcfile] \ + ${options}] \ + func_start func_len + set func_end "$func_start + $func_len" +} + +# A DWARF assembler. +# +# All the variables in this namespace are private to the +# implementation. Also, any procedure whose name starts with "_" is +# private as well. Do not use these. +# +# Exported functions are documented at their definition. +# +# In addition to the hand-written functions documented below, this +# module automatically generates a function for each DWARF tag. For +# most tags, two forms are made: a full name, and one with the +# "DW_TAG_" prefix stripped. For example, you can use either +# 'DW_TAG_compile_unit' or 'compile_unit' interchangeably. +# +# There are two exceptions to this rule: DW_TAG_variable and +# DW_TAG_namespace. For these, the full name must always be used, +# as the short name conflicts with Tcl builtins. (Should future +# versions of Tcl or DWARF add more conflicts, this list will grow. +# If you want to be safe you should always use the full names.) +# +# Each tag procedure is defined like: +# +# proc DW_TAG_mumble {{attrs {}} {children {}}} { ... } +# +# ATTRS is an optional list of attributes. +# It is run through 'subst' in the caller's context before processing. +# +# Each attribute in the list has one of two forms: +# 1. { NAME VALUE } +# 2. { NAME VALUE FORM } +# +# In each case, NAME is the attribute's name. +# This can either be the full name, like 'DW_AT_name', or a shortened +# name, like 'name'. These are fully equivalent. +# +# Besides DWARF standard attributes, assembler supports 'macro' attribute +# which will be substituted by one or more standard or macro attributes. +# supported macro attributes are: +# +# - MACRO_AT_range { FUNC } +# It is substituted by DW_AT_low_pc and DW_AT_high_pc with the start and +# end address of function FUNC in file $srcdir/$subdir/$srcfile. +# +# - MACRO_AT_func { FUNC } +# It is substituted by DW_AT_name with FUNC and MACRO_AT_range. +# +# If FORM is given, it should name a DW_FORM_ constant. +# This can either be the short form, like 'DW_FORM_addr', or a +# shortened version, like 'addr'. If the form is given, VALUE +# is its value; see below. In some cases, additional processing +# is done; for example, DW_FORM_strp manages the .debug_str +# section automatically. +# +# If FORM is 'SPECIAL_expr', then VALUE is treated as a location +# expression. The effective form is then DW_FORM_block or DW_FORM_exprloc +# for DWARF version >= 4, and VALUE is passed to the (internal) +# '_location' proc to be translated. +# This proc implements a miniature DW_OP_ assembler. +# +# If FORM is not given, it is guessed: +# * If VALUE starts with the "@" character, the rest of VALUE is +# looked up as a DWARF constant, and DW_FORM_sdata is used. For +# example, '@DW_LANG_c89' could be used. +# * If VALUE starts with the ":" character, then it is a label +# reference. The rest of VALUE is taken to be the name of a label, +# and DW_FORM_ref4 is used. See 'new_label' and 'define_label'. +# * If VALUE starts with the "%" character, then it is a label +# reference too, but DW_FORM_ref_addr is used. +# * Otherwise, if the attribute name has a default form (f.i. DW_FORM_addr for +# DW_AT_low_pc), then that one is used. +# * Otherwise, an error is reported. Either specify a form explicitly, or +# add a default for the the attribute name in _default_form. +# +# CHILDREN is just Tcl code that can be used to define child DIEs. It +# is evaluated in the caller's context. +# +# Currently this code is missing nice support for CFA handling, and +# probably other things as well. + +namespace eval Dwarf { + # True if the module has been initialized. + variable _initialized 0 + + # Constants from dwarf2.h. + variable _constants + # DW_AT short names. + variable _AT + # DW_FORM short names. + variable _FORM + # DW_OP short names. + variable _OP + + # The current output file. + variable _output_file + + # Note: The _cu_ values here also apply to type units (TUs). + # Think of a TU as a special kind of CU. + + # Current CU count. + variable _cu_count + + # The current CU's base label. + variable _cu_label + + # The current CU's version. + variable _cu_version + + # The current CU's address size. + variable _cu_addr_size + # The current CU's offset size. + variable _cu_offset_size + + # Label generation number. + variable _label_num + + # The deferred output array. The index is the section name; the + # contents hold the data for that section. + variable _deferred_output + + # If empty, we should write directly to the output file. + # Otherwise, this is the name of a section to write to. + variable _defer + + # The abbrev section. Typically .debug_abbrev but can be .debug_abbrev.dwo + # for Fission. + variable _abbrev_section + + # The next available abbrev number in the current CU's abbrev + # table. + variable _abbrev_num + + # The string table for this assembly. The key is the string; the + # value is the label for that string. + variable _strings + + # Current .debug_line unit count. + variable _line_count + + # Whether a file_name entry was seen. + variable _line_saw_file + + # Whether a line table program has been seen. + variable _line_saw_program + + # A Label for line table header generation. + variable _line_header_end_label + + # The address size for debug ranges section. + variable _debug_ranges_64_bit + + proc _process_one_constant {name value} { + variable _constants + variable _AT + variable _FORM + variable _OP + + set _constants($name) $value + + if {![regexp "^DW_(\[A-Z\]+)_(\[A-Za-z0-9_\]+)$" $name \ + ignore prefix name2]} { + error "non-matching name: $name" + } + + if {$name2 == "lo_user" || $name2 == "hi_user"} { + return + } + + # We only try to shorten some very common things. + # FIXME: CFA? + switch -exact -- $prefix { + TAG { + # Create two procedures for the tag. These call + # _handle_DW_TAG with the full tag name baked in; this + # does all the actual work. + proc $name {{attrs {}} {children {}}} \ + "_handle_DW_TAG $name \$attrs \$children" + + # Filter out ones that are known to clash. + if {$name2 == "variable" || $name2 == "namespace"} { + set name2 "tag_$name2" + } + + if {[info commands $name2] != {}} { + error "duplicate proc name: from $name" + } + + proc $name2 {{attrs {}} {children {}}} \ + "_handle_DW_TAG $name \$attrs \$children" + } + + AT { + set _AT($name2) $name + } + + FORM { + set _FORM($name2) $name + } + + OP { + set _OP($name2) $name + } + + default { + return + } + } + } + + proc _read_constants {} { + global srcdir hex decimal + + # DWARF name-matching regexp. + set dwrx "DW_\[a-zA-Z0-9_\]+" + # Whitespace regexp. + set ws "\[ \t\]+" + + set fd [open [file join $srcdir .. dwarf2.h]] + while {![eof $fd]} { + set line [gets $fd] + if {[regexp -- "^${ws}($dwrx)${ws}=${ws}($hex|$decimal),?$" \ + $line ignore name value ignore2]} { + _process_one_constant $name $value + } + } + close $fd + + set fd [open [file join $srcdir .. dwarf2.def]] + while {![eof $fd]} { + set line [gets $fd] + if {[regexp -- \ + "^DW_\[A-Z_\]+${ws}\\(($dwrx),${ws}($hex|$decimal)\\)$" \ + $line ignore name value ignore2]} { + _process_one_constant $name $value + } + } + close $fd + } + + proc _quote {string} { + # FIXME + return "\"${string}\\0\"" + } + + proc _nz_quote {string} { + # For now, no quoting is done. + return "\"${string}\"" + } + + proc _handle_DW_FORM {form value} { + switch -exact -- $form { + DW_FORM_string { + _op .ascii [_quote $value] + } + + DW_FORM_flag_present { + # We don't need to emit anything. + } + + DW_FORM_data4 - + DW_FORM_ref4 { + _op .4byte $value + } + + DW_FORM_ref_addr { + variable _cu_offset_size + variable _cu_version + variable _cu_addr_size + + if {$_cu_version == 2} { + set size $_cu_addr_size + } else { + set size $_cu_offset_size + } + + _op .${size}byte $value + } + + DW_FORM_sec_offset { + variable _cu_offset_size + _op .${_cu_offset_size}byte $value + } + + DW_FORM_ref1 - + DW_FORM_flag - + DW_FORM_data1 { + _op .byte $value + } + + DW_FORM_sdata { + _op .sleb128 $value + } + + DW_FORM_ref_udata - + DW_FORM_udata { + _op .uleb128 $value + } + + DW_FORM_addr { + variable _cu_addr_size + + _op .${_cu_addr_size}byte $value + } + + DW_FORM_data2 - + DW_FORM_ref2 { + _op .2byte $value + } + + DW_FORM_data8 - + DW_FORM_ref8 - + DW_FORM_ref_sig8 { + _op .8byte $value + } + + DW_FORM_data16 { + _op .8byte $value + } + + DW_FORM_strp { + variable _strings + variable _cu_offset_size + + if {![info exists _strings($value)]} { + set _strings($value) [new_label strp] + _defer_output .debug_string { + define_label $_strings($value) + _op .ascii [_quote $value] + } + } + + _op .${_cu_offset_size}byte $_strings($value) "strp: $value" + } + + SPECIAL_expr { + set l1 [new_label "expr_start"] + set l2 [new_label "expr_end"] + _op .uleb128 "$l2 - $l1" "expression" + define_label $l1 + _location $value + define_label $l2 + } + + DW_FORM_block1 { + set len [string length $value] + if {$len > 255} { + error "DW_FORM_block1 length too long" + } + _op .byte $len + _op .ascii [_nz_quote $value] + } + + DW_FORM_block2 - + DW_FORM_block4 - + + DW_FORM_block - + + DW_FORM_ref2 - + DW_FORM_indirect - + DW_FORM_exprloc - + + DW_FORM_strx - + DW_FORM_strx1 - + DW_FORM_strx2 - + DW_FORM_strx3 - + DW_FORM_strx4 - + + DW_FORM_GNU_addr_index - + DW_FORM_GNU_str_index - + DW_FORM_GNU_ref_alt - + DW_FORM_GNU_strp_alt - + + default { + error "unhandled form $form" + } + } + } + + proc _guess_form {value varname} { + upvar $varname new_value + + switch -exact -- [string range $value 0 0] { + @ { + # Constant reference. + variable _constants + + set new_value $_constants([string range $value 1 end]) + # Just the simplest. + return DW_FORM_sdata + } + + : { + # Label reference. + variable _cu_label + + set new_value "[string range $value 1 end] - $_cu_label" + + return DW_FORM_ref4 + } + + % { + # Label reference, an offset from .debug_info. + set new_value "[string range $value 1 end]" + + return DW_FORM_ref_addr + } + + default { + return "" + } + } + } + + proc _default_form { attr } { + switch -exact -- $attr { + DW_AT_low_pc { + return DW_FORM_addr + } + DW_AT_producer - + DW_AT_comp_dir - + DW_AT_linkage_name - + DW_AT_MIPS_linkage_name - + DW_AT_name { + return DW_FORM_string + } + } + return "" + } + + # Map NAME to its canonical form. + proc _map_name {name ary} { + variable $ary + + if {[info exists ${ary}($name)]} { + set name [set ${ary}($name)] + } + + return $name + } + + proc _handle_attribute { attr_name attr_value attr_form } { + variable _abbrev_section + variable _constants + variable _cu_version + + _handle_DW_FORM $attr_form $attr_value + + _defer_output $_abbrev_section { + if { $attr_form eq "SPECIAL_expr" } { + if { $_cu_version < 4 } { + set attr_form_comment "DW_FORM_block" + } else { + set attr_form_comment "DW_FORM_exprloc" + } + } else { + set attr_form_comment $attr_form + } + _op .uleb128 $_constants($attr_name) $attr_name + _op .uleb128 $_constants($attr_form) $attr_form_comment + } + } + + # Handle macro attribute MACRO_AT_range. + + proc _handle_macro_at_range { attr_value } { + if {[llength $attr_value] != 1} { + error "usage: MACRO_AT_range { func }" + } + + set func [lindex $attr_value 0] + global srcdir subdir srcfile + set src ${srcdir}/${subdir}/${srcfile} + set result [function_range $func $src] + + _handle_attribute DW_AT_low_pc [lindex $result 0] \ + DW_FORM_addr + _handle_attribute DW_AT_high_pc \ + "[lindex $result 0] + [lindex $result 1]" DW_FORM_addr + } + + # Handle macro attribute MACRO_AT_func. + + proc _handle_macro_at_func { attr_value } { + if {[llength $attr_value] != 1} { + error "usage: MACRO_AT_func { func file }" + } + _handle_attribute DW_AT_name [lindex $attr_value 0] DW_FORM_string + _handle_macro_at_range $attr_value + } + + proc _handle_DW_TAG {tag_name {attrs {}} {children {}}} { + variable _abbrev_section + variable _abbrev_num + variable _constants + + set has_children [expr {[string length $children] > 0}] + set my_abbrev [incr _abbrev_num] + + # We somewhat wastefully emit a new abbrev entry for each tag. + # There's no reason for this other than laziness. + _defer_output $_abbrev_section { + _op .uleb128 $my_abbrev "Abbrev start" + _op .uleb128 $_constants($tag_name) $tag_name + _op .byte $has_children "has_children" + } + + _op .uleb128 $my_abbrev "Abbrev ($tag_name)" + + foreach attr $attrs { + set attr_name [_map_name [lindex $attr 0] _AT] + + # When the length of ATTR is greater than 2, the last + # element of the list must be a form. The second through + # the penultimate elements are joined together and + # evaluated using subst. This allows constructs such as + # [gdb_target_symbol foo] to be used. + + if {[llength $attr] > 2} { + set attr_value [uplevel 2 [list subst [join [lrange $attr 1 end-1]]]] + } else { + set attr_value [uplevel 2 [list subst [lindex $attr 1]]] + } + + if { [string equal "MACRO_AT_func" $attr_name] } { + _handle_macro_at_func $attr_value + } elseif { [string equal "MACRO_AT_range" $attr_name] } { + _handle_macro_at_range $attr_value + } else { + if {[llength $attr] > 2} { + set attr_form [uplevel 2 [list subst [lindex $attr end]]] + + if { [string index $attr_value 0] == ":" } { + # It is a label, get its value. + _guess_form $attr_value attr_value + } + } else { + set attr_form [_guess_form $attr_value attr_value] + if { $attr_form eq "" } { + set attr_form [_default_form $attr_name] + } + if { $attr_form eq "" } { + error "No form for $attr_name $attr_value" + } + } + set attr_form [_map_name $attr_form _FORM] + + _handle_attribute $attr_name $attr_value $attr_form + } + } + + _defer_output $_abbrev_section { + # Terminator. + _op .byte 0x0 "DW_AT - Terminator" + _op .byte 0x0 "DW_FORM - Terminator" + } + + if {$has_children} { + uplevel 2 $children + + # Terminate children. + _op .byte 0x0 "Terminate children" + } + } + + proc _emit {string} { + variable _output_file + variable _defer + variable _deferred_output + + if {$_defer == ""} { + puts $_output_file $string + } else { + append _deferred_output($_defer) ${string}\n + } + } + + proc _section {name {flags ""} {type ""}} { + if {$flags == "" && $type == ""} { + _emit " .section $name" + } elseif {$type == ""} { + _emit " .section $name, \"$flags\"" + } else { + _emit " .section $name, \"$flags\", %$type" + } + } + + # SECTION_SPEC is a list of arguments to _section. + proc _defer_output {section_spec body} { + variable _defer + variable _deferred_output + + set old_defer $_defer + set _defer [lindex $section_spec 0] + + if {![info exists _deferred_output($_defer)]} { + set _deferred_output($_defer) "" + eval _section $section_spec + } + + uplevel $body + + set _defer $old_defer + } + + proc _defer_to_string {body} { + variable _defer + variable _deferred_output + + set old_defer $_defer + set _defer temp + + set _deferred_output($_defer) "" + + uplevel $body + + set result $_deferred_output($_defer) + unset _deferred_output($_defer) + + set _defer $old_defer + return $result + } + + proc _write_deferred_output {} { + variable _output_file + variable _deferred_output + + foreach section [array names _deferred_output] { + # The data already has a newline. + puts -nonewline $_output_file $_deferred_output($section) + } + + # Save some memory. + unset _deferred_output + } + + proc _op {name value {comment ""}} { + set text " ${name} ${value}" + if {$comment != ""} { + # Try to make stuff line up nicely. + while {[string length $text] < 40} { + append text " " + } + append text "/* ${comment} */" + } + _emit $text + } + + proc _compute_label {name} { + return ".L${name}" + } + + # Return a name suitable for use as a label. If BASE_NAME is + # specified, it is incorporated into the label name; this is to + # make debugging the generated assembler easier. If BASE_NAME is + # not specified a generic default is used. This proc does not + # define the label; see 'define_label'. 'new_label' attempts to + # ensure that label names are unique. + proc new_label {{base_name label}} { + variable _label_num + + return [_compute_label ${base_name}[incr _label_num]] + } + + # Define a label named NAME. Ordinarily, NAME comes from a call + # to 'new_label', but this is not required. + proc define_label {name} { + _emit "${name}:" + } + + # A higher-level interface to label handling. + # + # ARGS is a list of label descriptors. Each one is either a + # single element, or a list of two elements -- a name and some + # text. For each descriptor, 'new_label' is invoked. If the list + # form is used, the second element in the list is passed as an + # argument. The label name is used to define a variable in the + # enclosing scope; this can be used to refer to the label later. + # The label name is also used to define a new proc whose name is + # the label name plus a trailing ":". This proc takes a body as + # an argument and can be used to define the label at that point; + # then the body, if any, is evaluated in the caller's context. + # + # For example: + # + # declare_labels int_label + # something { ... $int_label } ;# refer to the label + # int_label: constant { ... } ;# define the label + proc declare_labels {args} { + foreach arg $args { + set name [lindex $arg 0] + set text [lindex $arg 1] + + if { $text == "" } { + set text $name + } + + upvar $name label_var + set label_var [new_label $text] + + proc ${name}: {args} [format { + define_label %s + uplevel $args + } $label_var] + } + } + + # This is a miniature assembler for location expressions. It is + # suitable for use in the attributes to a DIE. Its output is + # prefixed with "=" to make it automatically use DW_FORM_block. + # BODY is split by lines, and each line is taken to be a list. + # (FIXME should use 'info complete' here.) + # Each list's first element is the opcode, either short or long + # forms are accepted. + # FIXME argument handling + # FIXME move docs + proc _location {body} { + variable _constants + variable _cu_label + variable _cu_version + variable _cu_addr_size + variable _cu_offset_size + + foreach line [split $body \n] { + # Ignore blank lines, and allow embedded comments. + if {[lindex $line 0] == "" || [regexp -- {^[ \t]*#} $line]} { + continue + } + set opcode [_map_name [lindex $line 0] _OP] + _op .byte $_constants($opcode) $opcode + + switch -exact -- $opcode { + DW_OP_addr { + _op .${_cu_addr_size}byte [lindex $line 1] + } + + DW_OP_regx { + _op .uleb128 [lindex $line 1] + } + + DW_OP_pick - + DW_OP_const1u - + DW_OP_const1s { + _op .byte [lindex $line 1] + } + + DW_OP_const2u - + DW_OP_const2s { + _op .2byte [lindex $line 1] + } + + DW_OP_const4u - + DW_OP_const4s { + _op .4byte [lindex $line 1] + } + + DW_OP_const8u - + DW_OP_const8s { + _op .8byte [lindex $line 1] + } + + DW_OP_constu { + _op .uleb128 [lindex $line 1] + } + DW_OP_consts { + _op .sleb128 [lindex $line 1] + } + + DW_OP_plus_uconst { + _op .uleb128 [lindex $line 1] + } + + DW_OP_piece { + _op .uleb128 [lindex $line 1] + } + + DW_OP_bit_piece { + _op .uleb128 [lindex $line 1] + _op .uleb128 [lindex $line 2] + } + + DW_OP_skip - + DW_OP_bra { + _op .2byte [lindex $line 1] + } + + DW_OP_implicit_value { + set l1 [new_label "value_start"] + set l2 [new_label "value_end"] + _op .uleb128 "$l2 - $l1" + define_label $l1 + foreach value [lrange $line 1 end] { + switch -regexp -- $value { + {^0x[[:xdigit:]]{1,2}$} {_op .byte $value} + {^0x[[:xdigit:]]{4}$} {_op .2byte $value} + {^0x[[:xdigit:]]{8}$} {_op .4byte $value} + {^0x[[:xdigit:]]{16}$} {_op .8byte $value} + default { + error "bad value '$value' in DW_OP_implicit_value" + } + } + } + define_label $l2 + } + + DW_OP_implicit_pointer - + DW_OP_GNU_implicit_pointer { + if {[llength $line] != 3} { + error "usage: $opcode LABEL OFFSET" + } + + # Here label is a section offset. + set label [lindex $line 1] + if { $_cu_version == 2 } { + _op .${_cu_addr_size}byte $label + } else { + _op .${_cu_offset_size}byte $label + } + _op .sleb128 [lindex $line 2] + } + + DW_OP_GNU_variable_value { + if {[llength $line] != 2} { + error "usage: $opcode LABEL" + } + + # Here label is a section offset. + set label [lindex $line 1] + if { $_cu_version == 2 } { + _op .${_cu_addr_size}byte $label + } else { + _op .${_cu_offset_size}byte $label + } + } + + DW_OP_deref_size { + if {[llength $line] != 2} { + error "usage: DW_OP_deref_size SIZE" + } + + _op .byte [lindex $line 1] + } + + DW_OP_bregx { + _op .uleb128 [lindex $line 1] + _op .sleb128 [lindex $line 2] + } + + default { + if {[llength $line] > 1} { + error "Unimplemented: operands in location for $opcode" + } + } + } + } + } + + # Emit a DWARF CU. + # OPTIONS is a list with an even number of elements containing + # option-name and option-value pairs. + # Current options are: + # is_64 0|1 - boolean indicating if you want to emit 64-bit DWARF + # default = 0 (32-bit) + # version n - DWARF version number to emit + # default = 4 + # addr_size n - the size of addresses in bytes: 4, 8, or default + # default = default + # fission 0|1 - boolean indicating if generating Fission debug info + # default = 0 + # BODY is Tcl code that emits the DIEs which make up the body of + # the CU. It is evaluated in the caller's context. + proc cu {options body} { + variable _constants + variable _cu_count + variable _abbrev_section + variable _abbrev_num + variable _cu_label + variable _cu_version + variable _cu_addr_size + variable _cu_offset_size + + # Establish the defaults. + set is_64 0 + set _cu_version 4 + set _cu_addr_size default + set fission 0 + set section ".debug_info" + set _abbrev_section ".debug_abbrev" + + foreach { name value } $options { + set value [uplevel 1 "subst \"$value\""] + switch -exact -- $name { + is_64 { set is_64 $value } + version { set _cu_version $value } + addr_size { set _cu_addr_size $value } + fission { set fission $value } + default { error "unknown option $name" } + } + } + if {$_cu_addr_size == "default"} { + if {[is_64_target]} { + set _cu_addr_size 8 + } else { + set _cu_addr_size 4 + } + } + set _cu_offset_size [expr { $is_64 ? 8 : 4 }] + if { $fission } { + set section ".debug_info.dwo" + set _abbrev_section ".debug_abbrev.dwo" + } + + if {$_cu_version < 4} { + set _constants(SPECIAL_expr) $_constants(DW_FORM_block) + } else { + set _constants(SPECIAL_expr) $_constants(DW_FORM_exprloc) + } + + _section $section + + set cu_num [incr _cu_count] + set my_abbrevs [_compute_label "abbrev${cu_num}_begin"] + set _abbrev_num 1 + + set _cu_label [_compute_label "cu${cu_num}_begin"] + set start_label [_compute_label "cu${cu_num}_start"] + set end_label [_compute_label "cu${cu_num}_end"] + + define_label $_cu_label + if {$is_64} { + _op .4byte 0xffffffff + _op .8byte "$end_label - $start_label" + } else { + _op .4byte "$end_label - $start_label" + } + define_label $start_label + _op .2byte $_cu_version Version + _op .${_cu_offset_size}byte $my_abbrevs Abbrevs + _op .byte $_cu_addr_size "Pointer size" + + _defer_output $_abbrev_section { + define_label $my_abbrevs + } + + uplevel $body + + _defer_output $_abbrev_section { + # Emit the terminator. + _op .byte 0x0 "Abbrev end - Terminator" + } + + define_label $end_label + } + + # Emit a DWARF TU. + # OPTIONS is a list with an even number of elements containing + # option-name and option-value pairs. + # Current options are: + # is_64 0|1 - boolean indicating if you want to emit 64-bit DWARF + # default = 0 (32-bit) + # version n - DWARF version number to emit + # default = 4 + # addr_size n - the size of addresses in bytes: 4, 8, or default + # default = default + # fission 0|1 - boolean indicating if generating Fission debug info + # default = 0 + # SIGNATURE is the 64-bit signature of the type. + # TYPE_LABEL is the label of the type defined by this TU, + # or "" if there is no type (i.e., type stubs in Fission). + # BODY is Tcl code that emits the DIEs which make up the body of + # the TU. It is evaluated in the caller's context. + proc tu {options signature type_label body} { + variable _cu_count + variable _abbrev_section + variable _abbrev_num + variable _cu_label + variable _cu_version + variable _cu_addr_size + variable _cu_offset_size + + # Establish the defaults. + set is_64 0 + set _cu_version 4 + set _cu_addr_size default + set fission 0 + set section ".debug_types" + set _abbrev_section ".debug_abbrev" + + foreach { name value } $options { + switch -exact -- $name { + is_64 { set is_64 $value } + version { set _cu_version $value } + addr_size { set _cu_addr_size $value } + fission { set fission $value } + default { error "unknown option $name" } + } + } + if {$_cu_addr_size == "default"} { + if {[is_64_target]} { + set _cu_addr_size 8 + } else { + set _cu_addr_size 4 + } + } + set _cu_offset_size [expr { $is_64 ? 8 : 4 }] + if { $fission } { + set section ".debug_types.dwo" + set _abbrev_section ".debug_abbrev.dwo" + } + + _section $section + + set cu_num [incr _cu_count] + set my_abbrevs [_compute_label "abbrev${cu_num}_begin"] + set _abbrev_num 1 + + set _cu_label [_compute_label "cu${cu_num}_begin"] + set start_label [_compute_label "cu${cu_num}_start"] + set end_label [_compute_label "cu${cu_num}_end"] + + define_label $_cu_label + if {$is_64} { + _op .4byte 0xffffffff + _op .8byte "$end_label - $start_label" + } else { + _op .4byte "$end_label - $start_label" + } + define_label $start_label + _op .2byte $_cu_version Version + _op .${_cu_offset_size}byte $my_abbrevs Abbrevs + _op .byte $_cu_addr_size "Pointer size" + _op .8byte $signature Signature + if { $type_label != "" } { + uplevel declare_labels $type_label + upvar $type_label my_type_label + if {$is_64} { + _op .8byte "$my_type_label - $_cu_label" + } else { + _op .4byte "$my_type_label - $_cu_label" + } + } else { + if {$is_64} { + _op .8byte 0 + } else { + _op .4byte 0 + } + } + + _defer_output $_abbrev_section { + define_label $my_abbrevs + } + + uplevel $body + + _defer_output $_abbrev_section { + # Emit the terminator. + _op .byte 0x0 "Abbrev end - Terminator" + } + + define_label $end_label + } + + # Emit a DWARF .debug_ranges unit. + # OPTIONS is a list with an even number of elements containing + # option-name and option-value pairs. + # Current options are: + # is_64 0|1 - boolean indicating if you want to emit 64-bit DWARF + # default = 0 (32-bit) + # + # BODY is Tcl code that emits the content of the .debug_ranges + # unit, it is evaluated in the caller's context. + proc ranges {options body} { + variable _debug_ranges_64_bit + + foreach { name value } $options { + switch -exact -- $name { + is_64 { set _debug_ranges_64_bit [subst $value] } + default { error "unknown option $name" } + } + } + + set section ".debug_ranges" + _section $section + + proc sequence { body } { + variable _debug_ranges_64_bit + + # Emit the sequence of addresses. + + proc base { addr } { + variable _debug_ranges_64_bit + + if { $_debug_ranges_64_bit } then { + _op .8byte 0xffffffffffffffff "Base Marker" + _op .8byte $addr "Base Address" + } else { + _op .4byte 0xffffffff "Base Marker" + _op .4byte $addr "Base Address" + } + } + + proc range { start end } { + variable _debug_ranges_64_bit + + if { $_debug_ranges_64_bit } then { + _op .8byte $start "Start Address" + _op .8byte $end "End Address" + } else { + _op .4byte $start "Start Address" + _op .4byte $end "End Address" + } + } + + uplevel $body + + # End of the sequence. + if { $_debug_ranges_64_bit } then { + _op .8byte 0x0 "End of Sequence Marker (Part 1)" + _op .8byte 0x0 "End of Sequence Marker (Part 2)" + } else { + _op .4byte 0x0 "End of Sequence Marker (Part 1)" + _op .4byte 0x0 "End of Sequence Marker (Part 2)" + } + } + + uplevel $body + } + + + # Emit a DWARF .debug_line unit. + # OPTIONS is a list with an even number of elements containing + # option-name and option-value pairs. + # Current options are: + # is_64 0|1 - boolean indicating if you want to emit 64-bit DWARF + # default = 0 (32-bit) + # version n - DWARF version number to emit + # default = 4 + # addr_size n - the size of addresses in bytes: 4, 8, or default + # default = default + # + # LABEL is the label of the current unit (which is probably + # referenced by a DW_AT_stmt_list), or "" if there is no such + # label. + # + # BODY is Tcl code that emits the parts which make up the body of + # the line unit. It is evaluated in the caller's context. The + # following commands are available for the BODY section: + # + # include_dir "dirname" -- adds a new include directory + # + # file_name "file.c" idx -- adds a new file name. IDX is a + # 1-based index referencing an include directory or 0 for + # current directory. + + proc lines {options label body} { + variable _line_count + variable _line_saw_file + variable _line_saw_program + variable _line_header_end_label + + # Establish the defaults. + set is_64 0 + set _unit_version 4 + set _unit_addr_size default + set _line_saw_program 0 + set _line_saw_file 0 + set _default_is_stmt 1 + + foreach { name value } $options { + switch -exact -- $name { + is_64 { set is_64 $value } + version { set _unit_version $value } + addr_size { set _unit_addr_size $value } + default_is_stmt { set _default_is_stmt $value } + default { error "unknown option $name" } + } + } + if {$_unit_addr_size == "default"} { + if {[is_64_target]} { + set _unit_addr_size 8 + } else { + set _unit_addr_size 4 + } + } + + set unit_num [incr _line_count] + + set section ".debug_line" + _section $section + + if { "$label" != "" } { + # Define the user-provided label at this point. + $label: + } + + set unit_len_label [_compute_label "line${_line_count}_start"] + set unit_end_label [_compute_label "line${_line_count}_end"] + set header_len_label [_compute_label "line${_line_count}_header_start"] + set _line_header_end_label [_compute_label "line${_line_count}_header_end"] + + if {$is_64} { + _op .4byte 0xffffffff + _op .8byte "$unit_end_label - $unit_len_label" "unit_length" + } else { + _op .4byte "$unit_end_label - $unit_len_label" "unit_length" + } + + define_label $unit_len_label + + _op .2byte $_unit_version version + + if {$is_64} { + _op .8byte "$_line_header_end_label - $header_len_label" "header_length" + } else { + _op .4byte "$_line_header_end_label - $header_len_label" "header_length" + } + + define_label $header_len_label + + _op .byte 1 "minimum_instruction_length" + _op .byte $_default_is_stmt "default_is_stmt" + _op .byte 1 "line_base" + _op .byte 1 "line_range" + _op .byte 10 "opcode_base" + + # The standard_opcode_lengths table. The number of arguments + # for each of the standard opcodes. Generating 9 entries here + # matches the use of 10 in the opcode_base above. These 9 + # entries match the 9 standard opcodes for DWARF2, making use + # of only 9 should be fine, even if we are generating DWARF3 + # or DWARF4. + _op .byte 0 "standard opcode 1" + _op .byte 1 "standard opcode 2" + _op .byte 1 "standard opcode 3" + _op .byte 1 "standard opcode 4" + _op .byte 1 "standard opcode 5" + _op .byte 0 "standard opcode 6" + _op .byte 0 "standard opcode 7" + _op .byte 0 "standard opcode 8" + _op .byte 1 "standard opcode 9" + + proc include_dir {dirname} { + _op .ascii [_quote $dirname] + } + + proc file_name {filename diridx} { + variable _line_saw_file + if "! $_line_saw_file" { + # Terminate the dir list. + _op .byte 0 "Terminator." + set _line_saw_file 1 + } + + _op .ascii [_quote $filename] + _op .sleb128 $diridx + _op .sleb128 0 "mtime" + _op .sleb128 0 "length" + } + + proc program {statements} { + variable _line_saw_program + variable _line_header_end_label + variable _line + + set _line 1 + + if "! $_line_saw_program" { + # Terminate the file list. + _op .byte 0 "Terminator." + define_label $_line_header_end_label + set _line_saw_program 1 + } + + proc DW_LNE_set_address {addr} { + _op .byte 0 + set start [new_label "set_address_start"] + set end [new_label "set_address_end"] + _op .uleb128 "${end} - ${start}" + define_label ${start} + _op .byte 2 + if {[is_64_target]} { + _op .8byte ${addr} + } else { + _op .4byte ${addr} + } + define_label ${end} + } + + proc DW_LNE_end_sequence {} { + variable _line + _op .byte 0 + _op .uleb128 1 + _op .byte 1 + set _line 1 + } + + proc DW_LNE_user { len opcode } { + set DW_LNE_lo_usr 0x80 + set DW_LNE_hi_usr 0xff + if { $DW_LNE_lo_usr <= $opcode + && $opcode <= $DW_LNE_hi_usr } { + _op .byte 0 + _op .uleb128 $len + _op .byte $opcode + for {set i 1} {$i < $len} {incr i} { + _op .byte 0 + } + } else { + error "unknown vendor specific extended opcode: $opcode" + } + } + + proc DW_LNS_copy {} { + _op .byte 1 + } + + proc DW_LNS_negate_stmt {} { + _op .byte 6 + } + + proc DW_LNS_advance_pc {offset} { + _op .byte 2 + _op .uleb128 ${offset} + } + + proc DW_LNS_advance_line {offset} { + variable _line + _op .byte 3 + _op .sleb128 ${offset} + set _line [expr $_line + $offset] + } + + # A pseudo line number program instruction, that can be used instead + # of DW_LNS_advance_line. Rather than writing: + # {DW_LNS_advance_line [expr $line1 - 1]} + # {DW_LNS_advance_line [expr $line2 - $line1]} + # {DW_LNS_advance_line [expr $line3 - $line2]} + # we can just write: + # {line $line1} + # {line $line2} + # {line $line3} + proc line {line} { + variable _line + set offset [expr $line - $_line] + DW_LNS_advance_line $offset + } + + proc DW_LNS_set_file {num} { + _op .byte 4 + _op .sleb128 ${num} + } + + foreach statement $statements { + uplevel 1 $statement + } + } + + uplevel $body + + rename include_dir "" + rename file_name "" + + # Terminate dir list if we saw no files. + if "! $_line_saw_file" { + _op .byte 0 "Terminator." + } + + # Terminate the file list. + if "! $_line_saw_program" { + _op .byte 0 "Terminator." + define_label $_line_header_end_label + } + + define_label $unit_end_label + } + + proc _empty_array {name} { + upvar $name the_array + + catch {unset the_array} + set the_array(_) {} + unset the_array(_) + } + + # Emit a .gnu_debugaltlink section with the given file name and + # build-id. The buildid should be represented as a hexadecimal + # string, like "ffeeddcc". + proc gnu_debugaltlink {filename buildid} { + _defer_output .gnu_debugaltlink { + _op .ascii [_quote $filename] + foreach {a b} [split $buildid {}] { + _op .byte 0x$a$b + } + } + } + + proc _note {type name hexdata} { + set namelen [expr [string length $name] + 1] + + # Name size. + _op .4byte $namelen + # Data size. + _op .4byte [expr [string length $hexdata] / 2] + # Type. + _op .4byte $type + # The name. + _op .ascii [_quote $name] + # Alignment. + set align 2 + set total [expr {($namelen + (1 << $align) - 1) & -(1 << $align)}] + for {set i $namelen} {$i < $total} {incr i} { + _op .byte 0 + } + # The data. + foreach {a b} [split $hexdata {}] { + _op .byte 0x$a$b + } + } + + # Emit a note section holding the given build-id. + proc build_id {buildid} { + _defer_output {.note.gnu.build-id a note} { + # From elf/common.h. + set NT_GNU_BUILD_ID 3 + + _note $NT_GNU_BUILD_ID GNU $buildid + } + } + + # The top-level interface to the DWARF assembler. + # FILENAME is the name of the file where the generated assembly + # code is written. + # BODY is Tcl code to emit the assembly. It is evaluated via + # "eval" -- not uplevel as you might expect, because it is + # important to run the body in the Dwarf namespace. + # + # A typical invocation is something like: + # Dwarf::assemble $file { + # cu 0 2 8 { + # compile_unit { + # ... + # } + # } + # cu 0 2 8 { + # ... + # } + # } + proc assemble {filename body} { + variable _initialized + variable _output_file + variable _deferred_output + variable _defer + variable _label_num + variable _strings + variable _cu_count + variable _line_count + variable _line_saw_file + variable _line_saw_program + variable _line_header_end_label + variable _debug_ranges_64_bit + + if {!$_initialized} { + _read_constants + set _initialized 1 + } + + set _output_file [open $filename w] + set _cu_count 0 + _empty_array _deferred_output + set _defer "" + set _label_num 0 + _empty_array _strings + + set _line_count 0 + set _line_saw_file 0 + set _line_saw_program 0 + set _debug_ranges_64_bit [is_64_target] + + # Not "uplevel" here, because we want to evaluate in this + # namespace. This is somewhat bad because it means we can't + # readily refer to outer variables. + eval $body + + _write_deferred_output + + _section .note.GNU-stack "" progbits + + catch {close $_output_file} + set _output_file {} + } +} |