gdb.dwarf2: Define and use gdb_target_symbol for symbol prefixes

[deliverable/binutils-gdb.git] / gdb / testsuite / lib / dwarf.exp

# Copyright 2010-2015 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/>.

# 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 {nodebug}]
    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 } {
    global decimal gdb_prompt

    set exe [standard_temp_file func_addr[pid].x]

    gdb_compile $src $exe executable {debug}

    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]
}

# 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 FILE }
#  It is substituted by DW_AT_low_pc and DW_AT_high_pc with the start and
#  end address of function FUNC in file FILE.
#
#  - MACRO_AT_func { FUNC FILE }
#  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, 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'.
# * Otherwise, VALUE is taken to be a string and DW_FORM_string is
#   used.  In order to prevent bugs where a numeric value is given but
#   no form is specified, it is an error if the value looks like a number
#   (using Tcl's "string is integer") and no form is provided.
# More form-guessing functionality may be added.
#
# 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

    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
        variable _constants

        # DWARF name-matching regexp.
        set dwrx "DW_\[a-zA-Z0-9_\]+"
        # Whitespace regexp.
        set ws "\[ \t\]+"

        set fd [open [file join $srcdir .. .. include 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 .. .. include 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

        set _constants(SPECIAL_expr) $_constants(DW_FORM_block)
    }

    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_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_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
            }

            default {
                return DW_FORM_string
            }
        }
    }

    # 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

        _handle_DW_FORM $attr_form $attr_value

        _defer_output $_abbrev_section {
            _op .uleb128 $_constants($attr_name) $attr_name
            _op .uleb128 $_constants($attr_form) $attr_form
        }
    }

    # Handle macro attribute MACRO_AT_range.

    proc _handle_macro_at_range { attr_value } {
        if {[llength $attr_value] != 2} {
            error "usage: MACRO_AT_range { func file }"
        }

        set func [lindex $attr_value 0]
        set src [lindex $attr_value 1]
        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] != 2} {
            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 [lindex $attr end]
                } else {
                    # If the value looks like an integer, a form is required.
                    if [string is integer $attr_value] {
                        error "Integer value requires a form"
                    }
                    set attr_form [_guess_form $attr_value 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 Terminator
            _op .byte 0x0 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}:"
    }

    # Declare a global label.  This is typically used to refer to
    # labels defined in other files, for example a function defined in
    # a .c file.
    proc extern {args} {
        foreach name $args {
            _op .global $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]

            upvar $name label_var
            if {$text == ""} {
                set label_var [new_label]
            } else {
                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_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_GNU_implicit_pointer {
                    if {[llength $line] != 3} {
                        error "usage: DW_OP_GNU_implicit_pointer LABEL OFFSET"
                    }

                    # Here label is a section offset.
                    set label [lindex $line 1]
                    _op .${_cu_offset_size}byte $label
                    _op .sleb128 [lindex $line 2]
                }

                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, 32, 64, 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 _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 {
            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"
        }

        _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 Terminator
            _op .byte 0x0 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, 32, 64, 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 Terminator
            _op .byte 0x0 Terminator
        }

        define_label $end_label
    }

    # 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, 32, 64, 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

        # Establish the defaults.
        set is_64 0
        set _unit_version 4
        set _unit_addr_size default

        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 { 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 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 "$header_end_label - $header_len_label" "header_length"
        } else {
            _op .4byte "$header_end_label - $header_len_label" "header_length"
        }

        define_label $header_len_label

        _op .byte 1 "minimum_instruction_length"
        _op .byte 0 "default_is_stmt"
        _op .byte 1 "line_base"
        _op .byte 1 "line_range"
        _op .byte 1 "opcode_base"
        # Since we emit opcode_base==1, we skip
        # standard_opcode_length table altogether.

        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"
        }

        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.
        _op .byte 0 "Terminator."

        define_label $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

        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

        # 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

        catch {close $_output_file}
        set _output_file {}
    }
}