gdb/testsuite/lib/dwarf.exp

   1 # Copyright 2010-2021 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 powerpc-*-eabi*]} {
  25         return 1
  26     }
  27
  28     return 0
  29 }
  30
  31 # Use 'objcopy --extract-dwo to extract DWO information from
  32 # OBJECT_FILE and place it into DWO_FILE.
  33 #
  34 # Return 0 on success, otherwise, return -1.
  35 proc extract_dwo_information { object_file dwo_file } {
  36     set objcopy [gdb_find_objcopy]
  37     set command "$objcopy --extract-dwo $object_file $dwo_file"
  38     verbose -log "Executing $command"
  39     set result [catch "exec $command" output]
  40     verbose -log "objcopy --extract-dwo output: $output"
  41     if { $result == 1 } {
  42         return -1
  43     }
  44     return 0
  45 }
  46
  47 # Use 'objcopy --strip-dwo to remove DWO information from
  48 # FILENAME.
  49 #
  50 # Return 0 on success, otherwise, return -1.
  51 proc strip_dwo_information { filename } {
  52     set objcopy [gdb_find_objcopy]
  53     set command "$objcopy --strip-dwo $filename"
  54     verbose -log "Executing $command"
  55     set result [catch "exec $command" output]
  56     verbose -log "objcopy --strip-dwo output: $output"
  57     if { $result == 1 } {
  58         return -1
  59     }
  60     return 0
  61 }
  62
  63 # Build an executable, with the debug information split out into a
  64 # separate .dwo file.
  65 #
  66 # This function is based on build_executable_from_specs in
  67 # lib/gdb.exp, but with threading support, and rust support removed.
  68 #
  69 # TESTNAME is the name of the test; this is passed to 'untested' if
  70 # something fails.
  71 #
  72 # EXECUTABLE is the executable to create, this can be an absolute
  73 # path, or a relative path, in which case the EXECUTABLE will be
  74 # created in the standard output directory.
  75 #
  76 # OPTIONS is passed to the final link, using gdb_compile.  If OPTIONS
  77 # contains any option that indicates threads is required, of if the
  78 # option rust is included, then this function will return failure.
  79 #
  80 # ARGS is a series of lists.  Each list is a spec for one source file
  81 # that will be compiled to make EXECUTABLE.  Each spec in ARGS has the
  82 # form:
  83 #       [ SOURCE OPTIONS ]
  84 # or:
  85 #       [ SOURCE OPTIONS OBJFILE ]
  86 #
  87 # Where SOURCE is the path to the source file to compile.  This can be
  88 # absolute, or relative to the standard global ${subdir}/${srcdir}/
  89 # path.
  90 #
  91 # OPTIONS are the options to use when compiling SOURCE into an object
  92 # file.
  93 #
  94 # OBJFILE is optional, if present this is the name of the object file
  95 # to create for SOURCE.  If this is not provided then a suitable name
  96 # will be auto-generated.
  97 #
  98 # If OPTIONS contains the option 'split-dwo' then the debug
  99 # information is extracted from the object file created by compiling
 100 # SOURCE and placed into a file with a dwo extension.  The name of
 101 # this file is generated based on the name of the object file that was
 102 # created (with the .o replaced with .dwo).
 103 proc build_executable_and_dwo_files { testname executable options args } {
 104     global subdir
 105     global srcdir
 106
 107     if { ! [regexp "^/" "$executable"] } then {
 108         set binfile [standard_output_file $executable]
 109     } else {
 110         set binfile $executable
 111     }
 112
 113     set info_options ""
 114     if { [lsearch -exact $options "c++"] >= 0 } {
 115         set info_options "c++"
 116     }
 117     if [get_compiler_info ${info_options}] {
 118         return -1
 119     }
 120
 121     set func gdb_compile
 122     if {[lsearch -regexp $options \
 123              {^(pthreads|shlib|shlib_pthreads|openmp)$}] != -1} {
 124         # Currently don't support compiling thread based tests here.
 125         # If this is required then look to build_executable_from_specs
 126         # for inspiration.
 127         return -1
 128     }
 129     if {[lsearch -exact $options rust] != -1} {
 130         # Currently don't support compiling rust tests here.  If this
 131         # is required then look to build_executable_from_specs for
 132         # inspiration.
 133         return -1
 134     }
 135
 136     # Must be run on local host due to use of objcopy.
 137     if [is_remote host] {
 138         return -1
 139     }
 140
 141     set objects {}
 142     set i 0
 143     foreach spec $args {
 144         if {[llength $spec] < 2} {
 145             error "invalid spec length"
 146             return -1
 147         }
 148
 149         verbose -log "APB: SPEC: $spec"
 150
 151         set s [lindex $spec 0]
 152         set local_options [lindex $spec 1]
 153
 154         if { ! [regexp "^/" "$s"] } then {
 155             set s "$srcdir/$subdir/$s"
 156         }
 157
 158         if {[llength $spec] > 2} {
 159             set objfile [lindex $spec 2]
 160         } else {
 161             set objfile "${binfile}${i}.o"
 162             incr i
 163         }
 164
 165         if  { [$func "${s}" "${objfile}" object $local_options] != "" } {
 166             untested $testname
 167             return -1
 168         }
 169
 170         lappend objects "$objfile"
 171
 172         if {[lsearch -exact $local_options "split-dwo"] >= 0} {
 173             # Split out the DWO file.
 174             set dwo_file "[file rootname ${objfile}].dwo"
 175
 176             if { [extract_dwo_information $objfile $dwo_file] == -1 } {
 177                 untested $testname
 178                 return -1
 179             }
 180
 181             if { [strip_dwo_information $objfile] == -1 } {
 182                 untested $testname
 183                 return -1
 184             }
 185         }
 186     }
 187
 188     verbose -log "APB: OBJECTS = $objects"
 189
 190     set ret [$func $objects "${binfile}" executable $options]
 191     if  { $ret != "" } {
 192         untested $testname
 193         return -1
 194     }
 195
 196     return 0
 197 }
 198
 199 # Return a list of expressions about function FUNC's address and length.
 200 # The first expression is the address of function FUNC, and the second
 201 # one is FUNC's length.  SRC is the source file having function FUNC.
 202 # An internal label ${func}_label must be defined inside FUNC:
 203 #
 204 #  int main (void)
 205 #  {
 206 #    asm ("main_label: .globl main_label");
 207 #    return 0;
 208 #  }
 209 #
 210 # This label is needed to compute the start address of function FUNC.
 211 # If the compiler is gcc, we can do the following to get function start
 212 # and end address too:
 213 #
 214 # asm ("func_start: .globl func_start");
 215 # static void func (void) {}
 216 # asm ("func_end: .globl func_end");
 217 #
 218 # however, this isn't portable, because other compilers, such as clang,
 219 # may not guarantee the order of global asms and function.  The code
 220 # becomes:
 221 #
 222 # asm ("func_start: .globl func_start");
 223 # asm ("func_end: .globl func_end");
 224 # static void func (void) {}
 225 #
 226
 227 proc function_range { func src {options {debug}} } {
 228     global decimal gdb_prompt
 229
 230     set exe [standard_temp_file func_addr[pid].x]
 231
 232     gdb_compile $src $exe executable $options
 233
 234     gdb_exit
 235     gdb_start
 236     gdb_load "$exe"
 237
 238     # Compute the label offset, and we can get the function start address
 239     # by "${func}_label - $func_label_offset".
 240     set func_label_offset ""
 241     set test "p ${func}_label - ${func}"
 242     gdb_test_multiple $test $test {
 243         -re ".* = ($decimal)\r\n$gdb_prompt $" {
 244             set func_label_offset $expect_out(1,string)
 245         }
 246     }
 247
 248     # Compute the function length.
 249     global hex
 250     set func_length ""
 251     set test "disassemble $func"
 252     gdb_test_multiple $test $test {
 253         -re ".*$hex <\\+($decimal)>:\[^\r\n\]+\r\nEnd of assembler dump\.\r\n$gdb_prompt $" {
 254             set func_length $expect_out(1,string)
 255         }
 256     }
 257
 258     # Compute the size of the last instruction.
 259     if { $func_length == 0 } then {
 260         set func_pattern "$func"
 261     } else {
 262         set func_pattern "$func\\+$func_length"
 263     }
 264     set test "x/2i $func+$func_length"
 265     gdb_test_multiple $test $test {
 266         -re ".*($hex) <$func_pattern>:\[^\r\n\]+\r\n\[ \]+($hex).*\.\r\n$gdb_prompt $" {
 267             set start $expect_out(1,string)
 268             set end $expect_out(2,string)
 269
 270             set func_length [expr $func_length + $end - $start]
 271         }
 272     }
 273
 274     return [list "${func}_label - $func_label_offset" $func_length]
 275 }
 276
 277 # Extract the start, length, and end for function called NAME and
 278 # create suitable variables in the callers scope.
 279 proc get_func_info { name {options {debug}} } {
 280     global srcdir subdir srcfile
 281
 282     upvar 1 "${name}_start" func_start
 283     upvar 1 "${name}_len" func_len
 284     upvar 1 "${name}_end" func_end
 285
 286     lassign [function_range ${name} \
 287                  [list ${srcdir}/${subdir}/$srcfile] \
 288                  ${options}]  \
 289         func_start func_len
 290     set func_end "$func_start + $func_len"
 291 }
 292
 293 # A DWARF assembler.
 294 #
 295 # All the variables in this namespace are private to the
 296 # implementation.  Also, any procedure whose name starts with "_" is
 297 # private as well.  Do not use these.
 298 #
 299 # Exported functions are documented at their definition.
 300 #
 301 # In addition to the hand-written functions documented below, this
 302 # module automatically generates a function for each DWARF tag.  For
 303 # most tags, two forms are made: a full name, and one with the
 304 # "DW_TAG_" prefix stripped.  For example, you can use either
 305 # 'DW_TAG_compile_unit' or 'compile_unit' interchangeably.
 306 #
 307 # There are two exceptions to this rule: DW_TAG_variable and
 308 # DW_TAG_namespace.  For these, the full name must always be used,
 309 # as the short name conflicts with Tcl builtins.  (Should future
 310 # versions of Tcl or DWARF add more conflicts, this list will grow.
 311 # If you want to be safe you should always use the full names.)
 312 #
 313 # Each tag procedure is defined like:
 314 #
 315 # proc DW_TAG_mumble {{attrs {}} {children {}}} { ... }
 316 #
 317 # ATTRS is an optional list of attributes.
 318 # It is run through 'subst' in the caller's context before processing.
 319 #
 320 # Each attribute in the list has one of two forms:
 321 #   1. { NAME VALUE }
 322 #   2. { NAME VALUE FORM }
 323 #
 324 # In each case, NAME is the attribute's name.
 325 # This can either be the full name, like 'DW_AT_name', or a shortened
 326 # name, like 'name'.  These are fully equivalent.
 327 #
 328 # Besides DWARF standard attributes, assembler supports 'macro' attribute
 329 # which will be substituted by one or more standard or macro attributes.
 330 # supported macro attributes are:
 331 #
 332 #  - MACRO_AT_range { FUNC }
 333 #  It is substituted by DW_AT_low_pc and DW_AT_high_pc with the start and
 334 #  end address of function FUNC in file $srcdir/$subdir/$srcfile.
 335 #
 336 #  - MACRO_AT_func { FUNC }
 337 #  It is substituted by DW_AT_name with FUNC and MACRO_AT_range.
 338 #
 339 # If FORM is given, it should name a DW_FORM_ constant.
 340 # This can either be the short form, like 'DW_FORM_addr', or a
 341 # shortened version, like 'addr'.  If the form is given, VALUE
 342 # is its value; see below.  In some cases, additional processing
 343 # is done; for example, DW_FORM_strp manages the .debug_str
 344 # section automatically.
 345 #
 346 # If FORM is 'SPECIAL_expr', then VALUE is treated as a location
 347 # expression.  The effective form is then DW_FORM_block or DW_FORM_exprloc
 348 # for DWARF version >= 4, and VALUE is passed to the (internal)
 349 # '_location' proc to be translated.
 350 # This proc implements a miniature DW_OP_ assembler.
 351 #
 352 # If FORM is not given, it is guessed:
 353 # * If VALUE starts with the "@" character, the rest of VALUE is
 354 #   looked up as a DWARF constant, and DW_FORM_sdata is used.  For
 355 #   example, '@DW_LANG_c89' could be used.
 356 # * If VALUE starts with the ":" character, then it is a label
 357 #   reference.  The rest of VALUE is taken to be the name of a label,
 358 #   and DW_FORM_ref4 is used.  See 'new_label' and 'define_label'.
 359 # * If VALUE starts with the "%" character, then it is a label
 360 #   reference too, but DW_FORM_ref_addr is used.
 361 # * Otherwise, if the attribute name has a default form (f.i. DW_FORM_addr for
 362 #   DW_AT_low_pc), then that one is used.
 363 # * Otherwise, an error is reported.  Either specify a form explicitly, or
 364 #   add a default for the the attribute name in _default_form.
 365 #
 366 # CHILDREN is just Tcl code that can be used to define child DIEs.  It
 367 # is evaluated in the caller's context.
 368 #
 369 # Currently this code is missing nice support for CFA handling, and
 370 # probably other things as well.
 371
 372 namespace eval Dwarf {
 373     # True if the module has been initialized.
 374     variable _initialized 0
 375
 376     # Constants from dwarf2.h.
 377     variable _constants
 378     # DW_AT short names.
 379     variable _AT
 380     # DW_FORM short names.
 381     variable _FORM
 382     # DW_OP short names.
 383     variable _OP
 384
 385     # The current output file.
 386     variable _output_file
 387
 388     # Note: The _cu_ values here also apply to type units (TUs).
 389     # Think of a TU as a special kind of CU.
 390
 391     # Current CU count.
 392     variable _cu_count
 393
 394     # The current CU's base label.
 395     variable _cu_label
 396
 397     # The current CU's version.
 398     variable _cu_version
 399
 400     # The current CU's address size.
 401     variable _cu_addr_size
 402     # The current CU's offset size.
 403     variable _cu_offset_size
 404
 405     # Label generation number.
 406     variable _label_num
 407
 408     # The deferred output array.  The index is the section name; the
 409     # contents hold the data for that section.
 410     variable _deferred_output
 411
 412     # If empty, we should write directly to the output file.
 413     # Otherwise, this is the name of a section to write to.
 414     variable _defer
 415
 416     # The abbrev section.  Typically .debug_abbrev but can be .debug_abbrev.dwo
 417     # for Fission.
 418     variable _abbrev_section
 419
 420     # The next available abbrev number in the current CU's abbrev
 421     # table.
 422     variable _abbrev_num
 423
 424     # The string table for this assembly.  The key is the string; the
 425     # value is the label for that string.
 426     variable _strings
 427
 428     # Current .debug_line unit count.
 429     variable _line_count
 430
 431     # Whether a file_name entry was seen.
 432     variable _line_saw_file
 433
 434     # Whether a line table program has been seen.
 435     variable _line_saw_program
 436
 437     # A Label for line table header generation.
 438     variable _line_header_end_label
 439
 440     # The address size for debug ranges section.
 441     variable _debug_ranges_64_bit
 442
 443     # The index into the .debug_addr section (used for fission
 444     # generation).
 445     variable _debug_addr_index
 446
 447     # Flag, true if the current CU is contains fission information,
 448     # otherwise false.
 449     variable _cu_is_fission
 450
 451     proc _process_one_constant {name value} {
 452         variable _constants
 453         variable _AT
 454         variable _FORM
 455         variable _OP
 456
 457         set _constants($name) $value
 458
 459         if {![regexp "^DW_(\[A-Z\]+)_(\[A-Za-z0-9_\]+)$" $name \
 460                   ignore prefix name2]} {
 461             error "non-matching name: $name"
 462         }
 463
 464         if {$name2 == "lo_user" || $name2 == "hi_user"} {
 465             return
 466         }
 467
 468         # We only try to shorten some very common things.
 469         # FIXME: CFA?
 470         switch -exact -- $prefix {
 471             TAG {
 472                 # Create two procedures for the tag.  These call
 473                 # _handle_DW_TAG with the full tag name baked in; this
 474                 # does all the actual work.
 475                 proc $name {{attrs {}} {children {}}} \
 476                     "_handle_DW_TAG $name \$attrs \$children"
 477
 478                 # Filter out ones that are known to clash.
 479                 if {$name2 == "variable" || $name2 == "namespace"} {
 480                     set name2 "tag_$name2"
 481                 }
 482
 483                 if {[info commands $name2] != {}} {
 484                     error "duplicate proc name: from $name"
 485                 }
 486
 487                 proc $name2 {{attrs {}} {children {}}} \
 488                     "_handle_DW_TAG $name \$attrs \$children"
 489             }
 490
 491             AT {
 492                 set _AT($name2) $name
 493             }
 494
 495             FORM {
 496                 set _FORM($name2) $name
 497             }
 498
 499             OP {
 500                 set _OP($name2) $name
 501             }
 502
 503             default {
 504                 return
 505             }
 506         }
 507     }
 508
 509     proc _read_constants {} {
 510         global srcdir hex decimal
 511
 512         # DWARF name-matching regexp.
 513         set dwrx "DW_\[a-zA-Z0-9_\]+"
 514         # Whitespace regexp.
 515         set ws "\[ \t\]+"
 516
 517         set fd [open [file join $srcdir .. .. include dwarf2.h]]
 518         while {![eof $fd]} {
 519             set line [gets $fd]
 520             if {[regexp -- "^${ws}($dwrx)${ws}=${ws}($hex|$decimal),?$" \
 521                      $line ignore name value ignore2]} {
 522                 _process_one_constant $name $value
 523             }
 524         }
 525         close $fd
 526
 527         set fd [open [file join $srcdir .. .. include dwarf2.def]]
 528         while {![eof $fd]} {
 529             set line [gets $fd]
 530             if {[regexp -- \
 531                      "^DW_\[A-Z_\]+${ws}\\(($dwrx),${ws}($hex|$decimal)\\)$" \
 532                      $line ignore name value ignore2]} {
 533                 _process_one_constant $name $value
 534             }
 535         }
 536         close $fd
 537     }
 538
 539     proc _quote {string} {
 540         # FIXME
 541         return "\"${string}\\0\""
 542     }
 543
 544     proc _nz_quote {string} {
 545         # For now, no quoting is done.
 546         return "\"${string}\""
 547     }
 548
 549     proc _handle_DW_FORM {form value} {
 550         switch -exact -- $form {
 551             DW_FORM_string  {
 552                 _op .ascii [_quote $value]
 553             }
 554
 555             DW_FORM_flag_present {
 556                 # We don't need to emit anything.
 557             }
 558
 559             DW_FORM_data4 -
 560             DW_FORM_ref4 {
 561                 _op .4byte $value
 562             }
 563
 564             DW_FORM_ref_addr {
 565                 variable _cu_offset_size
 566                 variable _cu_version
 567                 variable _cu_addr_size
 568
 569                 if {$_cu_version == 2} {
 570                     set size $_cu_addr_size
 571                 } else {
 572                     set size $_cu_offset_size
 573                 }
 574
 575                 _op .${size}byte $value
 576             }
 577
 578             DW_FORM_GNU_ref_alt -
 579             DW_FORM_GNU_strp_alt -
 580             DW_FORM_sec_offset {
 581                 variable _cu_offset_size
 582                 _op .${_cu_offset_size}byte $value
 583             }
 584
 585             DW_FORM_ref1 -
 586             DW_FORM_flag -
 587             DW_FORM_data1 {
 588                 _op .byte $value
 589             }
 590
 591             DW_FORM_sdata {
 592                 _op .sleb128 $value
 593             }
 594
 595             DW_FORM_ref_udata -
 596             DW_FORM_udata -
 597             DW_FORM_loclistx -
 598             DW_FORM_rnglistx {
 599                 _op .uleb128 $value
 600             }
 601
 602             DW_FORM_addr {
 603                 variable _cu_addr_size
 604
 605                 _op .${_cu_addr_size}byte $value
 606             }
 607
 608             DW_FORM_GNU_addr_index {
 609                 variable _debug_addr_index
 610                 variable _cu_addr_size
 611
 612                 _op .uleb128 ${_debug_addr_index}
 613                 incr _debug_addr_index
 614
 615                 _defer_output .debug_addr {
 616                     _op .${_cu_addr_size}byte $value
 617                 }
 618             }
 619
 620             DW_FORM_data2 -
 621             DW_FORM_ref2 {
 622                 _op .2byte $value
 623             }
 624
 625             DW_FORM_data8 -
 626             DW_FORM_ref8 -
 627             DW_FORM_ref_sig8 {
 628                 _op .8byte $value
 629             }
 630
 631             DW_FORM_data16 {
 632                 _op .8byte $value
 633             }
 634
 635             DW_FORM_strp {
 636                 variable _strings
 637                 variable _cu_offset_size
 638
 639                 if {![info exists _strings($value)]} {
 640                     set _strings($value) [new_label strp]
 641                     _defer_output .debug_str {
 642                         define_label $_strings($value)
 643                         _op .ascii [_quote $value]
 644                     }
 645                 }
 646
 647                 _op .${_cu_offset_size}byte $_strings($value) "strp: $value"
 648             }
 649
 650             SPECIAL_expr {
 651                 variable _cu_version
 652                 variable _cu_addr_size
 653                 variable _cu_offset_size
 654
 655                 set l1 [new_label "expr_start"]
 656                 set l2 [new_label "expr_end"]
 657                 _op .uleb128 "$l2 - $l1" "expression"
 658                 define_label $l1
 659                 _location $value $_cu_version $_cu_addr_size $_cu_offset_size
 660                 define_label $l2
 661             }
 662
 663             DW_FORM_block1 {
 664                 set len [string length $value]
 665                 if {$len > 255} {
 666                     error "DW_FORM_block1 length too long"
 667                 }
 668                 _op .byte $len
 669                 _op .ascii [_nz_quote $value]
 670             }
 671
 672             DW_FORM_block2 -
 673             DW_FORM_block4 -
 674
 675             DW_FORM_block -
 676
 677             DW_FORM_ref2 -
 678             DW_FORM_indirect -
 679             DW_FORM_exprloc -
 680
 681             DW_FORM_strx -
 682             DW_FORM_strx1 -
 683             DW_FORM_strx2 -
 684             DW_FORM_strx3 -
 685             DW_FORM_strx4 -
 686
 687             DW_FORM_GNU_str_index -
 688
 689             default {
 690                 error "unhandled form $form"
 691             }
 692         }
 693     }
 694
 695     proc _guess_form {value varname} {
 696         upvar $varname new_value
 697
 698         switch -exact -- [string range $value 0 0] {
 699             @ {
 700                 # Constant reference.
 701                 variable _constants
 702
 703                 set new_value $_constants([string range $value 1 end])
 704                 # Just the simplest.
 705                 return DW_FORM_sdata
 706             }
 707
 708             : {
 709                 # Label reference.
 710                 variable _cu_label
 711
 712                 set new_value "[string range $value 1 end] - $_cu_label"
 713
 714                 return DW_FORM_ref4
 715             }
 716
 717             % {
 718                 # Label reference, an offset from .debug_info.
 719                 set new_value "[string range $value 1 end]"
 720
 721                 return DW_FORM_ref_addr
 722             }
 723
 724             default {
 725                 return ""
 726             }
 727         }
 728     }
 729
 730     proc _default_form { attr } {
 731         switch -exact -- $attr {
 732             DW_AT_low_pc  {
 733                 return DW_FORM_addr
 734             }
 735             DW_AT_producer -
 736             DW_AT_comp_dir -
 737             DW_AT_linkage_name -
 738             DW_AT_MIPS_linkage_name -
 739             DW_AT_name {
 740                 return DW_FORM_string
 741             }
 742             DW_AT_GNU_addr_base {
 743                 return DW_FORM_sec_offset
 744             }
 745         }
 746         return ""
 747     }
 748
 749     # Map NAME to its canonical form.
 750     proc _map_name {name ary} {
 751         variable $ary
 752
 753         if {[info exists ${ary}($name)]} {
 754             set name [set ${ary}($name)]
 755         }
 756
 757         return $name
 758     }
 759
 760     proc _handle_attribute { attr_name attr_value attr_form } {
 761         variable _abbrev_section
 762         variable _constants
 763         variable _cu_version
 764
 765         _handle_DW_FORM $attr_form $attr_value
 766
 767         _defer_output $_abbrev_section {
 768             if { $attr_form eq "SPECIAL_expr" } {
 769                 if { $_cu_version < 4 } {
 770                     set attr_form_comment "DW_FORM_block"
 771                 } else {
 772                     set attr_form_comment "DW_FORM_exprloc"
 773                 }
 774             } else {
 775                 set attr_form_comment $attr_form
 776             }
 777             _op .uleb128 $_constants($attr_name) $attr_name
 778             _op .uleb128 $_constants($attr_form) $attr_form_comment
 779         }
 780     }
 781
 782     # Handle macro attribute MACRO_AT_range.
 783
 784     proc _handle_macro_at_range { attr_value } {
 785         variable _cu_is_fission
 786
 787         if {[llength $attr_value] != 1} {
 788             error "usage: MACRO_AT_range { func }"
 789         }
 790
 791         set func [lindex $attr_value 0]
 792         global srcdir subdir srcfile
 793         set src ${srcdir}/${subdir}/${srcfile}
 794         set result [function_range $func $src]
 795
 796         set form DW_FORM_addr
 797         if { $_cu_is_fission } {
 798             set form DW_FORM_GNU_addr_index
 799         }
 800
 801         _handle_attribute DW_AT_low_pc [lindex $result 0] $form
 802         _handle_attribute DW_AT_high_pc \
 803             "[lindex $result 0] + [lindex $result 1]" $form
 804     }
 805
 806     # Handle macro attribute MACRO_AT_func.
 807
 808     proc _handle_macro_at_func { attr_value } {
 809         if {[llength $attr_value] != 1} {
 810             error "usage: MACRO_AT_func { func file }"
 811         }
 812         _handle_attribute DW_AT_name [lindex $attr_value 0] DW_FORM_string
 813         _handle_macro_at_range $attr_value
 814     }
 815
 816     proc _handle_DW_TAG {tag_name {attrs {}} {children {}}} {
 817         variable _abbrev_section
 818         variable _abbrev_num
 819         variable _constants
 820
 821         set has_children [expr {[string length $children] > 0}]
 822         set my_abbrev [incr _abbrev_num]
 823
 824         # We somewhat wastefully emit a new abbrev entry for each tag.
 825         # There's no reason for this other than laziness.
 826         _defer_output $_abbrev_section {
 827             _op .uleb128 $my_abbrev "Abbrev start"
 828             _op .uleb128 $_constants($tag_name) $tag_name
 829             _op .byte $has_children "has_children"
 830         }
 831
 832         _op .uleb128 $my_abbrev "Abbrev ($tag_name)"
 833
 834         foreach attr $attrs {
 835             set attr_name [_map_name [lindex $attr 0] _AT]
 836
 837             # When the length of ATTR is greater than 2, the last
 838             # element of the list must be a form.  The second through
 839             # the penultimate elements are joined together and
 840             # evaluated using subst.  This allows constructs such as
 841             # [gdb_target_symbol foo] to be used.
 842
 843             if {[llength $attr] > 2} {
 844                 set attr_value [uplevel 2 [list subst [join [lrange $attr 1 end-1]]]]
 845             } else {
 846                 set attr_value [uplevel 2 [list subst [lindex $attr 1]]]
 847             }
 848
 849             if { [string equal "MACRO_AT_func" $attr_name] } {
 850                 _handle_macro_at_func $attr_value
 851             } elseif { [string equal "MACRO_AT_range" $attr_name] } {
 852                 _handle_macro_at_range $attr_value
 853             } else {
 854                 if {[llength $attr] > 2} {
 855                     set attr_form [uplevel 2 [list subst [lindex $attr end]]]
 856
 857                     if { [string index $attr_value 0] == ":" } {
 858                         # It is a label, get its value.
 859                         _guess_form $attr_value attr_value
 860                     }
 861                 } else {
 862                     set attr_form [_guess_form $attr_value attr_value]
 863                     if { $attr_form eq "" } {
 864                         set attr_form [_default_form $attr_name]
 865                     }
 866                     if { $attr_form eq "" } {
 867                         error "No form for $attr_name $attr_value"
 868                     }
 869                 }
 870                 set attr_form [_map_name $attr_form _FORM]
 871
 872                 _handle_attribute $attr_name $attr_value $attr_form
 873             }
 874         }
 875
 876         _defer_output $_abbrev_section {
 877             # Terminator.
 878             _op .byte 0x0 "DW_AT - Terminator"
 879             _op .byte 0x0 "DW_FORM - Terminator"
 880         }
 881
 882         if {$has_children} {
 883             uplevel 2 $children
 884
 885             # Terminate children.
 886             _op .byte 0x0 "Terminate children"
 887         }
 888     }
 889
 890     proc _emit {string} {
 891         variable _output_file
 892         variable _defer
 893         variable _deferred_output
 894
 895         if {$_defer == ""} {
 896             puts $_output_file $string
 897         } else {
 898             append _deferred_output($_defer) ${string}\n
 899         }
 900     }
 901
 902     proc _section {name {flags ""} {type ""}} {
 903         if {$flags == "" && $type == ""} {
 904             _emit "        .section $name"
 905         } elseif {$type == ""} {
 906             _emit "        .section $name, \"$flags\""
 907         } else {
 908             _emit "        .section $name, \"$flags\", %$type"
 909         }
 910     }
 911
 912     # SECTION_SPEC is a list of arguments to _section.
 913     proc _defer_output {section_spec body} {
 914         variable _defer
 915         variable _deferred_output
 916
 917         set old_defer $_defer
 918         set _defer [lindex $section_spec 0]
 919
 920         if {![info exists _deferred_output($_defer)]} {
 921             set _deferred_output($_defer) ""
 922             eval _section $section_spec
 923         }
 924
 925         uplevel $body
 926
 927         set _defer $old_defer
 928     }
 929
 930     proc _defer_to_string {body} {
 931         variable _defer
 932         variable _deferred_output
 933
 934         set old_defer $_defer
 935         set _defer temp
 936
 937         set _deferred_output($_defer) ""
 938
 939         uplevel $body
 940
 941         set result $_deferred_output($_defer)
 942         unset _deferred_output($_defer)
 943
 944         set _defer $old_defer
 945         return $result
 946     }
 947
 948     proc _write_deferred_output {} {
 949         variable _output_file
 950         variable _deferred_output
 951
 952         foreach section [array names _deferred_output] {
 953             # The data already has a newline.
 954             puts -nonewline $_output_file $_deferred_output($section)
 955         }
 956
 957         # Save some memory.
 958         unset _deferred_output
 959     }
 960
 961     proc _op {name value {comment ""}} {
 962         set text "        ${name}        ${value}"
 963         if {$comment != ""} {
 964             # Try to make stuff line up nicely.
 965             while {[string length $text] < 40} {
 966                 append text " "
 967             }
 968             append text "/* ${comment} */"
 969         }
 970         _emit $text
 971     }
 972
 973     proc _compute_label {name} {
 974         return ".L${name}"
 975     }
 976
 977     # Return a name suitable for use as a label.  If BASE_NAME is
 978     # specified, it is incorporated into the label name; this is to
 979     # make debugging the generated assembler easier.  If BASE_NAME is
 980     # not specified a generic default is used.  This proc does not
 981     # define the label; see 'define_label'.  'new_label' attempts to
 982     # ensure that label names are unique.
 983     proc new_label {{base_name label}} {
 984         variable _label_num
 985
 986         return [_compute_label ${base_name}[incr _label_num]]
 987     }
 988
 989     # Define a label named NAME.  Ordinarily, NAME comes from a call
 990     # to 'new_label', but this is not required.
 991     proc define_label {name} {
 992         _emit "${name}:"
 993     }
 994
 995     # A higher-level interface to label handling.
 996     #
 997     # ARGS is a list of label descriptors.  Each one is either a
 998     # single element, or a list of two elements -- a name and some
 999     # text.  For each descriptor, 'new_label' is invoked.  If the list
1000     # form is used, the second element in the list is passed as an
1001     # argument.  The label name is used to define a variable in the
1002     # enclosing scope; this can be used to refer to the label later.
1003     # The label name is also used to define a new proc whose name is
1004     # the label name plus a trailing ":".  This proc takes a body as
1005     # an argument and can be used to define the label at that point;
1006     # then the body, if any, is evaluated in the caller's context.
1007     #
1008     # For example:
1009     #
1010     # declare_labels int_label
1011     # something { ... $int_label }   ;# refer to the label
1012     # int_label: constant { ... }    ;# define the label
1013     proc declare_labels {args} {
1014         foreach arg $args {
1015             set name [lindex $arg 0]
1016             set text [lindex $arg 1]
1017
1018             if { $text == "" } {
1019                 set text $name
1020             }
1021
1022             upvar $name label_var
1023             set label_var [new_label $text]
1024
1025             proc ${name}: {args} [format {
1026                 define_label %s
1027                 uplevel $args
1028             } $label_var]
1029         }
1030     }
1031
1032     # Assign elements from LINE to the elements of an array named
1033     # "argvec" in the caller scope.  The keys used are named in ARGS.
1034     # If the wrong number of elements appear in LINE, error.
1035     proc _get_args {line op args} {
1036         if {[llength $line] != [llength $args] + 1} {
1037             error "usage: $op [string toupper $args]"
1038         }
1039
1040         upvar argvec argvec
1041         foreach var $args value [lreplace $line 0 0] {
1042             set argvec($var) $value
1043         }
1044     }
1045
1046     # This is a miniature assembler for location expressions.  It is
1047     # suitable for use in the attributes to a DIE.  Its output is
1048     # prefixed with "=" to make it automatically use DW_FORM_block.
1049     #
1050     # BODY is split by lines, and each line is taken to be a list.
1051     #
1052     # DWARF_VERSION is the DWARF version for the section where the location
1053     # description is found.
1054     #
1055     # ADDR_SIZE is the length in bytes (4 or 8) of an address on the target
1056     # machine (typically found in the header of the section where the location
1057     # description is found).
1058     #
1059     # OFFSET_SIZE is the length in bytes (4 or 8) of an offset into a DWARF
1060     # section.  This typically depends on whether 32-bit or 64-bit DWARF is
1061     # used, as indicated in the header of the section where the location
1062     # description is found.
1063     #
1064     # (FIXME should use 'info complete' here.)
1065     # Each list's first element is the opcode, either short or long
1066     # forms are accepted.
1067     # FIXME argument handling
1068     # FIXME move docs
1069     proc _location { body dwarf_version addr_size offset_size } {
1070         variable _constants
1071
1072         foreach line [split $body \n] {
1073             # Ignore blank lines, and allow embedded comments.
1074             if {[lindex $line 0] == "" || [regexp -- {^[ \t]*#} $line]} {
1075                 continue
1076             }
1077             set opcode [_map_name [lindex $line 0] _OP]
1078             _op .byte $_constants($opcode) $opcode
1079
1080             array unset argvec *
1081             switch -exact -- $opcode {
1082                 DW_OP_addr {
1083                     _get_args $line $opcode size
1084                     _op .${addr_size}byte $argvec(size)
1085                 }
1086
1087                 DW_OP_GNU_addr_index {
1088                     variable _debug_addr_index
1089                     variable _cu_addr_size
1090
1091                     _op .uleb128 ${_debug_addr_index}
1092                     incr _debug_addr_index
1093
1094                     _defer_output .debug_addr {
1095                         _op .${_cu_addr_size}byte [lindex $line 1]
1096                     }
1097                 }
1098
1099                 DW_OP_regx {
1100                     _get_args $line $opcode register
1101                     _op .uleb128 $argvec(register)
1102                 }
1103
1104                 DW_OP_pick -
1105                 DW_OP_const1u -
1106                 DW_OP_const1s {
1107                     _get_args $line $opcode const
1108                     _op .byte $argvec(const)
1109                 }
1110
1111                 DW_OP_const2u -
1112                 DW_OP_const2s {
1113                     _get_args $line $opcode const
1114                     _op .2byte $argvec(const)
1115                 }
1116
1117                 DW_OP_const4u -
1118                 DW_OP_const4s {
1119                     _get_args $line $opcode const
1120                     _op .4byte $argvec(const)
1121                 }
1122
1123                 DW_OP_const8u -
1124                 DW_OP_const8s {
1125                     _get_args $line $opcode const
1126                     _op .8byte $argvec(const)
1127                 }
1128
1129                 DW_OP_constu {
1130                     _get_args $line $opcode const
1131                     _op .uleb128 $argvec(const)
1132                 }
1133                 DW_OP_consts {
1134                     _get_args $line $opcode const
1135                     _op .sleb128 $argvec(const)
1136                 }
1137
1138                 DW_OP_plus_uconst {
1139                     _get_args $line $opcode const
1140                     _op .uleb128 $argvec(const)
1141                 }
1142
1143                 DW_OP_piece {
1144                     _get_args $line $opcode size
1145                     _op .uleb128 $argvec(size)
1146                 }
1147
1148                 DW_OP_bit_piece {
1149                     _get_args $line $opcode size offset
1150                     _op .uleb128 $argvec(size)
1151                     _op .uleb128 $argvec(offset)
1152                 }
1153
1154                 DW_OP_skip -
1155                 DW_OP_bra {
1156                     _get_args $line $opcode label
1157                     _op .2byte $argvec(label)
1158                 }
1159
1160                 DW_OP_implicit_value {
1161                     set l1 [new_label "value_start"]
1162                     set l2 [new_label "value_end"]
1163                     _op .uleb128 "$l2 - $l1"
1164                     define_label $l1
1165                     foreach value [lrange $line 1 end] {
1166                         switch -regexp -- $value {
1167                             {^0x[[:xdigit:]]{1,2}$} {_op .byte $value}
1168                             {^0x[[:xdigit:]]{4}$} {_op .2byte $value}
1169                             {^0x[[:xdigit:]]{8}$} {_op .4byte $value}
1170                             {^0x[[:xdigit:]]{16}$} {_op .8byte $value}
1171                             default {
1172                                 error "bad value '$value' in DW_OP_implicit_value"
1173                             }
1174                         }
1175                     }
1176                     define_label $l2
1177                 }
1178
1179                 DW_OP_implicit_pointer -
1180                 DW_OP_GNU_implicit_pointer {
1181                     _get_args $line $opcode label offset
1182
1183                     # Here label is a section offset.
1184                     if { $dwarf_version == 2 } {
1185                         _op .${addr_size}byte $argvec(label)
1186                     } else {
1187                         _op .${offset_size}byte $argvec(label)
1188                     }
1189                     _op .sleb128 $argvec(offset)
1190                 }
1191
1192                 DW_OP_GNU_variable_value {
1193                     _get_args $line $opcode label
1194
1195                     # Here label is a section offset.
1196                     if { $dwarf_version == 2 } {
1197                         _op .${addr_size}byte $argvec(label)
1198                     } else {
1199                         _op .${offset_size}byte $argvec(label)
1200                     }
1201                 }
1202
1203                 DW_OP_deref_size {
1204                     _get_args $line $opcode size
1205                     _op .byte $argvec(size)
1206                 }
1207
1208                 DW_OP_bregx {
1209                     _get_args $line $opcode register offset
1210                     _op .uleb128 $argvec(register)
1211                     _op .sleb128 $argvec(offset)
1212                 }
1213
1214                 default {
1215                     if {[llength $line] > 1} {
1216                         error "Unimplemented: operands in location for $opcode"
1217                     }
1218                 }
1219             }
1220         }
1221     }
1222
1223     # Return a label that references the current position in the
1224     # .debug_addr table.  When a user is creating split DWARF they
1225     # will define two CUs, the first will be the split DWARF content,
1226     # and the second will be the non-split stub CU.  The split DWARF
1227     # CU fills in the .debug_addr section, but the non-split CU
1228     # includes a reference to the start of the section.  The label
1229     # returned by this proc provides that reference.
1230     proc debug_addr_label {} {
1231         variable _debug_addr_index
1232
1233         set lbl [new_label "debug_addr_idx_${_debug_addr_index}_"]
1234         _defer_output .debug_addr {
1235             define_label $lbl
1236         }
1237         return $lbl
1238     }
1239
1240     # Emit a DWARF CU.
1241     # OPTIONS is a list with an even number of elements containing
1242     # option-name and option-value pairs.
1243     # Current options are:
1244     # is_64 0|1    - boolean indicating if you want to emit 64-bit DWARF
1245     #                default = 0 (32-bit)
1246     # version n    - DWARF version number to emit
1247     #                default = 4
1248     # addr_size n  - the size of addresses in bytes: 4, 8, or default
1249     #                default = default
1250     # fission 0|1  - boolean indicating if generating Fission debug info
1251     #                default = 0
1252     # BODY is Tcl code that emits the DIEs which make up the body of
1253     # the CU.  It is evaluated in the caller's context.
1254     proc cu {options body} {
1255         variable _constants
1256         variable _cu_count
1257         variable _abbrev_section
1258         variable _abbrev_num
1259         variable _cu_label
1260         variable _cu_version
1261         variable _cu_addr_size
1262         variable _cu_offset_size
1263         variable _cu_is_fission
1264
1265         # Establish the defaults.
1266         set is_64 0
1267         set _cu_version 4
1268         set _cu_addr_size default
1269         set _cu_is_fission 0
1270         set section ".debug_info"
1271         set _abbrev_section ".debug_abbrev"
1272
1273         foreach { name value } $options {
1274             set value [uplevel 1 "subst \"$value\""]
1275             switch -exact -- $name {
1276                 is_64 { set is_64 $value }
1277                 version { set _cu_version $value }
1278                 addr_size { set _cu_addr_size $value }
1279                 fission { set _cu_is_fission $value }
1280                 default { error "unknown option $name" }
1281             }
1282         }
1283         if {$_cu_addr_size == "default"} {
1284             if {[is_64_target]} {
1285                 set _cu_addr_size 8
1286             } else {
1287                 set _cu_addr_size 4
1288             }
1289         }
1290         set _cu_offset_size [expr { $is_64 ? 8 : 4 }]
1291         if { $_cu_is_fission } {
1292             set section ".debug_info.dwo"
1293             set _abbrev_section ".debug_abbrev.dwo"
1294         }
1295
1296         if {$_cu_version < 4} {
1297             set _constants(SPECIAL_expr) $_constants(DW_FORM_block)
1298         } else {
1299             set _constants(SPECIAL_expr) $_constants(DW_FORM_exprloc)
1300         }
1301
1302         _section $section
1303
1304         set cu_num [incr _cu_count]
1305         set my_abbrevs [_compute_label "abbrev${cu_num}_begin"]
1306         set _abbrev_num 1
1307
1308         set _cu_label [_compute_label "cu${cu_num}_begin"]
1309         set start_label [_compute_label "cu${cu_num}_start"]
1310         set end_label [_compute_label "cu${cu_num}_end"]
1311
1312         define_label $_cu_label
1313         if {$is_64} {
1314             _op .4byte 0xffffffff
1315             _op .8byte "$end_label - $start_label"
1316         } else {
1317             _op .4byte "$end_label - $start_label"
1318         }
1319         define_label $start_label
1320         _op .2byte $_cu_version Version
1321
1322         # The CU header for DWARF 4 and 5 are slightly different.
1323         if { $_cu_version == 5 } {
1324             _op .byte 0x1 "DW_UT_compile"
1325             _op .byte $_cu_addr_size "Pointer size"
1326             _op .${_cu_offset_size}byte $my_abbrevs Abbrevs
1327         } else {
1328             _op .${_cu_offset_size}byte $my_abbrevs Abbrevs
1329             _op .byte $_cu_addr_size "Pointer size"
1330         }
1331
1332         _defer_output $_abbrev_section {
1333             define_label $my_abbrevs
1334         }
1335
1336         uplevel $body
1337
1338         _defer_output $_abbrev_section {
1339             # Emit the terminator.
1340             _op .byte 0x0 "Abbrev end - Terminator"
1341         }
1342
1343         define_label $end_label
1344     }
1345
1346     # Emit a DWARF TU.
1347     # OPTIONS is a list with an even number of elements containing
1348     # option-name and option-value pairs.
1349     # Current options are:
1350     # is_64 0|1    - boolean indicating if you want to emit 64-bit DWARF
1351     #                default = 0 (32-bit)
1352     # version n    - DWARF version number to emit
1353     #                default = 4
1354     # addr_size n  - the size of addresses in bytes: 4, 8, or default
1355     #                default = default
1356     # fission 0|1  - boolean indicating if generating Fission debug info
1357     #                default = 0
1358     # SIGNATURE is the 64-bit signature of the type.
1359     # TYPE_LABEL is the label of the type defined by this TU,
1360     # or "" if there is no type (i.e., type stubs in Fission).
1361     # BODY is Tcl code that emits the DIEs which make up the body of
1362     # the TU.  It is evaluated in the caller's context.
1363     proc tu {options signature type_label body} {
1364         variable _cu_count
1365         variable _abbrev_section
1366         variable _abbrev_num
1367         variable _cu_label
1368         variable _cu_version
1369         variable _cu_addr_size
1370         variable _cu_offset_size
1371         variable _cu_is_fission
1372
1373         # Establish the defaults.
1374         set is_64 0
1375         set _cu_version 4
1376         set _cu_addr_size default
1377         set _cu_is_fission 0
1378         set section ".debug_types"
1379         set _abbrev_section ".debug_abbrev"
1380
1381         foreach { name value } $options {
1382             switch -exact -- $name {
1383                 is_64 { set is_64 $value }
1384                 version { set _cu_version $value }
1385                 addr_size { set _cu_addr_size $value }
1386                 fission { set _cu_is_fission $value }
1387                 default { error "unknown option $name" }
1388             }
1389         }
1390         if {$_cu_addr_size == "default"} {
1391             if {[is_64_target]} {
1392                 set _cu_addr_size 8
1393             } else {
1394                 set _cu_addr_size 4
1395             }
1396         }
1397         set _cu_offset_size [expr { $is_64 ? 8 : 4 }]
1398         if { $_cu_is_fission } {
1399             set section ".debug_types.dwo"
1400             set _abbrev_section ".debug_abbrev.dwo"
1401         }
1402
1403         _section $section
1404
1405         set cu_num [incr _cu_count]
1406         set my_abbrevs [_compute_label "abbrev${cu_num}_begin"]
1407         set _abbrev_num 1
1408
1409         set _cu_label [_compute_label "cu${cu_num}_begin"]
1410         set start_label [_compute_label "cu${cu_num}_start"]
1411         set end_label [_compute_label "cu${cu_num}_end"]
1412
1413         define_label $_cu_label
1414         if {$is_64} {
1415             _op .4byte 0xffffffff
1416             _op .8byte "$end_label - $start_label"
1417         } else {
1418             _op .4byte "$end_label - $start_label"
1419         }
1420         define_label $start_label
1421         _op .2byte $_cu_version Version
1422         _op .${_cu_offset_size}byte $my_abbrevs Abbrevs
1423         _op .byte $_cu_addr_size "Pointer size"
1424         _op .8byte $signature Signature
1425         if { $type_label != "" } {
1426             uplevel declare_labels $type_label
1427             upvar $type_label my_type_label
1428             if {$is_64} {
1429                 _op .8byte "$my_type_label - $_cu_label"
1430             } else {
1431                 _op .4byte "$my_type_label - $_cu_label"
1432             }
1433         } else {
1434             if {$is_64} {
1435                 _op .8byte 0
1436             } else {
1437                 _op .4byte 0
1438             }
1439         }
1440
1441         _defer_output $_abbrev_section {
1442             define_label $my_abbrevs
1443         }
1444
1445         uplevel $body
1446
1447         _defer_output $_abbrev_section {
1448             # Emit the terminator.
1449             _op .byte 0x0 "Abbrev end - Terminator"
1450         }
1451
1452         define_label $end_label
1453     }
1454
1455     # Emit a DWARF .debug_ranges unit.
1456     # OPTIONS is a list with an even number of elements containing
1457     # option-name and option-value pairs.
1458     # Current options are:
1459     # is_64 0|1    - boolean indicating if you want to emit 64-bit DWARF
1460     #                default = 0 (32-bit)
1461     #
1462     # BODY is Tcl code that emits the content of the .debug_ranges
1463     # unit, it is evaluated in the caller's context.
1464     proc ranges {options body} {
1465         variable _debug_ranges_64_bit
1466
1467         foreach { name value } $options {
1468             switch -exact -- $name {
1469                 is_64 { set _debug_ranges_64_bit [subst $value] }
1470                 default { error "unknown option $name" }
1471             }
1472         }
1473
1474         set section ".debug_ranges"
1475         _section $section
1476
1477         proc sequence { body } {
1478             variable _debug_ranges_64_bit
1479
1480             # Emit the sequence of addresses.
1481
1482             proc base { addr } {
1483                 variable _debug_ranges_64_bit
1484
1485                 if { $_debug_ranges_64_bit } then {
1486                     _op .8byte 0xffffffffffffffff "Base Marker"
1487                     _op .8byte $addr "Base Address"
1488                 } else {
1489                     _op .4byte 0xffffffff "Base Marker"
1490                     _op .4byte $addr "Base Address"
1491                 }
1492             }
1493
1494             proc range { start end } {
1495                 variable _debug_ranges_64_bit
1496
1497                 if { $_debug_ranges_64_bit } then {
1498                     _op .8byte $start "Start Address"
1499                     _op .8byte $end "End Address"
1500                 } else {
1501                     _op .4byte $start "Start Address"
1502                     _op .4byte $end "End Address"
1503                 }
1504             }
1505
1506             uplevel $body
1507
1508             # End of the sequence.
1509             if { $_debug_ranges_64_bit } then {
1510                 _op .8byte 0x0 "End of Sequence Marker (Part 1)"
1511                 _op .8byte 0x0 "End of Sequence Marker (Part 2)"
1512             } else {
1513                 _op .4byte 0x0 "End of Sequence Marker (Part 1)"
1514                 _op .4byte 0x0 "End of Sequence Marker (Part 2)"
1515             }
1516         }
1517
1518         uplevel $body
1519     }
1520
1521     # Emit a DWARF .debug_rnglists section.
1522     #
1523     # The target address size is based on the current target's address size.
1524     #
1525     # There is one mandatory positional argument, BODY, which must be Tcl code
1526     # that emits the content of the section.  It is evaluated in the caller's
1527     # context.
1528     #
1529     # The following option can be used:
1530     #
1531     #  - -is-64 true|false: Whether to use 64-bit DWARF instead of 32-bit DWARF.
1532     #                       The default is 32-bit.
1533
1534     proc rnglists { args } {
1535         variable _debug_rnglists_addr_size
1536         variable _debug_rnglists_offset_size
1537         variable _debug_rnglists_is_64_dwarf
1538
1539         parse_args {{"is-64" "false"}}
1540
1541         if { [llength $args] != 1 } {
1542             error "rnglists proc expects one positional argument (body)"
1543         }
1544
1545         lassign $args body
1546
1547         if [is_64_target] {
1548             set _debug_rnglists_addr_size 8
1549         } else {
1550             set _debug_rnglists_addr_size 4
1551         }
1552
1553         if { ${is-64} } {
1554             set _debug_rnglists_offset_size 8
1555             set _debug_rnglists_is_64_dwarf true
1556         } else {
1557             set _debug_rnglists_offset_size 4
1558             set _debug_rnglists_is_64_dwarf false
1559         }
1560
1561         _section ".debug_rnglists"
1562
1563         # Count of tables in the section.
1564         variable _debug_rnglists_table_count 0
1565
1566         # Compute the label name for list at index LIST_IDX, for the current
1567         # table.
1568
1569         proc _compute_list_label { list_idx } {
1570             variable _debug_rnglists_table_count
1571
1572             return ".Lrnglists_table_${_debug_rnglists_table_count}_list_${list_idx}"
1573         }
1574
1575         # Generate one table (header + offset array + range lists).
1576         #
1577         # Accepts one positional argument, BODY.  BODY may call the LIST_
1578         # procedure to generate rnglists.
1579         #
1580         # The -post-header-label option can be used to define a label just after
1581         # the header of the table.  This is the label that a DW_AT_rnglists_base
1582         # attribute will usually refer to.
1583         #
1584         # The `-with-offset-array true|false` option can be used to control
1585         # whether the headers of the location list tables have an array of
1586         # offset.  The default is true.
1587
1588         proc table { args } {
1589             variable _debug_rnglists_table_count
1590             variable _debug_rnglists_addr_size
1591             variable _debug_rnglists_offset_size
1592             variable _debug_rnglists_is_64_dwarf
1593
1594             parse_args {
1595                 {post-header-label ""}
1596                 {with-offset-array true}
1597             }
1598
1599             if { [llength $args] != 1 } {
1600                 error "table proc expects one positional argument (body)"
1601             }
1602
1603             lassign $args body
1604
1605             # Generate one range list.
1606             #
1607             # BODY may call the various procs defined below to generate list entries.
1608             # They correspond to the range list entry kinds described in section 2.17.3
1609             # of the DWARF 5 spec.
1610             #
1611             # To define a label pointing to the beginning of the list, use
1612             # the conventional way of declaring and defining labels:
1613             #
1614             #   declare_labels the_list
1615             #
1616             #   the_list: list_ {
1617             #     ...
1618             #   }
1619
1620             proc list_ { body } {
1621                 variable _debug_rnglists_list_count
1622
1623                 # Define a label for this list.  It is used to build the offset
1624                 # array later.
1625                 set list_label [_compute_list_label $_debug_rnglists_list_count]
1626                 define_label $list_label
1627
1628                 # Emit a DW_RLE_start_end entry.
1629
1630                 proc start_end { start end } {
1631                     variable _debug_rnglists_addr_size
1632
1633                     _op .byte 0x06 "DW_RLE_start_end"
1634                     _op .${_debug_rnglists_addr_size}byte $start "start"
1635                     _op .${_debug_rnglists_addr_size}byte $end "end"
1636                 }
1637
1638                 uplevel $body
1639
1640                 # Emit end of list.
1641                 _op .byte 0x00 "DW_RLE_end_of_list"
1642
1643                 incr _debug_rnglists_list_count
1644             }
1645
1646             # Count of lists in the table.
1647             variable _debug_rnglists_list_count 0
1648
1649             # Generate the lists ops first, because we need to know how many
1650             # lists there are to generate the header and offset table.
1651             set lists_ops [_defer_to_string {
1652                 uplevel $body
1653             }]
1654
1655             set post_unit_len_label \
1656                 [_compute_label "rnglists_table_${_debug_rnglists_table_count}_post_unit_len"]
1657             set post_header_label \
1658                 [_compute_label "rnglists_table_${_debug_rnglists_table_count}_post_header"]
1659             set table_end_label \
1660                 [_compute_label "rnglists_table_${_debug_rnglists_table_count}_end"]
1661
1662             # Emit the table header.
1663             if { $_debug_rnglists_is_64_dwarf } {
1664                 _op .4byte 0xffffffff "unit length 1/2"
1665                 _op .8byte "$table_end_label - $post_unit_len_label" "unit length 2/2"
1666             } else {
1667                 _op .4byte "$table_end_label - $post_unit_len_label" "unit length"
1668             }
1669
1670             define_label $post_unit_len_label
1671
1672             _op .2byte 5 "dwarf version"
1673             _op .byte $_debug_rnglists_addr_size "address size"
1674             _op .byte 0 "segment selector size"
1675
1676             if { ${with-offset-array} } {
1677               _op .4byte "$_debug_rnglists_list_count" "offset entry count"
1678             } else {
1679               _op .4byte 0 "offset entry count"
1680             }
1681
1682             define_label $post_header_label
1683
1684             # Define the user post-header label, if provided.
1685             if { ${post-header-label} != "" } {
1686                 define_label ${post-header-label}
1687             }
1688
1689             # Emit the offset array.
1690             if { ${with-offset-array} } {
1691                 for {set list_idx 0} {$list_idx < $_debug_rnglists_list_count} {incr list_idx} {
1692                     set list_label [_compute_list_label $list_idx]
1693                     _op .${_debug_rnglists_offset_size}byte "$list_label - $post_header_label" "offset of list $list_idx"
1694                 }
1695             }
1696
1697             # Emit the actual list data.
1698             _emit "$lists_ops"
1699
1700             define_label $table_end_label
1701
1702             incr _debug_rnglists_table_count
1703         }
1704
1705         uplevel $body
1706     }
1707
1708     # Emit a DWARF .debug_loclists section.
1709     #
1710     # The target address size is based on the current target's address size.
1711     #
1712     # There is one mandatory positional argument, BODY, which must be Tcl code
1713     # that emits the content of the section.  It is evaluated in the caller's
1714     # context.
1715     #
1716     # The following option can be used:
1717     #
1718     #  - -is-64 true|false: Whether to use 64-bit DWARF instead of 32-bit DWARF.
1719     #                       The default is 32-bit.
1720
1721     proc loclists { args } {
1722         variable _debug_loclists_addr_size
1723         variable _debug_loclists_offset_size
1724         variable _debug_loclists_is_64_dwarf
1725
1726         parse_args {{"is-64" "false"}}
1727
1728         if { [llength $args] != 1 } {
1729             error "loclists proc expects one positional argument (body)"
1730         }
1731
1732         lassign $args body
1733
1734         if [is_64_target] {
1735             set _debug_loclists_addr_size 8
1736         } else {
1737             set _debug_loclists_addr_size 4
1738         }
1739
1740         if { ${is-64} } {
1741             set _debug_loclists_offset_size 8
1742             set _debug_loclists_is_64_dwarf true
1743         } else {
1744             set _debug_loclists_offset_size 4
1745             set _debug_loclists_is_64_dwarf false
1746         }
1747
1748         _section ".debug_loclists"
1749
1750         # Count of tables in the section.
1751         variable _debug_loclists_table_count 0
1752
1753         # Compute the label name for list at index LIST_IDX, for the current
1754         # table.
1755
1756         proc _compute_list_label { list_idx } {
1757             variable _debug_loclists_table_count
1758
1759             return ".Lloclists_table_${_debug_loclists_table_count}_list_${list_idx}"
1760         }
1761
1762         # Generate one table (header + offset array + location lists).
1763         #
1764         # Accepts one position argument, BODY.  BODY may call the LIST_
1765         # procedure to generate loclists.
1766         #
1767         # The -post-header-label option can be used to define a label just after the
1768         # header of the table.  This is the label that a DW_AT_loclists_base
1769         # attribute will usually refer to.
1770         #
1771         # The `-with-offset-array true|false` option can be used to control
1772         # whether the headers of the location list tables have an array of
1773         # offset.  The default is true.
1774
1775         proc table { args } {
1776             variable _debug_loclists_table_count
1777             variable _debug_loclists_addr_size
1778             variable _debug_loclists_offset_size
1779             variable _debug_loclists_is_64_dwarf
1780
1781             parse_args {
1782                 {post-header-label ""}
1783                 {with-offset-array true}
1784             }
1785
1786             if { [llength $args] != 1 } {
1787                 error "table proc expects one positional argument (body)"
1788             }
1789
1790             lassign $args body
1791
1792             # Generate one location list.
1793             #
1794             # BODY may call the various procs defined below to generate list
1795             # entries.  They correspond to the location list entry kinds
1796             # described in section 2.6.2 of the DWARF 5 spec.
1797             #
1798             # To define a label pointing to the beginning of the list, use
1799             # the conventional way of declaring and defining labels:
1800             #
1801             #   declare_labels the_list
1802             #
1803             #   the_list: list_ {
1804             #     ...
1805             #   }
1806
1807             proc list_ { body } {
1808                 variable _debug_loclists_list_count
1809
1810                 # Count the location descriptions in this list.
1811                 variable _debug_loclists_locdesc_count 0
1812
1813                 # Define a label for this list.  It is used to build the offset
1814                 # array later.
1815                 set list_label [_compute_list_label $_debug_loclists_list_count]
1816                 define_label $list_label
1817
1818                 # Emit a DW_LLE_start_length entry.
1819
1820                 proc start_length { start length locdesc } {
1821                     variable _debug_loclists_is_64_dwarf
1822                     variable _debug_loclists_addr_size
1823                     variable _debug_loclists_offset_size
1824                     variable _debug_loclists_table_count
1825                     variable _debug_loclists_list_count
1826                     variable _debug_loclists_locdesc_count
1827
1828                     _op .byte 0x08 "DW_LLE_start_length"
1829
1830                     # Start and end of the address range.
1831                     _op .${_debug_loclists_addr_size}byte $start "start"
1832                     _op .uleb128 $length "length"
1833
1834                     # Length of location description.
1835                     set locdesc_start_label ".Lloclists_table_${_debug_loclists_table_count}_list_${_debug_loclists_list_count}_locdesc_${_debug_loclists_locdesc_count}_start"
1836                     set locdesc_end_label ".Lloclists_table_${_debug_loclists_table_count}_list_${_debug_loclists_list_count}_locdesc_${_debug_loclists_locdesc_count}_end"
1837                     _op .uleb128 "$locdesc_end_label - $locdesc_start_label" "locdesc length"
1838
1839                     define_label $locdesc_start_label
1840                     set dwarf_version 5
1841                     _location $locdesc $dwarf_version $_debug_loclists_addr_size $_debug_loclists_offset_size
1842                     define_label $locdesc_end_label
1843
1844                     incr _debug_loclists_locdesc_count
1845                 }
1846
1847                 uplevel $body
1848
1849                 # Emit end of list.
1850                 _op .byte 0x00 "DW_LLE_end_of_list"
1851
1852                 incr _debug_loclists_list_count
1853             }
1854
1855             # Count of lists in the table.
1856             variable _debug_loclists_list_count 0
1857
1858             # Generate the lists ops first, because we need to know how many
1859             # lists there are to generate the header and offset table.
1860             set lists_ops [_defer_to_string {
1861                 uplevel $body
1862             }]
1863
1864             set post_unit_len_label \
1865                 [_compute_label "loclists_table_${_debug_loclists_table_count}_post_unit_len"]
1866             set post_header_label \
1867                 [_compute_label "loclists_table_${_debug_loclists_table_count}_post_header"]
1868             set table_end_label \
1869                 [_compute_label "loclists_table_${_debug_loclists_table_count}_end"]
1870
1871             # Emit the table header.
1872             if { $_debug_loclists_is_64_dwarf } {
1873                 _op .4byte 0xffffffff "unit length 1/2"
1874                 _op .8byte "$table_end_label - $post_unit_len_label" "unit length 2/2"
1875             } else {
1876                 _op .4byte "$table_end_label - $post_unit_len_label" "unit length"
1877             }
1878
1879             define_label $post_unit_len_label
1880
1881             _op .2byte 5 "DWARF version"
1882             _op .byte $_debug_loclists_addr_size "address size"
1883             _op .byte 0 "segment selector size"
1884
1885             if { ${with-offset-array} } {
1886               _op .4byte "$_debug_loclists_list_count" "offset entry count"
1887             } else {
1888               _op .4byte 0 "offset entry count"
1889             }
1890
1891             define_label $post_header_label
1892
1893             # Define the user post-header label, if provided.
1894             if { ${post-header-label} != "" } {
1895                 define_label ${post-header-label}
1896             }
1897
1898             # Emit the offset array.
1899             if { ${with-offset-array} } {
1900                 for {set list_idx 0} {$list_idx < $_debug_loclists_list_count} {incr list_idx} {
1901                     set list_label [_compute_list_label $list_idx]
1902                     _op .${_debug_loclists_offset_size}byte "$list_label - $post_header_label" "offset of list $list_idx"
1903                 }
1904             }
1905
1906             # Emit the actual list data.
1907             _emit "$lists_ops"
1908
1909             define_label $table_end_label
1910
1911             incr _debug_loclists_table_count
1912         }
1913
1914         uplevel $body
1915     }
1916
1917     # Emit a DWARF .debug_line unit.
1918     # OPTIONS is a list with an even number of elements containing
1919     # option-name and option-value pairs.
1920     # Current options are:
1921     # is_64 0|1    - boolean indicating if you want to emit 64-bit DWARF
1922     #                default = 0 (32-bit)
1923     # version n    - DWARF version number to emit
1924     #                default = 4
1925     # addr_size n  - the size of addresses in bytes: 4, 8, or default
1926     #                default = default
1927     #
1928     # LABEL is the label of the current unit (which is probably
1929     # referenced by a DW_AT_stmt_list), or "" if there is no such
1930     # label.
1931     #
1932     # BODY is Tcl code that emits the parts which make up the body of
1933     # the line unit.  It is evaluated in the caller's context.  The
1934     # following commands are available for the BODY section:
1935     #
1936     #   include_dir "dirname" -- adds a new include directory
1937     #
1938     #   file_name "file.c" idx -- adds a new file name.  IDX is a
1939     #   1-based index referencing an include directory or 0 for
1940     #   current directory.
1941
1942     proc lines {options label body} {
1943         variable _line_count
1944         variable _line_saw_file
1945         variable _line_saw_program
1946         variable _line_header_end_label
1947
1948         # Establish the defaults.
1949         set is_64 0
1950         set _unit_version 4
1951         set _unit_addr_size default
1952         set _line_saw_program 0
1953         set _line_saw_file 0
1954         set _default_is_stmt 1
1955
1956         foreach { name value } $options {
1957             switch -exact -- $name {
1958                 is_64 { set is_64 $value }
1959                 version { set _unit_version $value }
1960                 addr_size { set _unit_addr_size $value }
1961                 default_is_stmt { set _default_is_stmt $value }
1962                 default { error "unknown option $name" }
1963             }
1964         }
1965         if {$_unit_addr_size == "default"} {
1966             if {[is_64_target]} {
1967                 set _unit_addr_size 8
1968             } else {
1969                 set _unit_addr_size 4
1970             }
1971         }
1972
1973         set unit_num [incr _line_count]
1974
1975         set section ".debug_line"
1976         _section $section
1977
1978         if { "$label" != "" } {
1979             # Define the user-provided label at this point.
1980             $label:
1981         }
1982
1983         set unit_len_label [_compute_label "line${_line_count}_start"]
1984         set unit_end_label [_compute_label "line${_line_count}_end"]
1985         set header_len_label [_compute_label "line${_line_count}_header_start"]
1986         set _line_header_end_label [_compute_label "line${_line_count}_header_end"]
1987
1988         if {$is_64} {
1989             _op .4byte 0xffffffff
1990             _op .8byte "$unit_end_label - $unit_len_label" "unit_length"
1991         } else {
1992             _op .4byte "$unit_end_label - $unit_len_label" "unit_length"
1993         }
1994
1995         define_label $unit_len_label
1996
1997         _op .2byte $_unit_version version
1998
1999         if {$is_64} {
2000             _op .8byte "$_line_header_end_label - $header_len_label" "header_length"
2001         } else {
2002             _op .4byte "$_line_header_end_label - $header_len_label" "header_length"
2003         }
2004
2005         define_label $header_len_label
2006
2007         _op .byte 1 "minimum_instruction_length"
2008         _op .byte $_default_is_stmt "default_is_stmt"
2009         _op .byte 1 "line_base"
2010         _op .byte 1 "line_range"
2011         _op .byte 10 "opcode_base"
2012
2013         # The standard_opcode_lengths table.  The number of arguments
2014         # for each of the standard opcodes.  Generating 9 entries here
2015         # matches the use of 10 in the opcode_base above.  These 9
2016         # entries match the 9 standard opcodes for DWARF2, making use
2017         # of only 9 should be fine, even if we are generating DWARF3
2018         # or DWARF4.
2019         _op .byte 0 "standard opcode 1"
2020         _op .byte 1 "standard opcode 2"
2021         _op .byte 1 "standard opcode 3"
2022         _op .byte 1 "standard opcode 4"
2023         _op .byte 1 "standard opcode 5"
2024         _op .byte 0 "standard opcode 6"
2025         _op .byte 0 "standard opcode 7"
2026         _op .byte 0 "standard opcode 8"
2027         _op .byte 1 "standard opcode 9"
2028
2029         proc include_dir {dirname} {
2030             _op .ascii [_quote $dirname]
2031         }
2032
2033         proc file_name {filename diridx} {
2034             variable _line_saw_file
2035             if "! $_line_saw_file" {
2036                 # Terminate the dir list.
2037                 _op .byte 0 "Terminator."
2038                 set _line_saw_file 1
2039             }
2040
2041             _op .ascii [_quote $filename]
2042             _op .sleb128 $diridx
2043             _op .sleb128 0 "mtime"
2044             _op .sleb128 0 "length"
2045         }
2046
2047         proc program {statements} {
2048             variable _line_saw_program
2049             variable _line_header_end_label
2050             variable _line
2051
2052             set _line 1
2053
2054             if "! $_line_saw_program" {
2055                 # Terminate the file list.
2056                 _op .byte 0 "Terminator."
2057                 define_label $_line_header_end_label
2058                 set _line_saw_program 1
2059             }
2060
2061             proc DW_LNE_set_address {addr} {
2062                 _op .byte 0
2063                 set start [new_label "set_address_start"]
2064                 set end [new_label "set_address_end"]
2065                 _op .uleb128 "${end} - ${start}"
2066                 define_label ${start}
2067                 _op .byte 2
2068                 if {[is_64_target]} {
2069                     _op .8byte ${addr}
2070                 } else {
2071                     _op .4byte ${addr}
2072                 }
2073                 define_label ${end}
2074             }
2075
2076             proc DW_LNE_end_sequence {} {
2077                 variable _line
2078                 _op .byte 0
2079                 _op .uleb128 1
2080                 _op .byte 1
2081                 set _line 1
2082             }
2083
2084             proc DW_LNE_user { len opcode } {
2085                 set DW_LNE_lo_usr 0x80
2086                 set DW_LNE_hi_usr 0xff
2087                 if { $DW_LNE_lo_usr <= $opcode
2088                      && $opcode <= $DW_LNE_hi_usr } {
2089                     _op .byte 0
2090                     _op .uleb128 $len
2091                     _op .byte $opcode
2092                     for {set i 1} {$i < $len} {incr i} {
2093                         _op .byte 0
2094                     }
2095                 } else {
2096                     error "unknown vendor specific extended opcode: $opcode"
2097                 }
2098             }
2099
2100             proc DW_LNS_copy {} {
2101                 _op .byte 1
2102             }
2103
2104             proc DW_LNS_negate_stmt {} {
2105                 _op .byte 6
2106             }
2107
2108             proc DW_LNS_advance_pc {offset} {
2109                 _op .byte 2
2110                 _op .uleb128 ${offset}
2111             }
2112
2113             proc DW_LNS_advance_line {offset} {
2114                 variable _line
2115                 _op .byte 3
2116                 _op .sleb128 ${offset}
2117                 set _line [expr $_line + $offset]
2118             }
2119
2120             # A pseudo line number program instruction, that can be used instead
2121             # of DW_LNS_advance_line.  Rather than writing:
2122             #   {DW_LNS_advance_line [expr $line1 - 1]}
2123             #   {DW_LNS_advance_line [expr $line2 - $line1]}
2124             #   {DW_LNS_advance_line [expr $line3 - $line2]}
2125             # we can just write:
2126             #   {line $line1}
2127             #   {line $line2}
2128             #   {line $line3}
2129             proc line {line} {
2130                 variable _line
2131                 set offset [expr $line - $_line]
2132                 DW_LNS_advance_line $offset
2133             }
2134
2135             proc DW_LNS_set_file {num} {
2136                 _op .byte 4
2137                 _op .sleb128 ${num}
2138             }
2139
2140             foreach statement $statements {
2141                 uplevel 1 $statement
2142             }
2143         }
2144
2145         uplevel $body
2146
2147         rename include_dir ""
2148         rename file_name ""
2149
2150         # Terminate dir list if we saw no files.
2151         if "! $_line_saw_file" {
2152             _op .byte 0 "Terminator."
2153         }
2154
2155         # Terminate the file list.
2156         if "! $_line_saw_program" {
2157             _op .byte 0 "Terminator."
2158             define_label $_line_header_end_label
2159         }
2160
2161         define_label $unit_end_label
2162     }
2163
2164     proc _empty_array {name} {
2165         upvar $name the_array
2166
2167         catch {unset the_array}
2168         set the_array(_) {}
2169         unset the_array(_)
2170     }
2171
2172     # Emit a .gnu_debugaltlink section with the given file name and
2173     # build-id.  The buildid should be represented as a hexadecimal
2174     # string, like "ffeeddcc".
2175     proc gnu_debugaltlink {filename buildid} {
2176         _defer_output .gnu_debugaltlink {
2177             _op .ascii [_quote $filename]
2178             foreach {a b} [split $buildid {}] {
2179                 _op .byte 0x$a$b
2180             }
2181         }
2182     }
2183
2184     proc _note {type name hexdata} {
2185         set namelen [expr [string length $name] + 1]
2186
2187         # Name size.
2188         _op .4byte $namelen
2189         # Data size.
2190         _op .4byte [expr [string length $hexdata] / 2]
2191         # Type.
2192         _op .4byte $type
2193         # The name.
2194         _op .ascii [_quote $name]
2195         # Alignment.
2196         set align 2
2197         set total [expr {($namelen + (1 << $align) - 1) & -(1 << $align)}]
2198         for {set i $namelen} {$i < $total} {incr i} {
2199             _op .byte 0
2200         }
2201         # The data.
2202         foreach {a b} [split $hexdata {}] {
2203             _op .byte 0x$a$b
2204         }
2205     }
2206
2207     # Emit a note section holding the given build-id.
2208     proc build_id {buildid} {
2209         _defer_output {.note.gnu.build-id a note} {
2210             # From elf/common.h.
2211             set NT_GNU_BUILD_ID 3
2212
2213             _note $NT_GNU_BUILD_ID GNU $buildid
2214         }
2215     }
2216
2217     # The top-level interface to the DWARF assembler.
2218     # FILENAME is the name of the file where the generated assembly
2219     # code is written.
2220     # BODY is Tcl code to emit the assembly.  It is evaluated via
2221     # "eval" -- not uplevel as you might expect, because it is
2222     # important to run the body in the Dwarf namespace.
2223     #
2224     # A typical invocation is something like:
2225     #    Dwarf::assemble $file {
2226     #        cu 0 2 8 {
2227     #            compile_unit {
2228     #            ...
2229     #            }
2230     #        }
2231     #        cu 0 2 8 {
2232     #        ...
2233     #        }
2234     #    }
2235     proc assemble {filename body} {
2236         variable _initialized
2237         variable _output_file
2238         variable _deferred_output
2239         variable _defer
2240         variable _label_num
2241         variable _strings
2242         variable _cu_count
2243         variable _line_count
2244         variable _line_saw_file
2245         variable _line_saw_program
2246         variable _line_header_end_label
2247         variable _debug_ranges_64_bit
2248         variable _debug_addr_index
2249
2250         if {!$_initialized} {
2251             _read_constants
2252             set _initialized 1
2253         }
2254
2255         set _output_file [open $filename w]
2256         set _cu_count 0
2257         _empty_array _deferred_output
2258         set _defer ""
2259         set _label_num 0
2260         _empty_array _strings
2261
2262         set _line_count 0
2263         set _line_saw_file 0
2264         set _line_saw_program 0
2265         set _debug_ranges_64_bit [is_64_target]
2266
2267         set _debug_addr_index 0
2268
2269         # Not "uplevel" here, because we want to evaluate in this
2270         # namespace.  This is somewhat bad because it means we can't
2271         # readily refer to outer variables.
2272         eval $body
2273
2274         _write_deferred_output
2275
2276         catch {close $_output_file}
2277         set _output_file {}
2278     }
2279 }