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. 18proc 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. 35proc 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. 51proc 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). 103proc 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 227proc 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. 279proc 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 372namespace 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 DW_OP_fbreg { 1215 _get_args $line $opcode offset 1216 _op .sleb128 $argvec(offset) 1217 } 1218 1219 default { 1220 if {[llength $line] > 1} { 1221 error "Unimplemented: operands in location for $opcode" 1222 } 1223 } 1224 } 1225 } 1226 } 1227 1228 # Return a label that references the current position in the 1229 # .debug_addr table. When a user is creating split DWARF they 1230 # will define two CUs, the first will be the split DWARF content, 1231 # and the second will be the non-split stub CU. The split DWARF 1232 # CU fills in the .debug_addr section, but the non-split CU 1233 # includes a reference to the start of the section. The label 1234 # returned by this proc provides that reference. 1235 proc debug_addr_label {} { 1236 variable _debug_addr_index 1237 1238 set lbl [new_label "debug_addr_idx_${_debug_addr_index}_"] 1239 _defer_output .debug_addr { 1240 define_label $lbl 1241 } 1242 return $lbl 1243 } 1244 1245 # Emit a DWARF CU. 1246 # OPTIONS is a list with an even number of elements containing 1247 # option-name and option-value pairs. 1248 # Current options are: 1249 # is_64 0|1 - boolean indicating if you want to emit 64-bit DWARF 1250 # default = 0 (32-bit) 1251 # version n - DWARF version number to emit 1252 # default = 4 1253 # addr_size n - the size of addresses in bytes: 4, 8, or default 1254 # default = default 1255 # fission 0|1 - boolean indicating if generating Fission debug info 1256 # default = 0 1257 # BODY is Tcl code that emits the DIEs which make up the body of 1258 # the CU. It is evaluated in the caller's context. 1259 proc cu {options body} { 1260 variable _constants 1261 variable _cu_count 1262 variable _abbrev_section 1263 variable _abbrev_num 1264 variable _cu_label 1265 variable _cu_version 1266 variable _cu_addr_size 1267 variable _cu_offset_size 1268 variable _cu_is_fission 1269 1270 # Establish the defaults. 1271 set is_64 0 1272 set _cu_version 4 1273 set _cu_addr_size default 1274 set _cu_is_fission 0 1275 set section ".debug_info" 1276 set _abbrev_section ".debug_abbrev" 1277 1278 foreach { name value } $options { 1279 set value [uplevel 1 "subst \"$value\""] 1280 switch -exact -- $name { 1281 is_64 { set is_64 $value } 1282 version { set _cu_version $value } 1283 addr_size { set _cu_addr_size $value } 1284 fission { set _cu_is_fission $value } 1285 default { error "unknown option $name" } 1286 } 1287 } 1288 if {$_cu_addr_size == "default"} { 1289 if {[is_64_target]} { 1290 set _cu_addr_size 8 1291 } else { 1292 set _cu_addr_size 4 1293 } 1294 } 1295 set _cu_offset_size [expr { $is_64 ? 8 : 4 }] 1296 if { $_cu_is_fission } { 1297 set section ".debug_info.dwo" 1298 set _abbrev_section ".debug_abbrev.dwo" 1299 } 1300 1301 if {$_cu_version < 4} { 1302 set _constants(SPECIAL_expr) $_constants(DW_FORM_block) 1303 } else { 1304 set _constants(SPECIAL_expr) $_constants(DW_FORM_exprloc) 1305 } 1306 1307 _section $section 1308 1309 set cu_num [incr _cu_count] 1310 set my_abbrevs [_compute_label "abbrev${cu_num}_begin"] 1311 set _abbrev_num 1 1312 1313 set _cu_label [_compute_label "cu${cu_num}_begin"] 1314 set start_label [_compute_label "cu${cu_num}_start"] 1315 set end_label [_compute_label "cu${cu_num}_end"] 1316 1317 define_label $_cu_label 1318 if {$is_64} { 1319 _op .4byte 0xffffffff 1320 _op .8byte "$end_label - $start_label" 1321 } else { 1322 _op .4byte "$end_label - $start_label" 1323 } 1324 define_label $start_label 1325 _op .2byte $_cu_version Version 1326 1327 # The CU header for DWARF 4 and 5 are slightly different. 1328 if { $_cu_version == 5 } { 1329 _op .byte 0x1 "DW_UT_compile" 1330 _op .byte $_cu_addr_size "Pointer size" 1331 _op .${_cu_offset_size}byte $my_abbrevs Abbrevs 1332 } else { 1333 _op .${_cu_offset_size}byte $my_abbrevs Abbrevs 1334 _op .byte $_cu_addr_size "Pointer size" 1335 } 1336 1337 _defer_output $_abbrev_section { 1338 define_label $my_abbrevs 1339 } 1340 1341 uplevel $body 1342 1343 _defer_output $_abbrev_section { 1344 # Emit the terminator. 1345 _op .byte 0x0 "Abbrev end - Terminator" 1346 } 1347 1348 define_label $end_label 1349 } 1350 1351 # Emit a DWARF TU. 1352 # OPTIONS is a list with an even number of elements containing 1353 # option-name and option-value pairs. 1354 # Current options are: 1355 # is_64 0|1 - boolean indicating if you want to emit 64-bit DWARF 1356 # default = 0 (32-bit) 1357 # version n - DWARF version number to emit 1358 # default = 4 1359 # addr_size n - the size of addresses in bytes: 4, 8, or default 1360 # default = default 1361 # fission 0|1 - boolean indicating if generating Fission debug info 1362 # default = 0 1363 # SIGNATURE is the 64-bit signature of the type. 1364 # TYPE_LABEL is the label of the type defined by this TU, 1365 # or "" if there is no type (i.e., type stubs in Fission). 1366 # BODY is Tcl code that emits the DIEs which make up the body of 1367 # the TU. It is evaluated in the caller's context. 1368 proc tu {options signature type_label body} { 1369 variable _cu_count 1370 variable _abbrev_section 1371 variable _abbrev_num 1372 variable _cu_label 1373 variable _cu_version 1374 variable _cu_addr_size 1375 variable _cu_offset_size 1376 variable _cu_is_fission 1377 1378 # Establish the defaults. 1379 set is_64 0 1380 set _cu_version 4 1381 set _cu_addr_size default 1382 set _cu_is_fission 0 1383 set section ".debug_types" 1384 set _abbrev_section ".debug_abbrev" 1385 1386 foreach { name value } $options { 1387 switch -exact -- $name { 1388 is_64 { set is_64 $value } 1389 version { set _cu_version $value } 1390 addr_size { set _cu_addr_size $value } 1391 fission { set _cu_is_fission $value } 1392 default { error "unknown option $name" } 1393 } 1394 } 1395 if {$_cu_addr_size == "default"} { 1396 if {[is_64_target]} { 1397 set _cu_addr_size 8 1398 } else { 1399 set _cu_addr_size 4 1400 } 1401 } 1402 set _cu_offset_size [expr { $is_64 ? 8 : 4 }] 1403 if { $_cu_is_fission } { 1404 set section ".debug_types.dwo" 1405 set _abbrev_section ".debug_abbrev.dwo" 1406 } 1407 1408 _section $section 1409 1410 set cu_num [incr _cu_count] 1411 set my_abbrevs [_compute_label "abbrev${cu_num}_begin"] 1412 set _abbrev_num 1 1413 1414 set _cu_label [_compute_label "cu${cu_num}_begin"] 1415 set start_label [_compute_label "cu${cu_num}_start"] 1416 set end_label [_compute_label "cu${cu_num}_end"] 1417 1418 define_label $_cu_label 1419 if {$is_64} { 1420 _op .4byte 0xffffffff 1421 _op .8byte "$end_label - $start_label" 1422 } else { 1423 _op .4byte "$end_label - $start_label" 1424 } 1425 define_label $start_label 1426 _op .2byte $_cu_version Version 1427 _op .${_cu_offset_size}byte $my_abbrevs Abbrevs 1428 _op .byte $_cu_addr_size "Pointer size" 1429 _op .8byte $signature Signature 1430 if { $type_label != "" } { 1431 uplevel declare_labels $type_label 1432 upvar $type_label my_type_label 1433 if {$is_64} { 1434 _op .8byte "$my_type_label - $_cu_label" 1435 } else { 1436 _op .4byte "$my_type_label - $_cu_label" 1437 } 1438 } else { 1439 if {$is_64} { 1440 _op .8byte 0 1441 } else { 1442 _op .4byte 0 1443 } 1444 } 1445 1446 _defer_output $_abbrev_section { 1447 define_label $my_abbrevs 1448 } 1449 1450 uplevel $body 1451 1452 _defer_output $_abbrev_section { 1453 # Emit the terminator. 1454 _op .byte 0x0 "Abbrev end - Terminator" 1455 } 1456 1457 define_label $end_label 1458 } 1459 1460 # Emit a DWARF .debug_ranges unit. 1461 # OPTIONS is a list with an even number of elements containing 1462 # option-name and option-value pairs. 1463 # Current options are: 1464 # is_64 0|1 - boolean indicating if you want to emit 64-bit DWARF 1465 # default = 0 (32-bit) 1466 # 1467 # BODY is Tcl code that emits the content of the .debug_ranges 1468 # unit, it is evaluated in the caller's context. 1469 proc ranges {options body} { 1470 variable _debug_ranges_64_bit 1471 1472 foreach { name value } $options { 1473 switch -exact -- $name { 1474 is_64 { set _debug_ranges_64_bit [subst $value] } 1475 default { error "unknown option $name" } 1476 } 1477 } 1478 1479 set section ".debug_ranges" 1480 _section $section 1481 1482 proc sequence { body } { 1483 variable _debug_ranges_64_bit 1484 1485 # Emit the sequence of addresses. 1486 1487 proc base { addr } { 1488 variable _debug_ranges_64_bit 1489 1490 if { $_debug_ranges_64_bit } then { 1491 _op .8byte 0xffffffffffffffff "Base Marker" 1492 _op .8byte $addr "Base Address" 1493 } else { 1494 _op .4byte 0xffffffff "Base Marker" 1495 _op .4byte $addr "Base Address" 1496 } 1497 } 1498 1499 proc range { start end } { 1500 variable _debug_ranges_64_bit 1501 1502 if { $_debug_ranges_64_bit } then { 1503 _op .8byte $start "Start Address" 1504 _op .8byte $end "End Address" 1505 } else { 1506 _op .4byte $start "Start Address" 1507 _op .4byte $end "End Address" 1508 } 1509 } 1510 1511 uplevel $body 1512 1513 # End of the sequence. 1514 if { $_debug_ranges_64_bit } then { 1515 _op .8byte 0x0 "End of Sequence Marker (Part 1)" 1516 _op .8byte 0x0 "End of Sequence Marker (Part 2)" 1517 } else { 1518 _op .4byte 0x0 "End of Sequence Marker (Part 1)" 1519 _op .4byte 0x0 "End of Sequence Marker (Part 2)" 1520 } 1521 } 1522 1523 uplevel $body 1524 } 1525 1526 # Emit a DWARF .debug_rnglists section. 1527 # 1528 # The target address size is based on the current target's address size. 1529 # 1530 # There is one mandatory positional argument, BODY, which must be Tcl code 1531 # that emits the content of the section. It is evaluated in the caller's 1532 # context. 1533 # 1534 # The following option can be used: 1535 # 1536 # - -is-64 true|false: Whether to use 64-bit DWARF instead of 32-bit DWARF. 1537 # The default is 32-bit. 1538 1539 proc rnglists { args } { 1540 variable _debug_rnglists_addr_size 1541 variable _debug_rnglists_offset_size 1542 variable _debug_rnglists_is_64_dwarf 1543 1544 parse_args {{"is-64" "false"}} 1545 1546 if { [llength $args] != 1 } { 1547 error "rnglists proc expects one positional argument (body)" 1548 } 1549 1550 lassign $args body 1551 1552 if [is_64_target] { 1553 set _debug_rnglists_addr_size 8 1554 } else { 1555 set _debug_rnglists_addr_size 4 1556 } 1557 1558 if { ${is-64} } { 1559 set _debug_rnglists_offset_size 8 1560 set _debug_rnglists_is_64_dwarf true 1561 } else { 1562 set _debug_rnglists_offset_size 4 1563 set _debug_rnglists_is_64_dwarf false 1564 } 1565 1566 _section ".debug_rnglists" 1567 1568 # Count of tables in the section. 1569 variable _debug_rnglists_table_count 0 1570 1571 # Compute the label name for list at index LIST_IDX, for the current 1572 # table. 1573 1574 proc _compute_list_label { list_idx } { 1575 variable _debug_rnglists_table_count 1576 1577 return ".Lrnglists_table_${_debug_rnglists_table_count}_list_${list_idx}" 1578 } 1579 1580 # Generate one table (header + offset array + range lists). 1581 # 1582 # Accepts one positional argument, BODY. BODY may call the LIST_ 1583 # procedure to generate rnglists. 1584 # 1585 # The -post-header-label option can be used to define a label just after 1586 # the header of the table. This is the label that a DW_AT_rnglists_base 1587 # attribute will usually refer to. 1588 # 1589 # The `-with-offset-array true|false` option can be used to control 1590 # whether the headers of the location list tables have an array of 1591 # offset. The default is true. 1592 1593 proc table { args } { 1594 variable _debug_rnglists_table_count 1595 variable _debug_rnglists_addr_size 1596 variable _debug_rnglists_offset_size 1597 variable _debug_rnglists_is_64_dwarf 1598 1599 parse_args { 1600 {post-header-label ""} 1601 {with-offset-array true} 1602 } 1603 1604 if { [llength $args] != 1 } { 1605 error "table proc expects one positional argument (body)" 1606 } 1607 1608 lassign $args body 1609 1610 # Generate one range list. 1611 # 1612 # BODY may call the various procs defined below to generate list entries. 1613 # They correspond to the range list entry kinds described in section 2.17.3 1614 # of the DWARF 5 spec. 1615 # 1616 # To define a label pointing to the beginning of the list, use 1617 # the conventional way of declaring and defining labels: 1618 # 1619 # declare_labels the_list 1620 # 1621 # the_list: list_ { 1622 # ... 1623 # } 1624 1625 proc list_ { body } { 1626 variable _debug_rnglists_list_count 1627 1628 # Define a label for this list. It is used to build the offset 1629 # array later. 1630 set list_label [_compute_list_label $_debug_rnglists_list_count] 1631 define_label $list_label 1632 1633 # Emit a DW_RLE_start_end entry. 1634 1635 proc start_end { start end } { 1636 variable _debug_rnglists_addr_size 1637 1638 _op .byte 0x06 "DW_RLE_start_end" 1639 _op .${_debug_rnglists_addr_size}byte $start "start" 1640 _op .${_debug_rnglists_addr_size}byte $end "end" 1641 } 1642 1643 uplevel $body 1644 1645 # Emit end of list. 1646 _op .byte 0x00 "DW_RLE_end_of_list" 1647 1648 incr _debug_rnglists_list_count 1649 } 1650 1651 # Count of lists in the table. 1652 variable _debug_rnglists_list_count 0 1653 1654 # Generate the lists ops first, because we need to know how many 1655 # lists there are to generate the header and offset table. 1656 set lists_ops [_defer_to_string { 1657 uplevel $body 1658 }] 1659 1660 set post_unit_len_label \ 1661 [_compute_label "rnglists_table_${_debug_rnglists_table_count}_post_unit_len"] 1662 set post_header_label \ 1663 [_compute_label "rnglists_table_${_debug_rnglists_table_count}_post_header"] 1664 set table_end_label \ 1665 [_compute_label "rnglists_table_${_debug_rnglists_table_count}_end"] 1666 1667 # Emit the table header. 1668 if { $_debug_rnglists_is_64_dwarf } { 1669 _op .4byte 0xffffffff "unit length 1/2" 1670 _op .8byte "$table_end_label - $post_unit_len_label" "unit length 2/2" 1671 } else { 1672 _op .4byte "$table_end_label - $post_unit_len_label" "unit length" 1673 } 1674 1675 define_label $post_unit_len_label 1676 1677 _op .2byte 5 "dwarf version" 1678 _op .byte $_debug_rnglists_addr_size "address size" 1679 _op .byte 0 "segment selector size" 1680 1681 if { ${with-offset-array} } { 1682 _op .4byte "$_debug_rnglists_list_count" "offset entry count" 1683 } else { 1684 _op .4byte 0 "offset entry count" 1685 } 1686 1687 define_label $post_header_label 1688 1689 # Define the user post-header label, if provided. 1690 if { ${post-header-label} != "" } { 1691 define_label ${post-header-label} 1692 } 1693 1694 # Emit the offset array. 1695 if { ${with-offset-array} } { 1696 for {set list_idx 0} {$list_idx < $_debug_rnglists_list_count} {incr list_idx} { 1697 set list_label [_compute_list_label $list_idx] 1698 _op .${_debug_rnglists_offset_size}byte "$list_label - $post_header_label" "offset of list $list_idx" 1699 } 1700 } 1701 1702 # Emit the actual list data. 1703 _emit "$lists_ops" 1704 1705 define_label $table_end_label 1706 1707 incr _debug_rnglists_table_count 1708 } 1709 1710 uplevel $body 1711 } 1712 1713 # Emit a DWARF .debug_loclists section. 1714 # 1715 # The target address size is based on the current target's address size. 1716 # 1717 # There is one mandatory positional argument, BODY, which must be Tcl code 1718 # that emits the content of the section. It is evaluated in the caller's 1719 # context. 1720 # 1721 # The following option can be used: 1722 # 1723 # - -is-64 true|false: Whether to use 64-bit DWARF instead of 32-bit DWARF. 1724 # The default is 32-bit. 1725 1726 proc loclists { args } { 1727 variable _debug_loclists_addr_size 1728 variable _debug_loclists_offset_size 1729 variable _debug_loclists_is_64_dwarf 1730 1731 parse_args {{"is-64" "false"}} 1732 1733 if { [llength $args] != 1 } { 1734 error "loclists proc expects one positional argument (body)" 1735 } 1736 1737 lassign $args body 1738 1739 if [is_64_target] { 1740 set _debug_loclists_addr_size 8 1741 } else { 1742 set _debug_loclists_addr_size 4 1743 } 1744 1745 if { ${is-64} } { 1746 set _debug_loclists_offset_size 8 1747 set _debug_loclists_is_64_dwarf true 1748 } else { 1749 set _debug_loclists_offset_size 4 1750 set _debug_loclists_is_64_dwarf false 1751 } 1752 1753 _section ".debug_loclists" 1754 1755 # Count of tables in the section. 1756 variable _debug_loclists_table_count 0 1757 1758 # Compute the label name for list at index LIST_IDX, for the current 1759 # table. 1760 1761 proc _compute_list_label { list_idx } { 1762 variable _debug_loclists_table_count 1763 1764 return ".Lloclists_table_${_debug_loclists_table_count}_list_${list_idx}" 1765 } 1766 1767 # Generate one table (header + offset array + location lists). 1768 # 1769 # Accepts one position argument, BODY. BODY may call the LIST_ 1770 # procedure to generate loclists. 1771 # 1772 # The -post-header-label option can be used to define a label just after the 1773 # header of the table. This is the label that a DW_AT_loclists_base 1774 # attribute will usually refer to. 1775 # 1776 # The `-with-offset-array true|false` option can be used to control 1777 # whether the headers of the location list tables have an array of 1778 # offset. The default is true. 1779 1780 proc table { args } { 1781 variable _debug_loclists_table_count 1782 variable _debug_loclists_addr_size 1783 variable _debug_loclists_offset_size 1784 variable _debug_loclists_is_64_dwarf 1785 1786 parse_args { 1787 {post-header-label ""} 1788 {with-offset-array true} 1789 } 1790 1791 if { [llength $args] != 1 } { 1792 error "table proc expects one positional argument (body)" 1793 } 1794 1795 lassign $args body 1796 1797 # Generate one location list. 1798 # 1799 # BODY may call the various procs defined below to generate list 1800 # entries. They correspond to the location list entry kinds 1801 # described in section 2.6.2 of the DWARF 5 spec. 1802 # 1803 # To define a label pointing to the beginning of the list, use 1804 # the conventional way of declaring and defining labels: 1805 # 1806 # declare_labels the_list 1807 # 1808 # the_list: list_ { 1809 # ... 1810 # } 1811 1812 proc list_ { body } { 1813 variable _debug_loclists_list_count 1814 1815 # Count the location descriptions in this list. 1816 variable _debug_loclists_locdesc_count 0 1817 1818 # Define a label for this list. It is used to build the offset 1819 # array later. 1820 set list_label [_compute_list_label $_debug_loclists_list_count] 1821 define_label $list_label 1822 1823 # Emit a DW_LLE_start_length entry. 1824 1825 proc start_length { start length locdesc } { 1826 variable _debug_loclists_is_64_dwarf 1827 variable _debug_loclists_addr_size 1828 variable _debug_loclists_offset_size 1829 variable _debug_loclists_table_count 1830 variable _debug_loclists_list_count 1831 variable _debug_loclists_locdesc_count 1832 1833 _op .byte 0x08 "DW_LLE_start_length" 1834 1835 # Start and end of the address range. 1836 _op .${_debug_loclists_addr_size}byte $start "start" 1837 _op .uleb128 $length "length" 1838 1839 # Length of location description. 1840 set locdesc_start_label ".Lloclists_table_${_debug_loclists_table_count}_list_${_debug_loclists_list_count}_locdesc_${_debug_loclists_locdesc_count}_start" 1841 set locdesc_end_label ".Lloclists_table_${_debug_loclists_table_count}_list_${_debug_loclists_list_count}_locdesc_${_debug_loclists_locdesc_count}_end" 1842 _op .uleb128 "$locdesc_end_label - $locdesc_start_label" "locdesc length" 1843 1844 define_label $locdesc_start_label 1845 set dwarf_version 5 1846 _location $locdesc $dwarf_version $_debug_loclists_addr_size $_debug_loclists_offset_size 1847 define_label $locdesc_end_label 1848 1849 incr _debug_loclists_locdesc_count 1850 } 1851 1852 # Emit a DW_LLE_start_end entry. 1853 1854 proc start_end { start end locdesc } { 1855 variable _debug_loclists_is_64_dwarf 1856 variable _debug_loclists_addr_size 1857 variable _debug_loclists_offset_size 1858 variable _debug_loclists_table_count 1859 variable _debug_loclists_list_count 1860 variable _debug_loclists_locdesc_count 1861 1862 _op .byte 0x07 "DW_LLE_start_end" 1863 1864 # Start and end of the address range. 1865 _op .${_debug_loclists_addr_size}byte $start "start" 1866 _op .${_debug_loclists_addr_size}byte $end "end" 1867 1868 # Length of location description. 1869 set locdesc_start_label ".Lloclists_table_${_debug_loclists_table_count}_list_${_debug_loclists_list_count}_locdesc_${_debug_loclists_locdesc_count}_start" 1870 set locdesc_end_label ".Lloclists_table_${_debug_loclists_table_count}_list_${_debug_loclists_list_count}_locdesc_${_debug_loclists_locdesc_count}_end" 1871 _op .uleb128 "$locdesc_end_label - $locdesc_start_label" "locdesc length" 1872 1873 define_label $locdesc_start_label 1874 set dwarf_version 5 1875 _location $locdesc $dwarf_version $_debug_loclists_addr_size $_debug_loclists_offset_size 1876 define_label $locdesc_end_label 1877 1878 incr _debug_loclists_locdesc_count 1879 } 1880 1881 uplevel $body 1882 1883 # Emit end of list. 1884 _op .byte 0x00 "DW_LLE_end_of_list" 1885 1886 incr _debug_loclists_list_count 1887 } 1888 1889 # Count of lists in the table. 1890 variable _debug_loclists_list_count 0 1891 1892 # Generate the lists ops first, because we need to know how many 1893 # lists there are to generate the header and offset table. 1894 set lists_ops [_defer_to_string { 1895 uplevel $body 1896 }] 1897 1898 set post_unit_len_label \ 1899 [_compute_label "loclists_table_${_debug_loclists_table_count}_post_unit_len"] 1900 set post_header_label \ 1901 [_compute_label "loclists_table_${_debug_loclists_table_count}_post_header"] 1902 set table_end_label \ 1903 [_compute_label "loclists_table_${_debug_loclists_table_count}_end"] 1904 1905 # Emit the table header. 1906 if { $_debug_loclists_is_64_dwarf } { 1907 _op .4byte 0xffffffff "unit length 1/2" 1908 _op .8byte "$table_end_label - $post_unit_len_label" "unit length 2/2" 1909 } else { 1910 _op .4byte "$table_end_label - $post_unit_len_label" "unit length" 1911 } 1912 1913 define_label $post_unit_len_label 1914 1915 _op .2byte 5 "DWARF version" 1916 _op .byte $_debug_loclists_addr_size "address size" 1917 _op .byte 0 "segment selector size" 1918 1919 if { ${with-offset-array} } { 1920 _op .4byte "$_debug_loclists_list_count" "offset entry count" 1921 } else { 1922 _op .4byte 0 "offset entry count" 1923 } 1924 1925 define_label $post_header_label 1926 1927 # Define the user post-header label, if provided. 1928 if { ${post-header-label} != "" } { 1929 define_label ${post-header-label} 1930 } 1931 1932 # Emit the offset array. 1933 if { ${with-offset-array} } { 1934 for {set list_idx 0} {$list_idx < $_debug_loclists_list_count} {incr list_idx} { 1935 set list_label [_compute_list_label $list_idx] 1936 _op .${_debug_loclists_offset_size}byte "$list_label - $post_header_label" "offset of list $list_idx" 1937 } 1938 } 1939 1940 # Emit the actual list data. 1941 _emit "$lists_ops" 1942 1943 define_label $table_end_label 1944 1945 incr _debug_loclists_table_count 1946 } 1947 1948 uplevel $body 1949 } 1950 1951 # Emit a DWARF .debug_line unit. 1952 # OPTIONS is a list with an even number of elements containing 1953 # option-name and option-value pairs. 1954 # Current options are: 1955 # is_64 0|1 - boolean indicating if you want to emit 64-bit DWARF 1956 # default = 0 (32-bit) 1957 # version n - DWARF version number to emit 1958 # default = 4 1959 # addr_size n - the size of addresses in bytes: 4, 8, or default 1960 # default = default 1961 # 1962 # LABEL is the label of the current unit (which is probably 1963 # referenced by a DW_AT_stmt_list), or "" if there is no such 1964 # label. 1965 # 1966 # BODY is Tcl code that emits the parts which make up the body of 1967 # the line unit. It is evaluated in the caller's context. The 1968 # following commands are available for the BODY section: 1969 # 1970 # include_dir "dirname" -- adds a new include directory 1971 # 1972 # file_name "file.c" idx -- adds a new file name. IDX is a 1973 # 1-based index referencing an include directory or 0 for 1974 # current directory. 1975 1976 proc lines {options label body} { 1977 variable _line_count 1978 variable _line_saw_file 1979 variable _line_saw_program 1980 variable _line_header_end_label 1981 1982 # Establish the defaults. 1983 set is_64 0 1984 set _unit_version 4 1985 set _unit_addr_size default 1986 set _line_saw_program 0 1987 set _line_saw_file 0 1988 set _default_is_stmt 1 1989 1990 foreach { name value } $options { 1991 switch -exact -- $name { 1992 is_64 { set is_64 $value } 1993 version { set _unit_version $value } 1994 addr_size { set _unit_addr_size $value } 1995 default_is_stmt { set _default_is_stmt $value } 1996 default { error "unknown option $name" } 1997 } 1998 } 1999 if {$_unit_addr_size == "default"} { 2000 if {[is_64_target]} { 2001 set _unit_addr_size 8 2002 } else { 2003 set _unit_addr_size 4 2004 } 2005 } 2006 2007 set unit_num [incr _line_count] 2008 2009 set section ".debug_line" 2010 _section $section 2011 2012 if { "$label" != "" } { 2013 # Define the user-provided label at this point. 2014 $label: 2015 } 2016 2017 set unit_len_label [_compute_label "line${_line_count}_start"] 2018 set unit_end_label [_compute_label "line${_line_count}_end"] 2019 set header_len_label [_compute_label "line${_line_count}_header_start"] 2020 set _line_header_end_label [_compute_label "line${_line_count}_header_end"] 2021 2022 if {$is_64} { 2023 _op .4byte 0xffffffff 2024 _op .8byte "$unit_end_label - $unit_len_label" "unit_length" 2025 } else { 2026 _op .4byte "$unit_end_label - $unit_len_label" "unit_length" 2027 } 2028 2029 define_label $unit_len_label 2030 2031 _op .2byte $_unit_version version 2032 2033 if {$is_64} { 2034 _op .8byte "$_line_header_end_label - $header_len_label" "header_length" 2035 } else { 2036 _op .4byte "$_line_header_end_label - $header_len_label" "header_length" 2037 } 2038 2039 define_label $header_len_label 2040 2041 _op .byte 1 "minimum_instruction_length" 2042 _op .byte $_default_is_stmt "default_is_stmt" 2043 _op .byte 1 "line_base" 2044 _op .byte 1 "line_range" 2045 _op .byte 10 "opcode_base" 2046 2047 # The standard_opcode_lengths table. The number of arguments 2048 # for each of the standard opcodes. Generating 9 entries here 2049 # matches the use of 10 in the opcode_base above. These 9 2050 # entries match the 9 standard opcodes for DWARF2, making use 2051 # of only 9 should be fine, even if we are generating DWARF3 2052 # or DWARF4. 2053 _op .byte 0 "standard opcode 1" 2054 _op .byte 1 "standard opcode 2" 2055 _op .byte 1 "standard opcode 3" 2056 _op .byte 1 "standard opcode 4" 2057 _op .byte 1 "standard opcode 5" 2058 _op .byte 0 "standard opcode 6" 2059 _op .byte 0 "standard opcode 7" 2060 _op .byte 0 "standard opcode 8" 2061 _op .byte 1 "standard opcode 9" 2062 2063 proc include_dir {dirname} { 2064 _op .ascii [_quote $dirname] 2065 } 2066 2067 proc file_name {filename diridx} { 2068 variable _line_saw_file 2069 if "! $_line_saw_file" { 2070 # Terminate the dir list. 2071 _op .byte 0 "Terminator." 2072 set _line_saw_file 1 2073 } 2074 2075 _op .ascii [_quote $filename] 2076 _op .sleb128 $diridx 2077 _op .sleb128 0 "mtime" 2078 _op .sleb128 0 "length" 2079 } 2080 2081 proc program {statements} { 2082 variable _line_saw_program 2083 variable _line_header_end_label 2084 variable _line 2085 2086 set _line 1 2087 2088 if "! $_line_saw_program" { 2089 # Terminate the file list. 2090 _op .byte 0 "Terminator." 2091 define_label $_line_header_end_label 2092 set _line_saw_program 1 2093 } 2094 2095 proc DW_LNE_set_address {addr} { 2096 _op .byte 0 2097 set start [new_label "set_address_start"] 2098 set end [new_label "set_address_end"] 2099 _op .uleb128 "${end} - ${start}" 2100 define_label ${start} 2101 _op .byte 2 2102 if {[is_64_target]} { 2103 _op .8byte ${addr} 2104 } else { 2105 _op .4byte ${addr} 2106 } 2107 define_label ${end} 2108 } 2109 2110 proc DW_LNE_end_sequence {} { 2111 variable _line 2112 _op .byte 0 2113 _op .uleb128 1 2114 _op .byte 1 2115 set _line 1 2116 } 2117 2118 proc DW_LNE_user { len opcode } { 2119 set DW_LNE_lo_usr 0x80 2120 set DW_LNE_hi_usr 0xff 2121 if { $DW_LNE_lo_usr <= $opcode 2122 && $opcode <= $DW_LNE_hi_usr } { 2123 _op .byte 0 2124 _op .uleb128 $len 2125 _op .byte $opcode 2126 for {set i 1} {$i < $len} {incr i} { 2127 _op .byte 0 2128 } 2129 } else { 2130 error "unknown vendor specific extended opcode: $opcode" 2131 } 2132 } 2133 2134 proc DW_LNS_copy {} { 2135 _op .byte 1 2136 } 2137 2138 proc DW_LNS_negate_stmt {} { 2139 _op .byte 6 2140 } 2141 2142 proc DW_LNS_advance_pc {offset} { 2143 _op .byte 2 2144 _op .uleb128 ${offset} 2145 } 2146 2147 proc DW_LNS_advance_line {offset} { 2148 variable _line 2149 _op .byte 3 2150 _op .sleb128 ${offset} 2151 set _line [expr $_line + $offset] 2152 } 2153 2154 # A pseudo line number program instruction, that can be used instead 2155 # of DW_LNS_advance_line. Rather than writing: 2156 # {DW_LNS_advance_line [expr $line1 - 1]} 2157 # {DW_LNS_advance_line [expr $line2 - $line1]} 2158 # {DW_LNS_advance_line [expr $line3 - $line2]} 2159 # we can just write: 2160 # {line $line1} 2161 # {line $line2} 2162 # {line $line3} 2163 proc line {line} { 2164 variable _line 2165 set offset [expr $line - $_line] 2166 DW_LNS_advance_line $offset 2167 } 2168 2169 proc DW_LNS_set_file {num} { 2170 _op .byte 4 2171 _op .sleb128 ${num} 2172 } 2173 2174 foreach statement $statements { 2175 uplevel 1 $statement 2176 } 2177 } 2178 2179 uplevel $body 2180 2181 rename include_dir "" 2182 rename file_name "" 2183 2184 # Terminate dir list if we saw no files. 2185 if "! $_line_saw_file" { 2186 _op .byte 0 "Terminator." 2187 } 2188 2189 # Terminate the file list. 2190 if "! $_line_saw_program" { 2191 _op .byte 0 "Terminator." 2192 define_label $_line_header_end_label 2193 } 2194 2195 define_label $unit_end_label 2196 } 2197 2198 proc _empty_array {name} { 2199 upvar $name the_array 2200 2201 catch {unset the_array} 2202 set the_array(_) {} 2203 unset the_array(_) 2204 } 2205 2206 # Emit a .gnu_debugaltlink section with the given file name and 2207 # build-id. The buildid should be represented as a hexadecimal 2208 # string, like "ffeeddcc". 2209 proc gnu_debugaltlink {filename buildid} { 2210 _defer_output .gnu_debugaltlink { 2211 _op .ascii [_quote $filename] 2212 foreach {a b} [split $buildid {}] { 2213 _op .byte 0x$a$b 2214 } 2215 } 2216 } 2217 2218 proc _note {type name hexdata} { 2219 set namelen [expr [string length $name] + 1] 2220 2221 # Name size. 2222 _op .4byte $namelen 2223 # Data size. 2224 _op .4byte [expr [string length $hexdata] / 2] 2225 # Type. 2226 _op .4byte $type 2227 # The name. 2228 _op .ascii [_quote $name] 2229 # Alignment. 2230 set align 2 2231 set total [expr {($namelen + (1 << $align) - 1) & -(1 << $align)}] 2232 for {set i $namelen} {$i < $total} {incr i} { 2233 _op .byte 0 2234 } 2235 # The data. 2236 foreach {a b} [split $hexdata {}] { 2237 _op .byte 0x$a$b 2238 } 2239 } 2240 2241 # Emit a note section holding the given build-id. 2242 proc build_id {buildid} { 2243 _defer_output {.note.gnu.build-id a note} { 2244 # From elf/common.h. 2245 set NT_GNU_BUILD_ID 3 2246 2247 _note $NT_GNU_BUILD_ID GNU $buildid 2248 } 2249 } 2250 2251 # The top-level interface to the DWARF assembler. 2252 # FILENAME is the name of the file where the generated assembly 2253 # code is written. 2254 # BODY is Tcl code to emit the assembly. It is evaluated via 2255 # "eval" -- not uplevel as you might expect, because it is 2256 # important to run the body in the Dwarf namespace. 2257 # 2258 # A typical invocation is something like: 2259 # Dwarf::assemble $file { 2260 # cu 0 2 8 { 2261 # compile_unit { 2262 # ... 2263 # } 2264 # } 2265 # cu 0 2 8 { 2266 # ... 2267 # } 2268 # } 2269 proc assemble {filename body} { 2270 variable _initialized 2271 variable _output_file 2272 variable _deferred_output 2273 variable _defer 2274 variable _label_num 2275 variable _strings 2276 variable _cu_count 2277 variable _line_count 2278 variable _line_saw_file 2279 variable _line_saw_program 2280 variable _line_header_end_label 2281 variable _debug_ranges_64_bit 2282 variable _debug_addr_index 2283 2284 if {!$_initialized} { 2285 _read_constants 2286 set _initialized 1 2287 } 2288 2289 set _output_file [open $filename w] 2290 set _cu_count 0 2291 _empty_array _deferred_output 2292 set _defer "" 2293 set _label_num 0 2294 _empty_array _strings 2295 2296 set _line_count 0 2297 set _line_saw_file 0 2298 set _line_saw_program 0 2299 set _debug_ranges_64_bit [is_64_target] 2300 2301 set _debug_addr_index 0 2302 2303 # Not "uplevel" here, because we want to evaluate in this 2304 # namespace. This is somewhat bad because it means we can't 2305 # readily refer to outer variables. 2306 eval $body 2307 2308 _write_deferred_output 2309 2310 catch {close $_output_file} 2311 set _output_file {} 2312 } 2313} 2314