6ef37366be
Example of use:
Dwarf::assemble "foo.s" {
build_id 0102030405060708
declare_labels L;
cu {is_64 0 version 4 addr_size 8} {
DW_TAG_compile_unit {
{DW_AT_stmt_list $L DW_FORM_sec_offset}
} {
DW_TAG_subprogram {
# We can now reference the source file.
{DW_AT_decl_file 1 DW_FORM_data1}
}
}
}
lines {is_64 0 version 2 addr_size 8} L {
include_dir "foo"
include_dir "bar"
file_name "foo.c" 1
file_name "bar.c" 1
file_name "baz.c" 2
}
}
Signed-off-by: Petr Machata <pmachata@redhat.com>
1346 lines
34 KiB
Text
1346 lines
34 KiB
Text
# 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]
|
|
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 2]
|
|
} 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_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]
|
|
}
|
|
|
|
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 {}
|
|
}
|
|
}
|