gdb/testsuite/lib/dwarf.exp

   1 # Copyright 2010-2015 Free Software Foundation, Inc.
   2
   3 # This program is free software; you can redistribute it and/or modify
   4 # it under the terms of the GNU General Public License as published by
   5 # the Free Software Foundation; either version 3 of the License, or
   6 # (at your option) any later version.
   7 #
   8 # This program is distributed in the hope that it will be useful,
   9 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 # GNU General Public License for more details.
  12 #
  13 # You should have received a copy of the GNU General Public License
  14 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  15
  16 # Return true if the target supports DWARF-2 and uses gas.
  17 # For now pick a sampling of likely targets.
  18 proc dwarf2_support {} {
  19     if {[istarget *-*-linux*]
  20         || [istarget *-*-gnu*]
  21         || [istarget *-*-elf*]
  22         || [istarget *-*-openbsd*]
  23         || [istarget arm*-*-eabi*]
  24         || [istarget arm*-*-symbianelf*]
  25         || [istarget powerpc-*-eabi*]} {
  26         return 1
  27     }
  28
  29     return 0
  30 }
  31
  32 # Build an executable from a fission-based .S file.
  33 # This handles the extra work of splitting the .o into non-dwo and dwo
  34 # pieces, making sure the .dwo is available if we're using cc-with-tweaks.sh
  35 # to build a .dwp file.
  36 # The arguments and results are the same as for build_executable.
  37 #
  38 # Current restrictions:
  39 # - only supports one source file
  40 # - cannot be run on remote hosts
  41
  42 proc build_executable_from_fission_assembler { testname executable sources options } {
  43     verbose -log "build_executable_from_fission_assembler $testname $executable $sources $options"
  44     if { [llength $sources] != 1 } {
  45         error "Only one source file supported."
  46     }
  47     if [is_remote host] {
  48         error "Remote hosts are not supported."
  49     }
  50
  51     global srcdir subdir
  52     set source_file ${srcdir}/${subdir}/${sources}
  53     set root_name [file rootname [file tail $source_file]]
  54     set output_base [standard_output_file $root_name]
  55     set object_file ${output_base}.o
  56     set dwo_file ${output_base}.dwo
  57     set object_options "object $options"
  58     set objcopy [gdb_find_objcopy]
  59
  60     set result [gdb_compile $source_file $object_file object $options]
  61     if { "$result" != "" } {
  62         return -1
  63     }
  64
  65     set command "$objcopy --extract-dwo $object_file $dwo_file"
  66     verbose -log "Executing $command"
  67     set result [catch "exec $command" output]
  68     verbose -log "objcopy --extract-dwo output: $output"
  69     if { $result == 1 } {
  70         return -1
  71     }
  72
  73     set command "$objcopy --strip-dwo $object_file"
  74     verbose -log "Executing $command"
  75     set result [catch "exec $command" output]
  76     verbose -log "objcopy --strip-dwo output: $output"
  77     if { $result == 1 } {
  78         return -1
  79     }
  80
  81     set result [gdb_compile $object_file $executable executable {nodebug}]
  82     if { "$result" != "" } {
  83         return -1
  84     }
  85
  86     return 0
  87 }
  88
  89 # Return a list of expressions about function FUNC's address and length.
  90 # The first expression is the address of function FUNC, and the second
  91 # one is FUNC's length.  SRC is the source file having function FUNC.
  92 # An internal label ${func}_label must be defined inside FUNC:
  93 #
  94 #  int main (void)
  95 #  {
  96 #    asm ("main_label: .globl main_label");
  97 #    return 0;
  98 #  }
  99 #
 100 # This label is needed to compute the start address of function FUNC.
 101 # If the compiler is gcc, we can do the following to get function start
 102 # and end address too:
 103 #
 104 # asm ("func_start: .globl func_start");
 105 # static void func (void) {}
 106 # asm ("func_end: .globl func_end");
 107 #
 108 # however, this isn't portable, because other compilers, such as clang,
 109 # may not guarantee the order of global asms and function.  The code
 110 # becomes:
 111 #
 112 # asm ("func_start: .globl func_start");
 113 # asm ("func_end: .globl func_end");
 114 # static void func (void) {}
 115 #
 116
 117 proc function_range { func src } {
 118     global decimal gdb_prompt
 119
 120     set exe [standard_temp_file func_addr[pid].x]
 121
 122     gdb_compile $src $exe executable {debug}
 123
 124     gdb_exit
 125     gdb_start
 126     gdb_load "$exe"
 127
 128     # Compute the label offset, and we can get the function start address
 129     # by "${func}_label - $func_label_offset".
 130     set func_label_offset ""
 131     set test "p ${func}_label - ${func}"
 132     gdb_test_multiple $test $test {
 133         -re ".* = ($decimal)\r\n$gdb_prompt $" {
 134             set func_label_offset $expect_out(1,string)
 135         }
 136     }
 137
 138     # Compute the function length.
 139     global hex
 140     set func_length ""
 141     set test "disassemble $func"
 142     gdb_test_multiple $test $test {
 143         -re ".*$hex <\\+($decimal)>:\[^\r\n\]+\r\nEnd of assembler dump\.\r\n$gdb_prompt $" {
 144             set func_length $expect_out(1,string)
 145         }
 146     }
 147
 148     # Compute the size of the last instruction.
 149     set test "x/2i $func+$func_length"
 150     gdb_test_multiple $test $test {
 151         -re ".*($hex) <$func\\+$func_length>:\[^\r\n\]+\r\n\[ \]+($hex).*\.\r\n$gdb_prompt $" {
 152             set start $expect_out(1,string)
 153             set end $expect_out(2,string)
 154
 155             set func_length [expr $func_length + $end - $start]
 156         }
 157     }
 158
 159     return [list "${func}_label - $func_label_offset" $func_length]
 160 }
 161
 162 # A DWARF assembler.
 163 #
 164 # All the variables in this namespace are private to the
 165 # implementation.  Also, any procedure whose name starts with "_" is
 166 # private as well.  Do not use these.
 167 #
 168 # Exported functions are documented at their definition.
 169 #
 170 # In addition to the hand-written functions documented below, this
 171 # module automatically generates a function for each DWARF tag.  For
 172 # most tags, two forms are made: a full name, and one with the
 173 # "DW_TAG_" prefix stripped.  For example, you can use either
 174 # 'DW_TAG_compile_unit' or 'compile_unit' interchangeably.
 175 #
 176 # There are two exceptions to this rule: DW_TAG_variable and
 177 # DW_TAG_namespace.  For these, the full name must always be used,
 178 # as the short name conflicts with Tcl builtins.  (Should future
 179 # versions of Tcl or DWARF add more conflicts, this list will grow.
 180 # If you want to be safe you should always use the full names.)
 181 #
 182 # Each tag procedure is defined like:
 183 #
 184 # proc DW_TAG_mumble {{attrs {}} {children {}}} { ... }
 185 #
 186 # ATTRS is an optional list of attributes.
 187 # It is run through 'subst' in the caller's context before processing.
 188 #
 189 # Each attribute in the list has one of two forms:
 190 #   1. { NAME VALUE }
 191 #   2. { NAME VALUE FORM }
 192 #
 193 # In each case, NAME is the attribute's name.
 194 # This can either be the full name, like 'DW_AT_name', or a shortened
 195 # name, like 'name'.  These are fully equivalent.
 196 #
 197 # Besides DWARF standard attributes, assembler supports 'macro' attribute
 198 # which will be substituted by one or more standard or macro attributes.
 199 # supported macro attributes are:
 200 #
 201 #  - MACRO_AT_range { FUNC FILE }
 202 #  It is substituted by DW_AT_low_pc and DW_AT_high_pc with the start and
 203 #  end address of function FUNC in file FILE.
 204 #
 205 #  - MACRO_AT_func { FUNC FILE }
 206 #  It is substituted by DW_AT_name with FUNC and MACRO_AT_range.
 207 #
 208 # If FORM is given, it should name a DW_FORM_ constant.
 209 # This can either be the short form, like 'DW_FORM_addr', or a
 210 # shortened version, like 'addr'.  If the form is given, VALUE
 211 # is its value; see below.  In some cases, additional processing
 212 # is done; for example, DW_FORM_strp manages the .debug_str
 213 # section automatically.
 214 #
 215 # If FORM is 'SPECIAL_expr', then VALUE is treated as a location
 216 # expression.  The effective form is then DW_FORM_block, and VALUE
 217 # is passed to the (internal) '_location' proc to be translated.
 218 # This proc implements a miniature DW_OP_ assembler.
 219 #
 220 # If FORM is not given, it is guessed:
 221 # * If VALUE starts with the "@" character, the rest of VALUE is
 222 #   looked up as a DWARF constant, and DW_FORM_sdata is used.  For
 223 #   example, '@DW_LANG_c89' could be used.
 224 # * If VALUE starts with the ":" character, then it is a label
 225 #   reference.  The rest of VALUE is taken to be the name of a label,
 226 #   and DW_FORM_ref4 is used.  See 'new_label' and 'define_label'.
 227 # * Otherwise, VALUE is taken to be a string and DW_FORM_string is
 228 #   used.  In order to prevent bugs where a numeric value is given but
 229 #   no form is specified, it is an error if the value looks like a number
 230 #   (using Tcl's "string is integer") and no form is provided.
 231 # More form-guessing functionality may be added.
 232 #
 233 # CHILDREN is just Tcl code that can be used to define child DIEs.  It
 234 # is evaluated in the caller's context.
 235 #
 236 # Currently this code is missing nice support for CFA handling, and
 237 # probably other things as well.
 238
 239 namespace eval Dwarf {
 240     # True if the module has been initialized.
 241     variable _initialized 0
 242
 243     # Constants from dwarf2.h.
 244     variable _constants
 245     # DW_AT short names.
 246     variable _AT
 247     # DW_FORM short names.
 248     variable _FORM
 249     # DW_OP short names.
 250     variable _OP
 251
 252     # The current output file.
 253     variable _output_file
 254
 255     # Note: The _cu_ values here also apply to type units (TUs).
 256     # Think of a TU as a special kind of CU.
 257
 258     # Current CU count.
 259     variable _cu_count
 260
 261     # The current CU's base label.
 262     variable _cu_label
 263
 264     # The current CU's version.
 265     variable _cu_version
 266
 267     # The current CU's address size.
 268     variable _cu_addr_size
 269     # The current CU's offset size.
 270     variable _cu_offset_size
 271
 272     # Label generation number.
 273     variable _label_num
 274
 275     # The deferred output array.  The index is the section name; the
 276     # contents hold the data for that section.
 277     variable _deferred_output
 278
 279     # If empty, we should write directly to the output file.
 280     # Otherwise, this is the name of a section to write to.
 281     variable _defer
 282
 283     # The abbrev section.  Typically .debug_abbrev but can be .debug_abbrev.dwo
 284     # for Fission.
 285     variable _abbrev_section
 286
 287     # The next available abbrev number in the current CU's abbrev
 288     # table.
 289     variable _abbrev_num
 290
 291     # The string table for this assembly.  The key is the string; the
 292     # value is the label for that string.
 293     variable _strings
 294
 295     proc _process_one_constant {name value} {
 296         variable _constants
 297         variable _AT
 298         variable _FORM
 299         variable _OP
 300
 301         set _constants($name) $value
 302
 303         if {![regexp "^DW_(\[A-Z\]+)_(\[A-Za-z0-9_\]+)$" $name \
 304                   ignore prefix name2]} {
 305             error "non-matching name: $name"
 306         }
 307
 308         if {$name2 == "lo_user" || $name2 == "hi_user"} {
 309             return
 310         }
 311
 312         # We only try to shorten some very common things.
 313         # FIXME: CFA?
 314         switch -exact -- $prefix {
 315             TAG {
 316                 # Create two procedures for the tag.  These call
 317                 # _handle_DW_TAG with the full tag name baked in; this
 318                 # does all the actual work.
 319                 proc $name {{attrs {}} {children {}}} \
 320                     "_handle_DW_TAG $name \$attrs \$children"
 321
 322                 # Filter out ones that are known to clash.
 323                 if {$name2 == "variable" || $name2 == "namespace"} {
 324                     set name2 "tag_$name2"
 325                 }
 326
 327                 if {[info commands $name2] != {}} {
 328                     error "duplicate proc name: from $name"
 329                 }
 330
 331                 proc $name2 {{attrs {}} {children {}}} \
 332                     "_handle_DW_TAG $name \$attrs \$children"
 333             }
 334
 335             AT {
 336                 set _AT($name2) $name
 337             }
 338
 339             FORM {
 340                 set _FORM($name2) $name
 341             }
 342
 343             OP {
 344                 set _OP($name2) $name
 345             }
 346
 347             default {
 348                 return
 349             }
 350         }
 351     }
 352
 353     proc _read_constants {} {
 354         global srcdir hex decimal
 355         variable _constants
 356
 357         # DWARF name-matching regexp.
 358         set dwrx "DW_\[a-zA-Z0-9_\]+"
 359         # Whitespace regexp.
 360         set ws "\[ \t\]+"
 361
 362         set fd [open [file join $srcdir .. .. include dwarf2.h]]
 363         while {![eof $fd]} {
 364             set line [gets $fd]
 365             if {[regexp -- "^${ws}($dwrx)${ws}=${ws}($hex|$decimal),?$" \
 366                      $line ignore name value ignore2]} {
 367                 _process_one_constant $name $value
 368             }
 369         }
 370         close $fd
 371
 372         set fd [open [file join $srcdir .. .. include dwarf2.def]]
 373         while {![eof $fd]} {
 374             set line [gets $fd]
 375             if {[regexp -- \
 376                      "^DW_\[A-Z_\]+${ws}\\(($dwrx),${ws}($hex|$decimal)\\)$" \
 377                      $line ignore name value ignore2]} {
 378                 _process_one_constant $name $value
 379             }
 380         }
 381         close $fd
 382
 383         set _constants(SPECIAL_expr) $_constants(DW_FORM_block)
 384     }
 385
 386     proc _quote {string} {
 387         # FIXME
 388         return "\"${string}\\0\""
 389     }
 390
 391     proc _nz_quote {string} {
 392         # For now, no quoting is done.
 393         return "\"${string}\""
 394     }
 395
 396     proc _handle_DW_FORM {form value} {
 397         switch -exact -- $form {
 398             DW_FORM_string  {
 399                 _op .ascii [_quote $value]
 400             }
 401
 402             DW_FORM_flag_present {
 403                 # We don't need to emit anything.
 404             }
 405
 406             DW_FORM_data4 -
 407             DW_FORM_ref4 {
 408                 _op .4byte $value
 409             }
 410
 411             DW_FORM_ref_addr {
 412                 variable _cu_offset_size
 413                 variable _cu_version
 414                 variable _cu_addr_size
 415
 416                 if {$_cu_version == 2} {
 417                     set size $_cu_addr_size
 418                 } else {
 419                     set size $_cu_offset_size
 420                 }
 421
 422                 _op .${size}byte $value
 423             }
 424
 425             DW_FORM_ref1 -
 426             DW_FORM_flag -
 427             DW_FORM_data1 {
 428                 _op .byte $value
 429             }
 430
 431             DW_FORM_sdata {
 432                 _op .sleb128 $value
 433             }
 434
 435             DW_FORM_ref_udata -
 436             DW_FORM_udata {
 437                 _op .uleb128 $value
 438             }
 439
 440             DW_FORM_addr {
 441                 variable _cu_addr_size
 442
 443                 _op .${_cu_addr_size}byte $value
 444             }
 445
 446             DW_FORM_data2 -
 447             DW_FORM_ref2 {
 448                 _op .2byte $value
 449             }
 450
 451             DW_FORM_data8 -
 452             DW_FORM_ref8 -
 453             DW_FORM_ref_sig8 {
 454                 _op .8byte $value
 455             }
 456
 457             DW_FORM_strp {
 458                 variable _strings
 459                 variable _cu_offset_size
 460
 461                 if {![info exists _strings($value)]} {
 462                     set _strings($value) [new_label strp]
 463                     _defer_output .debug_string {
 464                         define_label $_strings($value)
 465                         _op .ascii [_quote $value]
 466                     }
 467                 }
 468
 469                 _op .${_cu_offset_size}byte $_strings($value) "strp: $value"
 470             }
 471
 472             SPECIAL_expr {
 473                 set l1 [new_label "expr_start"]
 474                 set l2 [new_label "expr_end"]
 475                 _op .uleb128 "$l2 - $l1" "expression"
 476                 define_label $l1
 477                 _location $value
 478                 define_label $l2
 479             }
 480
 481             DW_FORM_block1 {
 482                 set len [string length $value]
 483                 if {$len > 255} {
 484                     error "DW_FORM_block1 length too long"
 485                 }
 486                 _op .byte $len
 487                 _op .ascii [_nz_quote $value]
 488             }
 489
 490             DW_FORM_block2 -
 491             DW_FORM_block4 -
 492
 493             DW_FORM_block -
 494
 495             DW_FORM_ref2 -
 496             DW_FORM_indirect -
 497             DW_FORM_sec_offset -
 498             DW_FORM_exprloc -
 499
 500             DW_FORM_GNU_addr_index -
 501             DW_FORM_GNU_str_index -
 502             DW_FORM_GNU_ref_alt -
 503             DW_FORM_GNU_strp_alt -
 504
 505             default {
 506                 error "unhandled form $form"
 507             }
 508         }
 509     }
 510
 511     proc _guess_form {value varname} {
 512         upvar $varname new_value
 513
 514         switch -exact -- [string range $value 0 0] {
 515             @ {
 516                 # Constant reference.
 517                 variable _constants
 518
 519                 set new_value $_constants([string range $value 1 end])
 520                 # Just the simplest.
 521                 return DW_FORM_sdata
 522             }
 523
 524             : {
 525                 # Label reference.
 526                 variable _cu_label
 527
 528                 set new_value "[string range $value 1 end] - $_cu_label"
 529
 530                 return DW_FORM_ref4
 531             }
 532
 533             default {
 534                 return DW_FORM_string
 535             }
 536         }
 537     }
 538
 539     # Map NAME to its canonical form.
 540     proc _map_name {name ary} {
 541         variable $ary
 542
 543         if {[info exists ${ary}($name)]} {
 544             set name [set ${ary}($name)]
 545         }
 546
 547         return $name
 548     }
 549
 550     proc _handle_attribute { attr_name attr_value attr_form } {
 551         variable _abbrev_section
 552         variable _constants
 553
 554         _handle_DW_FORM $attr_form $attr_value
 555
 556         _defer_output $_abbrev_section {
 557             _op .uleb128 $_constants($attr_name) $attr_name
 558             _op .uleb128 $_constants($attr_form) $attr_form
 559         }
 560     }
 561
 562     # Handle macro attribute MACRO_AT_range.
 563
 564     proc _handle_macro_at_range { attr_value } {
 565         if {[llength $attr_value] != 2} {
 566             error "usage: MACRO_AT_range { func file }"
 567         }
 568
 569         set func [lindex $attr_value 0]
 570         set src [lindex $attr_value 1]
 571         set result [function_range $func $src]
 572
 573         _handle_attribute DW_AT_low_pc [lindex $result 0] \
 574             DW_FORM_addr
 575         _handle_attribute DW_AT_high_pc \
 576             "[lindex $result 0] + [lindex $result 1]" DW_FORM_addr
 577     }
 578
 579     # Handle macro attribute MACRO_AT_func.
 580
 581     proc _handle_macro_at_func { attr_value } {
 582         if {[llength $attr_value] != 2} {
 583             error "usage: MACRO_AT_func { func file }"
 584         }
 585         _handle_attribute DW_AT_name [lindex $attr_value 0] DW_FORM_string
 586         _handle_macro_at_range $attr_value
 587     }
 588
 589     proc _handle_DW_TAG {tag_name {attrs {}} {children {}}} {
 590         variable _abbrev_section
 591         variable _abbrev_num
 592         variable _constants
 593
 594         set has_children [expr {[string length $children] > 0}]
 595         set my_abbrev [incr _abbrev_num]
 596
 597         # We somewhat wastefully emit a new abbrev entry for each tag.
 598         # There's no reason for this other than laziness.
 599         _defer_output $_abbrev_section {
 600             _op .uleb128 $my_abbrev "Abbrev start"
 601             _op .uleb128 $_constants($tag_name) $tag_name
 602             _op .byte $has_children "has_children"
 603         }
 604
 605         _op .uleb128 $my_abbrev "Abbrev ($tag_name)"
 606
 607         foreach attr $attrs {
 608             set attr_name [_map_name [lindex $attr 0] _AT]
 609             set attr_value [uplevel 2 [list subst [lindex $attr 1]]]
 610
 611             if { [string equal "MACRO_AT_func" $attr_name] } {
 612                 _handle_macro_at_func $attr_value
 613             } elseif { [string equal "MACRO_AT_range" $attr_name] } {
 614                 _handle_macro_at_range $attr_value
 615             } else {
 616                 if {[llength $attr] > 2} {
 617                     set attr_form [lindex $attr 2]
 618                 } else {
 619                     # If the value looks like an integer, a form is required.
 620                     if [string is integer $attr_value] {
 621                         error "Integer value requires a form"
 622                     }
 623                     set attr_form [_guess_form $attr_value attr_value]
 624                 }
 625                 set attr_form [_map_name $attr_form _FORM]
 626
 627                 _handle_attribute $attr_name $attr_value $attr_form
 628             }
 629         }
 630
 631         _defer_output $_abbrev_section {
 632             # Terminator.
 633             _op .byte 0x0 Terminator
 634             _op .byte 0x0 Terminator
 635         }
 636
 637         if {$has_children} {
 638             uplevel 2 $children
 639
 640             # Terminate children.
 641             _op .byte 0x0 "Terminate children"
 642         }
 643     }
 644
 645     proc _emit {string} {
 646         variable _output_file
 647         variable _defer
 648         variable _deferred_output
 649
 650         if {$_defer == ""} {
 651             puts $_output_file $string
 652         } else {
 653             append _deferred_output($_defer) ${string}\n
 654         }
 655     }
 656
 657     proc _section {name {flags ""} {type ""}} {
 658         if {$flags == "" && $type == ""} {
 659             _emit "        .section $name"
 660         } elseif {$type == ""} {
 661             _emit "        .section $name, \"$flags\""
 662         } else {
 663             _emit "        .section $name, \"$flags\", %$type"
 664         }
 665     }
 666
 667     # SECTION_SPEC is a list of arguments to _section.
 668     proc _defer_output {section_spec body} {
 669         variable _defer
 670         variable _deferred_output
 671
 672         set old_defer $_defer
 673         set _defer [lindex $section_spec 0]
 674
 675         if {![info exists _deferred_output($_defer)]} {
 676             set _deferred_output($_defer) ""
 677             eval _section $section_spec
 678         }
 679
 680         uplevel $body
 681
 682         set _defer $old_defer
 683     }
 684
 685     proc _defer_to_string {body} {
 686         variable _defer
 687         variable _deferred_output
 688
 689         set old_defer $_defer
 690         set _defer temp
 691
 692         set _deferred_output($_defer) ""
 693
 694         uplevel $body
 695
 696         set result $_deferred_output($_defer)
 697         unset _deferred_output($_defer)
 698
 699         set _defer $old_defer
 700         return $result
 701     }
 702
 703     proc _write_deferred_output {} {
 704         variable _output_file
 705         variable _deferred_output
 706
 707         foreach section [array names _deferred_output] {
 708             # The data already has a newline.
 709             puts -nonewline $_output_file $_deferred_output($section)
 710         }
 711
 712         # Save some memory.
 713         unset _deferred_output
 714     }
 715
 716     proc _op {name value {comment ""}} {
 717         set text "        ${name}        ${value}"
 718         if {$comment != ""} {
 719             # Try to make stuff line up nicely.
 720             while {[string length $text] < 40} {
 721                 append text " "
 722             }
 723             append text "/* ${comment} */"
 724         }
 725         _emit $text
 726     }
 727
 728     proc _compute_label {name} {
 729         return ".L${name}"
 730     }
 731
 732     # Return a name suitable for use as a label.  If BASE_NAME is
 733     # specified, it is incorporated into the label name; this is to
 734     # make debugging the generated assembler easier.  If BASE_NAME is
 735     # not specified a generic default is used.  This proc does not
 736     # define the label; see 'define_label'.  'new_label' attempts to
 737     # ensure that label names are unique.
 738     proc new_label {{base_name label}} {
 739         variable _label_num
 740
 741         return [_compute_label ${base_name}[incr _label_num]]
 742     }
 743
 744     # Define a label named NAME.  Ordinarily, NAME comes from a call
 745     # to 'new_label', but this is not required.
 746     proc define_label {name} {
 747         _emit "${name}:"
 748     }
 749
 750     # Declare a global label.  This is typically used to refer to
 751     # labels defined in other files, for example a function defined in
 752     # a .c file.
 753     proc extern {args} {
 754         foreach name $args {
 755             _op .global $name
 756         }
 757     }
 758
 759     # A higher-level interface to label handling.
 760     #
 761     # ARGS is a list of label descriptors.  Each one is either a
 762     # single element, or a list of two elements -- a name and some
 763     # text.  For each descriptor, 'new_label' is invoked.  If the list
 764     # form is used, the second element in the list is passed as an
 765     # argument.  The label name is used to define a variable in the
 766     # enclosing scope; this can be used to refer to the label later.
 767     # The label name is also used to define a new proc whose name is
 768     # the label name plus a trailing ":".  This proc takes a body as
 769     # an argument and can be used to define the label at that point;
 770     # then the body, if any, is evaluated in the caller's context.
 771     #
 772     # For example:
 773     #
 774     # declare_labels int_label
 775     # something { ... $int_label }   ;# refer to the label
 776     # int_label: constant { ... }    ;# define the label
 777     proc declare_labels {args} {
 778         foreach arg $args {
 779             set name [lindex $arg 0]
 780             set text [lindex $arg 1]
 781
 782             upvar $name label_var
 783             if {$text == ""} {
 784                 set label_var [new_label]
 785             } else {
 786                 set label_var [new_label $text]
 787             }
 788
 789             proc ${name}: {args} [format {
 790                 define_label %s
 791                 uplevel $args
 792             } $label_var]
 793         }
 794     }
 795
 796     # This is a miniature assembler for location expressions.  It is
 797     # suitable for use in the attributes to a DIE.  Its output is
 798     # prefixed with "=" to make it automatically use DW_FORM_block.
 799     # BODY is split by lines, and each line is taken to be a list.
 800     # (FIXME should use 'info complete' here.)
 801     # Each list's first element is the opcode, either short or long
 802     # forms are accepted.
 803     # FIXME argument handling
 804     # FIXME move docs
 805     proc _location {body} {
 806         variable _constants
 807         variable _cu_label
 808         variable _cu_addr_size
 809         variable _cu_offset_size
 810
 811         foreach line [split $body \n] {
 812             # Ignore blank lines, and allow embedded comments.
 813             if {[lindex $line 0] == "" || [regexp -- {^[ \t]*#} $line]} {
 814                 continue
 815             }
 816             set opcode [_map_name [lindex $line 0] _OP]
 817             _op .byte $_constants($opcode) $opcode
 818
 819             switch -exact -- $opcode {
 820                 DW_OP_addr {
 821                     _op .${_cu_addr_size}byte [lindex $line 1]
 822                 }
 823
 824                 DW_OP_pick -
 825                 DW_OP_const1u -
 826                 DW_OP_const1s {
 827                     _op .byte [lindex $line 1]
 828                 }
 829
 830                 DW_OP_const2u -
 831                 DW_OP_const2s {
 832                     _op .2byte [lindex $line 1]
 833                 }
 834
 835                 DW_OP_const4u -
 836                 DW_OP_const4s {
 837                     _op .4byte [lindex $line 1]
 838                 }
 839
 840                 DW_OP_const8u -
 841                 DW_OP_const8s {
 842                     _op .8byte [lindex $line 1]
 843                 }
 844
 845                 DW_OP_constu {
 846                     _op .uleb128 [lindex $line 1]
 847                 }
 848                 DW_OP_consts {
 849                     _op .sleb128 [lindex $line 1]
 850                 }
 851
 852                 DW_OP_plus_uconst {
 853                     _op .uleb128 [lindex $line 1]
 854                 }
 855
 856                 DW_OP_piece {
 857                     _op .uleb128 [lindex $line 1]
 858                 }
 859
 860                 DW_OP_bit_piece {
 861                     _op .uleb128 [lindex $line 1]
 862                     _op .uleb128 [lindex $line 2]
 863                 }
 864
 865                 DW_OP_skip -
 866                 DW_OP_bra {
 867                     _op .2byte [lindex $line 1]
 868                 }
 869
 870                 DW_OP_GNU_implicit_pointer {
 871                     if {[llength $line] != 3} {
 872                         error "usage: DW_OP_GNU_implicit_pointer LABEL OFFSET"
 873                     }
 874
 875                     # Here label is a section offset.
 876                     set label [lindex $line 1]
 877                     _op .${_cu_offset_size}byte $label
 878                     _op .sleb128 [lindex $line 2]
 879                 }
 880
 881                 DW_OP_deref_size {
 882                     if {[llength $line] != 2} {
 883                         error "usage: DW_OP_deref_size SIZE"
 884                     }
 885
 886                     _op .byte [lindex $line 1]
 887                 }
 888
 889                 default {
 890                     if {[llength $line] > 1} {
 891                         error "Unimplemented: operands in location for $opcode"
 892                     }
 893                 }
 894             }
 895         }
 896     }
 897
 898     # Emit a DWARF CU.
 899     # OPTIONS is a list with an even number of elements containing
 900     # option-name and option-value pairs.
 901     # Current options are:
 902     # is_64 0|1    - boolean indicating if you want to emit 64-bit DWARF
 903     #                default = 0 (32-bit)
 904     # version n    - DWARF version number to emit
 905     #                default = 4
 906     # addr_size n  - the size of addresses, 32, 64, or default
 907     #                default = default
 908     # fission 0|1  - boolean indicating if generating Fission debug info
 909     #                default = 0
 910     # BODY is Tcl code that emits the DIEs which make up the body of
 911     # the CU.  It is evaluated in the caller's context.
 912     proc cu {options body} {
 913         variable _cu_count
 914         variable _abbrev_section
 915         variable _abbrev_num
 916         variable _cu_label
 917         variable _cu_version
 918         variable _cu_addr_size
 919         variable _cu_offset_size
 920
 921         # Establish the defaults.
 922         set is_64 0
 923         set _cu_version 4
 924         set _cu_addr_size default
 925         set fission 0
 926         set section ".debug_info"
 927         set _abbrev_section ".debug_abbrev"
 928
 929         foreach { name value } $options {
 930             switch -exact -- $name {
 931                 is_64 { set is_64 $value }
 932                 version { set _cu_version $value }
 933                 addr_size { set _cu_addr_size $value }
 934                 fission { set fission $value }
 935                 default { error "unknown option $name" }
 936             }
 937         }
 938         if {$_cu_addr_size == "default"} {
 939             if {[is_64_target]} {
 940                 set _cu_addr_size 8
 941             } else {
 942                 set _cu_addr_size 4
 943             }
 944         }
 945         set _cu_offset_size [expr { $is_64 ? 8 : 4 }]
 946         if { $fission } {
 947             set section ".debug_info.dwo"
 948             set _abbrev_section ".debug_abbrev.dwo"
 949         }
 950
 951         _section $section
 952
 953         set cu_num [incr _cu_count]
 954         set my_abbrevs [_compute_label "abbrev${cu_num}_begin"]
 955         set _abbrev_num 1
 956
 957         set _cu_label [_compute_label "cu${cu_num}_begin"]
 958         set start_label [_compute_label "cu${cu_num}_start"]
 959         set end_label [_compute_label "cu${cu_num}_end"]
 960
 961         define_label $_cu_label
 962         if {$is_64} {
 963             _op .4byte 0xffffffff
 964             _op .8byte "$end_label - $start_label"
 965         } else {
 966             _op .4byte "$end_label - $start_label"
 967         }
 968         define_label $start_label
 969         _op .2byte $_cu_version Version
 970         _op .${_cu_offset_size}byte $my_abbrevs Abbrevs
 971         _op .byte $_cu_addr_size "Pointer size"
 972
 973         _defer_output $_abbrev_section {
 974             define_label $my_abbrevs
 975         }
 976
 977         uplevel $body
 978
 979         _defer_output $_abbrev_section {
 980             # Emit the terminator.
 981             _op .byte 0x0 Terminator
 982             _op .byte 0x0 Terminator
 983         }
 984
 985         define_label $end_label
 986     }
 987
 988     # Emit a DWARF TU.
 989     # OPTIONS is a list with an even number of elements containing
 990     # option-name and option-value pairs.
 991     # Current options are:
 992     # is_64 0|1    - boolean indicating if you want to emit 64-bit DWARF
 993     #                default = 0 (32-bit)
 994     # version n    - DWARF version number to emit
 995     #                default = 4
 996     # addr_size n  - the size of addresses, 32, 64, or default
 997     #                default = default
 998     # fission 0|1  - boolean indicating if generating Fission debug info
 999     #                default = 0
1000     # SIGNATURE is the 64-bit signature of the type.
1001     # TYPE_LABEL is the label of the type defined by this TU,
1002     # or "" if there is no type (i.e., type stubs in Fission).
1003     # BODY is Tcl code that emits the DIEs which make up the body of
1004     # the TU.  It is evaluated in the caller's context.
1005     proc tu {options signature type_label body} {
1006         variable _cu_count
1007         variable _abbrev_section
1008         variable _abbrev_num
1009         variable _cu_label
1010         variable _cu_version
1011         variable _cu_addr_size
1012         variable _cu_offset_size
1013
1014         # Establish the defaults.
1015         set is_64 0
1016         set _cu_version 4
1017         set _cu_addr_size default
1018         set fission 0
1019         set section ".debug_types"
1020         set _abbrev_section ".debug_abbrev"
1021
1022         foreach { name value } $options {
1023             switch -exact -- $name {
1024                 is_64 { set is_64 $value }
1025                 version { set _cu_version $value }
1026                 addr_size { set _cu_addr_size $value }
1027                 fission { set fission $value }
1028                 default { error "unknown option $name" }
1029             }
1030         }
1031         if {$_cu_addr_size == "default"} {
1032             if {[is_64_target]} {
1033                 set _cu_addr_size 8
1034             } else {
1035                 set _cu_addr_size 4
1036             }
1037         }
1038         set _cu_offset_size [expr { $is_64 ? 8 : 4 }]
1039         if { $fission } {
1040             set section ".debug_types.dwo"
1041             set _abbrev_section ".debug_abbrev.dwo"
1042         }
1043
1044         _section $section
1045
1046         set cu_num [incr _cu_count]
1047         set my_abbrevs [_compute_label "abbrev${cu_num}_begin"]
1048         set _abbrev_num 1
1049
1050         set _cu_label [_compute_label "cu${cu_num}_begin"]
1051         set start_label [_compute_label "cu${cu_num}_start"]
1052         set end_label [_compute_label "cu${cu_num}_end"]
1053
1054         define_label $_cu_label
1055         if {$is_64} {
1056             _op .4byte 0xffffffff
1057             _op .8byte "$end_label - $start_label"
1058         } else {
1059             _op .4byte "$end_label - $start_label"
1060         }
1061         define_label $start_label
1062         _op .2byte $_cu_version Version
1063         _op .${_cu_offset_size}byte $my_abbrevs Abbrevs
1064         _op .byte $_cu_addr_size "Pointer size"
1065         _op .8byte $signature Signature
1066         if { $type_label != "" } {
1067             uplevel declare_labels $type_label
1068             upvar $type_label my_type_label
1069             if {$is_64} {
1070                 _op .8byte "$my_type_label - $_cu_label"
1071             } else {
1072                 _op .4byte "$my_type_label - $_cu_label"
1073             }
1074         } else {
1075             if {$is_64} {
1076                 _op .8byte 0
1077             } else {
1078                 _op .4byte 0
1079             }
1080         }
1081
1082         _defer_output $_abbrev_section {
1083             define_label $my_abbrevs
1084         }
1085
1086         uplevel $body
1087
1088         _defer_output $_abbrev_section {
1089             # Emit the terminator.
1090             _op .byte 0x0 Terminator
1091             _op .byte 0x0 Terminator
1092         }
1093
1094         define_label $end_label
1095     }
1096
1097     proc _empty_array {name} {
1098         upvar $name the_array
1099
1100         catch {unset the_array}
1101         set the_array(_) {}
1102         unset the_array(_)
1103     }
1104
1105     # Emit a .gnu_debugaltlink section with the given file name and
1106     # build-id.  The buildid should be represented as a hexadecimal
1107     # string, like "ffeeddcc".
1108     proc gnu_debugaltlink {filename buildid} {
1109         _defer_output .gnu_debugaltlink {
1110             _op .ascii [_quote $filename]
1111             foreach {a b} [split $buildid {}] {
1112                 _op .byte 0x$a$b
1113             }
1114         }
1115     }
1116
1117     proc _note {type name hexdata} {
1118         set namelen [expr [string length $name] + 1]
1119
1120         # Name size.
1121         _op .4byte $namelen
1122         # Data size.
1123         _op .4byte [expr [string length $hexdata] / 2]
1124         # Type.
1125         _op .4byte $type
1126         # The name.
1127         _op .ascii [_quote $name]
1128         # Alignment.
1129         set align 2
1130         set total [expr {($namelen + (1 << $align) - 1) & (-1 << $align)}]
1131         for {set i $namelen} {$i < $total} {incr i} {
1132             _op .byte 0
1133         }
1134         # The data.
1135         foreach {a b} [split $hexdata {}] {
1136             _op .byte 0x$a$b
1137         }
1138     }
1139
1140     # Emit a note section holding the given build-id.
1141     proc build_id {buildid} {
1142         _defer_output {.note.gnu.build-id a note} {
1143             # From elf/common.h.
1144             set NT_GNU_BUILD_ID 3
1145
1146             _note $NT_GNU_BUILD_ID GNU $buildid
1147         }
1148     }
1149
1150     # The top-level interface to the DWARF assembler.
1151     # FILENAME is the name of the file where the generated assembly
1152     # code is written.
1153     # BODY is Tcl code to emit the assembly.  It is evaluated via
1154     # "eval" -- not uplevel as you might expect, because it is
1155     # important to run the body in the Dwarf namespace.
1156     #
1157     # A typical invocation is something like:
1158     #    Dwarf::assemble $file {
1159     #        cu 0 2 8 {
1160     #            compile_unit {
1161     #            ...
1162     #            }
1163     #        }
1164     #        cu 0 2 8 {
1165     #        ...
1166     #        }
1167     #    }
1168     proc assemble {filename body} {
1169         variable _initialized
1170         variable _output_file
1171         variable _deferred_output
1172         variable _defer
1173         variable _label_num
1174         variable _strings
1175         variable _cu_count
1176
1177         if {!$_initialized} {
1178             _read_constants
1179             set _initialized 1
1180         }
1181
1182         set _output_file [open $filename w]
1183         set _cu_count 0
1184         _empty_array _deferred_output
1185         set _defer ""
1186         set _label_num 0
1187         _empty_array _strings
1188
1189         # Not "uplevel" here, because we want to evaluate in this
1190         # namespace.  This is somewhat bad because it means we can't
1191         # readily refer to outer variables.
1192         eval $body
1193
1194         _write_deferred_output
1195
1196         catch {close $_output_file}
1197         set _output_file {}
1198     }
1199 }