1# Copyright 2010-2020 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# This was copied from the git://sourceware.org/git/binutils-gdb.git 17# repository, file gdb/testsuite/lib/dwarf.exp 18 19# Return true if the target supports DWARF-2 and uses gas. 20# For now pick a sampling of likely targets. 21proc dwarf2_support {} { 22 if {[istarget *-*-linux*] 23 || [istarget *-*-gnu*] 24 || [istarget *-*-elf*] 25 || [istarget *-*-openbsd*] 26 || [istarget arm*-*-eabi*] 27 || [istarget arm*-*-symbianelf*] 28 || [istarget powerpc-*-eabi*]} { 29 return 1 30 } 31 32 return 0 33} 34 35# Build an executable from a fission-based .S file. 36# This handles the extra work of splitting the .o into non-dwo and dwo 37# pieces, making sure the .dwo is available if we're using cc-with-tweaks.sh 38# to build a .dwp file. 39# The arguments and results are the same as for build_executable. 40# 41# Current restrictions: 42# - only supports one source file 43# - cannot be run on remote hosts 44 45proc build_executable_from_fission_assembler { testname executable sources options } { 46 verbose -log "build_executable_from_fission_assembler $testname $executable $sources $options" 47 if { [llength $sources] != 1 } { 48 error "Only one source file supported." 49 } 50 if [is_remote host] { 51 error "Remote hosts are not supported." 52 } 53 54 global srcdir subdir 55 set source_file ${srcdir}/${subdir}/${sources} 56 set root_name [file rootname [file tail $source_file]] 57 set output_base [standard_output_file $root_name] 58 set object_file ${output_base}.o 59 set dwo_file ${output_base}.dwo 60 set object_options "object $options" 61 set objcopy [gdb_find_objcopy] 62 63 set result [gdb_compile $source_file $object_file object $options] 64 if { "$result" != "" } { 65 return -1 66 } 67 68 set command "$objcopy --extract-dwo $object_file $dwo_file" 69 verbose -log "Executing $command" 70 set result [catch "exec $command" output] 71 verbose -log "objcopy --extract-dwo output: $output" 72 if { $result == 1 } { 73 return -1 74 } 75 76 set command "$objcopy --strip-dwo $object_file" 77 verbose -log "Executing $command" 78 set result [catch "exec $command" output] 79 verbose -log "objcopy --strip-dwo output: $output" 80 if { $result == 1 } { 81 return -1 82 } 83 84 set result [gdb_compile $object_file $executable executable $options] 85 if { "$result" != "" } { 86 return -1 87 } 88 89 return 0 90} 91 92# Return a list of expressions about function FUNC's address and length. 93# The first expression is the address of function FUNC, and the second 94# one is FUNC's length. SRC is the source file having function FUNC. 95# An internal label ${func}_label must be defined inside FUNC: 96# 97# int main (void) 98# { 99# asm ("main_label: .globl main_label"); 100# return 0; 101# } 102# 103# This label is needed to compute the start address of function FUNC. 104# If the compiler is gcc, we can do the following to get function start 105# and end address too: 106# 107# asm ("func_start: .globl func_start"); 108# static void func (void) {} 109# asm ("func_end: .globl func_end"); 110# 111# however, this isn't portable, because other compilers, such as clang, 112# may not guarantee the order of global asms and function. The code 113# becomes: 114# 115# asm ("func_start: .globl func_start"); 116# asm ("func_end: .globl func_end"); 117# static void func (void) {} 118# 119 120proc function_range { func src {options {debug}} } { 121 global decimal gdb_prompt 122 123 set exe [standard_temp_file func_addr[pid].x] 124 125 gdb_compile $src $exe executable $options 126 127 gdb_exit 128 gdb_start 129 gdb_load "$exe" 130 131 # Compute the label offset, and we can get the function start address 132 # by "${func}_label - $func_label_offset". 133 set func_label_offset "" 134 set test "p ${func}_label - ${func}" 135 gdb_test_multiple $test $test { 136 -re ".* = ($decimal)\r\n$gdb_prompt $" { 137 set func_label_offset $expect_out(1,string) 138 } 139 } 140 141 # Compute the function length. 142 global hex 143 set func_length "" 144 set test "disassemble $func" 145 gdb_test_multiple $test $test { 146 -re ".*$hex <\\+($decimal)>:\[^\r\n\]+\r\nEnd of assembler dump\.\r\n$gdb_prompt $" { 147 set func_length $expect_out(1,string) 148 } 149 } 150 151 # Compute the size of the last instruction. 152 if { $func_length == 0 } then { 153 set func_pattern "$func" 154 } else { 155 set func_pattern "$func\\+$func_length" 156 } 157 set test "x/2i $func+$func_length" 158 gdb_test_multiple $test $test { 159 -re ".*($hex) <$func_pattern>:\[^\r\n\]+\r\n\[ \]+($hex).*\.\r\n$gdb_prompt $" { 160 set start $expect_out(1,string) 161 set end $expect_out(2,string) 162 163 set func_length [expr $func_length + $end - $start] 164 } 165 } 166 167 return [list "${func}_label - $func_label_offset" $func_length] 168} 169 170# Extract the start, length, and end for function called NAME and 171# create suitable variables in the callers scope. 172proc get_func_info { name {options {debug}} } { 173 global srcdir subdir srcfile 174 175 upvar 1 "${name}_start" func_start 176 upvar 1 "${name}_len" func_len 177 upvar 1 "${name}_end" func_end 178 179 lassign [function_range ${name} \ 180 [list ${srcdir}/${subdir}/$srcfile] \ 181 ${options}] \ 182 func_start func_len 183 set func_end "$func_start + $func_len" 184} 185 186# A DWARF assembler. 187# 188# All the variables in this namespace are private to the 189# implementation. Also, any procedure whose name starts with "_" is 190# private as well. Do not use these. 191# 192# Exported functions are documented at their definition. 193# 194# In addition to the hand-written functions documented below, this 195# module automatically generates a function for each DWARF tag. For 196# most tags, two forms are made: a full name, and one with the 197# "DW_TAG_" prefix stripped. For example, you can use either 198# 'DW_TAG_compile_unit' or 'compile_unit' interchangeably. 199# 200# There are two exceptions to this rule: DW_TAG_variable and 201# DW_TAG_namespace. For these, the full name must always be used, 202# as the short name conflicts with Tcl builtins. (Should future 203# versions of Tcl or DWARF add more conflicts, this list will grow. 204# If you want to be safe you should always use the full names.) 205# 206# Each tag procedure is defined like: 207# 208# proc DW_TAG_mumble {{attrs {}} {children {}}} { ... } 209# 210# ATTRS is an optional list of attributes. 211# It is run through 'subst' in the caller's context before processing. 212# 213# Each attribute in the list has one of two forms: 214# 1. { NAME VALUE } 215# 2. { NAME VALUE FORM } 216# 217# In each case, NAME is the attribute's name. 218# This can either be the full name, like 'DW_AT_name', or a shortened 219# name, like 'name'. These are fully equivalent. 220# 221# Besides DWARF standard attributes, assembler supports 'macro' attribute 222# which will be substituted by one or more standard or macro attributes. 223# supported macro attributes are: 224# 225# - MACRO_AT_range { FUNC } 226# It is substituted by DW_AT_low_pc and DW_AT_high_pc with the start and 227# end address of function FUNC in file $srcdir/$subdir/$srcfile. 228# 229# - MACRO_AT_func { FUNC } 230# It is substituted by DW_AT_name with FUNC and MACRO_AT_range. 231# 232# If FORM is given, it should name a DW_FORM_ constant. 233# This can either be the short form, like 'DW_FORM_addr', or a 234# shortened version, like 'addr'. If the form is given, VALUE 235# is its value; see below. In some cases, additional processing 236# is done; for example, DW_FORM_strp manages the .debug_str 237# section automatically. 238# 239# If FORM is 'SPECIAL_expr', then VALUE is treated as a location 240# expression. The effective form is then DW_FORM_block or DW_FORM_exprloc 241# for DWARF version >= 4, and VALUE is passed to the (internal) 242# '_location' proc to be translated. 243# This proc implements a miniature DW_OP_ assembler. 244# 245# If FORM is not given, it is guessed: 246# * If VALUE starts with the "@" character, the rest of VALUE is 247# looked up as a DWARF constant, and DW_FORM_sdata is used. For 248# example, '@DW_LANG_c89' could be used. 249# * If VALUE starts with the ":" character, then it is a label 250# reference. The rest of VALUE is taken to be the name of a label, 251# and DW_FORM_ref4 is used. See 'new_label' and 'define_label'. 252# * If VALUE starts with the "%" character, then it is a label 253# reference too, but DW_FORM_ref_addr is used. 254# * Otherwise, if the attribute name has a default form (f.i. DW_FORM_addr for 255# DW_AT_low_pc), then that one is used. 256# * Otherwise, an error is reported. Either specify a form explicitly, or 257# add a default for the the attribute name in _default_form. 258# 259# CHILDREN is just Tcl code that can be used to define child DIEs. It 260# is evaluated in the caller's context. 261# 262# Currently this code is missing nice support for CFA handling, and 263# probably other things as well. 264 265namespace eval Dwarf { 266 # True if the module has been initialized. 267 variable _initialized 0 268 269 # Constants from dwarf2.h. 270 variable _constants 271 # DW_AT short names. 272 variable _AT 273 # DW_FORM short names. 274 variable _FORM 275 # DW_OP short names. 276 variable _OP 277 278 # The current output file. 279 variable _output_file 280 281 # Note: The _cu_ values here also apply to type units (TUs). 282 # Think of a TU as a special kind of CU. 283 284 # Current CU count. 285 variable _cu_count 286 287 # The current CU's base label. 288 variable _cu_label 289 290 # The current CU's version. 291 variable _cu_version 292 293 # The current CU's address size. 294 variable _cu_addr_size 295 # The current CU's offset size. 296 variable _cu_offset_size 297 298 # Label generation number. 299 variable _label_num 300 301 # The deferred output array. The index is the section name; the 302 # contents hold the data for that section. 303 variable _deferred_output 304 305 # If empty, we should write directly to the output file. 306 # Otherwise, this is the name of a section to write to. 307 variable _defer 308 309 # The abbrev section. Typically .debug_abbrev but can be .debug_abbrev.dwo 310 # for Fission. 311 variable _abbrev_section 312 313 # The next available abbrev number in the current CU's abbrev 314 # table. 315 variable _abbrev_num 316 317 # The string table for this assembly. The key is the string; the 318 # value is the label for that string. 319 variable _strings 320 321 # Current .debug_line unit count. 322 variable _line_count 323 324 # Whether a file_name entry was seen. 325 variable _line_saw_file 326 327 # Whether a line table program has been seen. 328 variable _line_saw_program 329 330 # A Label for line table header generation. 331 variable _line_header_end_label 332 333 # The address size for debug ranges section. 334 variable _debug_ranges_64_bit 335 336 proc _process_one_constant {name value} { 337 variable _constants 338 variable _AT 339 variable _FORM 340 variable _OP 341 342 set _constants($name) $value 343 344 if {![regexp "^DW_(\[A-Z\]+)_(\[A-Za-z0-9_\]+)$" $name \ 345 ignore prefix name2]} { 346 error "non-matching name: $name" 347 } 348 349 if {$name2 == "lo_user" || $name2 == "hi_user"} { 350 return 351 } 352 353 # We only try to shorten some very common things. 354 # FIXME: CFA? 355 switch -exact -- $prefix { 356 TAG { 357 # Create two procedures for the tag. These call 358 # _handle_DW_TAG with the full tag name baked in; this 359 # does all the actual work. 360 proc $name {{attrs {}} {children {}}} \ 361 "_handle_DW_TAG $name \$attrs \$children" 362 363 # Filter out ones that are known to clash. 364 if {$name2 == "variable" || $name2 == "namespace"} { 365 set name2 "tag_$name2" 366 } 367 368 if {[info commands $name2] != {}} { 369 error "duplicate proc name: from $name" 370 } 371 372 proc $name2 {{attrs {}} {children {}}} \ 373 "_handle_DW_TAG $name \$attrs \$children" 374 } 375 376 AT { 377 set _AT($name2) $name 378 } 379 380 FORM { 381 set _FORM($name2) $name 382 } 383 384 OP { 385 set _OP($name2) $name 386 } 387 388 default { 389 return 390 } 391 } 392 } 393 394 proc _read_constants {} { 395 global srcdir hex decimal 396 397 # DWARF name-matching regexp. 398 set dwrx "DW_\[a-zA-Z0-9_\]+" 399 # Whitespace regexp. 400 set ws "\[ \t\]+" 401 402 set fd [open [file join $srcdir .. dwarf2.h]] 403 while {![eof $fd]} { 404 set line [gets $fd] 405 if {[regexp -- "^${ws}($dwrx)${ws}=${ws}($hex|$decimal),?$" \ 406 $line ignore name value ignore2]} { 407 _process_one_constant $name $value 408 } 409 } 410 close $fd 411 412 set fd [open [file join $srcdir .. dwarf2.def]] 413 while {![eof $fd]} { 414 set line [gets $fd] 415 if {[regexp -- \ 416 "^DW_\[A-Z_\]+${ws}\\(($dwrx),${ws}($hex|$decimal)\\)$" \ 417 $line ignore name value ignore2]} { 418 _process_one_constant $name $value 419 } 420 } 421 close $fd 422 } 423 424 proc _quote {string} { 425 # FIXME 426 return "\"${string}\\0\"" 427 } 428 429 proc _nz_quote {string} { 430 # For now, no quoting is done. 431 return "\"${string}\"" 432 } 433 434 proc _handle_DW_FORM {form value} { 435 switch -exact -- $form { 436 DW_FORM_string { 437 _op .ascii [_quote $value] 438 } 439 440 DW_FORM_flag_present { 441 # We don't need to emit anything. 442 } 443 444 DW_FORM_data4 - 445 DW_FORM_ref4 { 446 _op .4byte $value 447 } 448 449 DW_FORM_ref_addr { 450 variable _cu_offset_size 451 variable _cu_version 452 variable _cu_addr_size 453 454 if {$_cu_version == 2} { 455 set size $_cu_addr_size 456 } else { 457 set size $_cu_offset_size 458 } 459 460 _op .${size}byte $value 461 } 462 463 DW_FORM_sec_offset { 464 variable _cu_offset_size 465 _op .${_cu_offset_size}byte $value 466 } 467 468 DW_FORM_ref1 - 469 DW_FORM_flag - 470 DW_FORM_data1 { 471 _op .byte $value 472 } 473 474 DW_FORM_sdata { 475 _op .sleb128 $value 476 } 477 478 DW_FORM_ref_udata - 479 DW_FORM_udata { 480 _op .uleb128 $value 481 } 482 483 DW_FORM_addr { 484 variable _cu_addr_size 485 486 _op .${_cu_addr_size}byte $value 487 } 488 489 DW_FORM_data2 - 490 DW_FORM_ref2 { 491 _op .2byte $value 492 } 493 494 DW_FORM_data8 - 495 DW_FORM_ref8 - 496 DW_FORM_ref_sig8 { 497 _op .8byte $value 498 } 499 500 DW_FORM_data16 { 501 _op .8byte $value 502 } 503 504 DW_FORM_strp { 505 variable _strings 506 variable _cu_offset_size 507 508 if {![info exists _strings($value)]} { 509 set _strings($value) [new_label strp] 510 _defer_output .debug_string { 511 define_label $_strings($value) 512 _op .ascii [_quote $value] 513 } 514 } 515 516 _op .${_cu_offset_size}byte $_strings($value) "strp: $value" 517 } 518 519 SPECIAL_expr { 520 set l1 [new_label "expr_start"] 521 set l2 [new_label "expr_end"] 522 _op .uleb128 "$l2 - $l1" "expression" 523 define_label $l1 524 _location $value 525 define_label $l2 526 } 527 528 DW_FORM_block1 { 529 set len [string length $value] 530 if {$len > 255} { 531 error "DW_FORM_block1 length too long" 532 } 533 _op .byte $len 534 _op .ascii [_nz_quote $value] 535 } 536 537 DW_FORM_block2 - 538 DW_FORM_block4 - 539 540 DW_FORM_block - 541 542 DW_FORM_ref2 - 543 DW_FORM_indirect - 544 DW_FORM_exprloc - 545 546 DW_FORM_strx - 547 DW_FORM_strx1 - 548 DW_FORM_strx2 - 549 DW_FORM_strx3 - 550 DW_FORM_strx4 - 551 552 DW_FORM_GNU_addr_index - 553 DW_FORM_GNU_str_index - 554 DW_FORM_GNU_ref_alt - 555 DW_FORM_GNU_strp_alt - 556 557 default { 558 error "unhandled form $form" 559 } 560 } 561 } 562 563 proc _guess_form {value varname} { 564 upvar $varname new_value 565 566 switch -exact -- [string range $value 0 0] { 567 @ { 568 # Constant reference. 569 variable _constants 570 571 set new_value $_constants([string range $value 1 end]) 572 # Just the simplest. 573 return DW_FORM_sdata 574 } 575 576 : { 577 # Label reference. 578 variable _cu_label 579 580 set new_value "[string range $value 1 end] - $_cu_label" 581 582 return DW_FORM_ref4 583 } 584 585 % { 586 # Label reference, an offset from .debug_info. 587 set new_value "[string range $value 1 end]" 588 589 return DW_FORM_ref_addr 590 } 591 592 default { 593 return "" 594 } 595 } 596 } 597 598 proc _default_form { attr } { 599 switch -exact -- $attr { 600 DW_AT_low_pc { 601 return DW_FORM_addr 602 } 603 DW_AT_producer - 604 DW_AT_comp_dir - 605 DW_AT_linkage_name - 606 DW_AT_MIPS_linkage_name - 607 DW_AT_name { 608 return DW_FORM_string 609 } 610 } 611 return "" 612 } 613 614 # Map NAME to its canonical form. 615 proc _map_name {name ary} { 616 variable $ary 617 618 if {[info exists ${ary}($name)]} { 619 set name [set ${ary}($name)] 620 } 621 622 return $name 623 } 624 625 proc _handle_attribute { attr_name attr_value attr_form } { 626 variable _abbrev_section 627 variable _constants 628 variable _cu_version 629 630 _handle_DW_FORM $attr_form $attr_value 631 632 _defer_output $_abbrev_section { 633 if { $attr_form eq "SPECIAL_expr" } { 634 if { $_cu_version < 4 } { 635 set attr_form_comment "DW_FORM_block" 636 } else { 637 set attr_form_comment "DW_FORM_exprloc" 638 } 639 } else { 640 set attr_form_comment $attr_form 641 } 642 _op .uleb128 $_constants($attr_name) $attr_name 643 _op .uleb128 $_constants($attr_form) $attr_form_comment 644 } 645 } 646 647 # Handle macro attribute MACRO_AT_range. 648 649 proc _handle_macro_at_range { attr_value } { 650 if {[llength $attr_value] != 1} { 651 error "usage: MACRO_AT_range { func }" 652 } 653 654 set func [lindex $attr_value 0] 655 global srcdir subdir srcfile 656 set src ${srcdir}/${subdir}/${srcfile} 657 set result [function_range $func $src] 658 659 _handle_attribute DW_AT_low_pc [lindex $result 0] \ 660 DW_FORM_addr 661 _handle_attribute DW_AT_high_pc \ 662 "[lindex $result 0] + [lindex $result 1]" DW_FORM_addr 663 } 664 665 # Handle macro attribute MACRO_AT_func. 666 667 proc _handle_macro_at_func { attr_value } { 668 if {[llength $attr_value] != 1} { 669 error "usage: MACRO_AT_func { func file }" 670 } 671 _handle_attribute DW_AT_name [lindex $attr_value 0] DW_FORM_string 672 _handle_macro_at_range $attr_value 673 } 674 675 proc _handle_DW_TAG {tag_name {attrs {}} {children {}}} { 676 variable _abbrev_section 677 variable _abbrev_num 678 variable _constants 679 680 set has_children [expr {[string length $children] > 0}] 681 set my_abbrev [incr _abbrev_num] 682 683 # We somewhat wastefully emit a new abbrev entry for each tag. 684 # There's no reason for this other than laziness. 685 _defer_output $_abbrev_section { 686 _op .uleb128 $my_abbrev "Abbrev start" 687 _op .uleb128 $_constants($tag_name) $tag_name 688 _op .byte $has_children "has_children" 689 } 690 691 _op .uleb128 $my_abbrev "Abbrev ($tag_name)" 692 693 foreach attr $attrs { 694 set attr_name [_map_name [lindex $attr 0] _AT] 695 696 # When the length of ATTR is greater than 2, the last 697 # element of the list must be a form. The second through 698 # the penultimate elements are joined together and 699 # evaluated using subst. This allows constructs such as 700 # [gdb_target_symbol foo] to be used. 701 702 if {[llength $attr] > 2} { 703 set attr_value [uplevel 2 [list subst [join [lrange $attr 1 end-1]]]] 704 } else { 705 set attr_value [uplevel 2 [list subst [lindex $attr 1]]] 706 } 707 708 if { [string equal "MACRO_AT_func" $attr_name] } { 709 _handle_macro_at_func $attr_value 710 } elseif { [string equal "MACRO_AT_range" $attr_name] } { 711 _handle_macro_at_range $attr_value 712 } else { 713 if {[llength $attr] > 2} { 714 set attr_form [uplevel 2 [list subst [lindex $attr end]]] 715 716 if { [string index $attr_value 0] == ":" } { 717 # It is a label, get its value. 718 _guess_form $attr_value attr_value 719 } 720 } else { 721 set attr_form [_guess_form $attr_value attr_value] 722 if { $attr_form eq "" } { 723 set attr_form [_default_form $attr_name] 724 } 725 if { $attr_form eq "" } { 726 error "No form for $attr_name $attr_value" 727 } 728 } 729 set attr_form [_map_name $attr_form _FORM] 730 731 _handle_attribute $attr_name $attr_value $attr_form 732 } 733 } 734 735 _defer_output $_abbrev_section { 736 # Terminator. 737 _op .byte 0x0 "DW_AT - Terminator" 738 _op .byte 0x0 "DW_FORM - Terminator" 739 } 740 741 if {$has_children} { 742 uplevel 2 $children 743 744 # Terminate children. 745 _op .byte 0x0 "Terminate children" 746 } 747 } 748 749 proc _emit {string} { 750 variable _output_file 751 variable _defer 752 variable _deferred_output 753 754 if {$_defer == ""} { 755 puts $_output_file $string 756 } else { 757 append _deferred_output($_defer) ${string}\n 758 } 759 } 760 761 proc _section {name {flags ""} {type ""}} { 762 if {$flags == "" && $type == ""} { 763 _emit " .section $name" 764 } elseif {$type == ""} { 765 _emit " .section $name, \"$flags\"" 766 } else { 767 _emit " .section $name, \"$flags\", %$type" 768 } 769 } 770 771 # SECTION_SPEC is a list of arguments to _section. 772 proc _defer_output {section_spec body} { 773 variable _defer 774 variable _deferred_output 775 776 set old_defer $_defer 777 set _defer [lindex $section_spec 0] 778 779 if {![info exists _deferred_output($_defer)]} { 780 set _deferred_output($_defer) "" 781 eval _section $section_spec 782 } 783 784 uplevel $body 785 786 set _defer $old_defer 787 } 788 789 proc _defer_to_string {body} { 790 variable _defer 791 variable _deferred_output 792 793 set old_defer $_defer 794 set _defer temp 795 796 set _deferred_output($_defer) "" 797 798 uplevel $body 799 800 set result $_deferred_output($_defer) 801 unset _deferred_output($_defer) 802 803 set _defer $old_defer 804 return $result 805 } 806 807 proc _write_deferred_output {} { 808 variable _output_file 809 variable _deferred_output 810 811 foreach section [array names _deferred_output] { 812 # The data already has a newline. 813 puts -nonewline $_output_file $_deferred_output($section) 814 } 815 816 # Save some memory. 817 unset _deferred_output 818 } 819 820 proc _op {name value {comment ""}} { 821 set text " ${name} ${value}" 822 if {$comment != ""} { 823 # Try to make stuff line up nicely. 824 while {[string length $text] < 40} { 825 append text " " 826 } 827 append text "/* ${comment} */" 828 } 829 _emit $text 830 } 831 832 proc _compute_label {name} { 833 return ".L${name}" 834 } 835 836 # Return a name suitable for use as a label. If BASE_NAME is 837 # specified, it is incorporated into the label name; this is to 838 # make debugging the generated assembler easier. If BASE_NAME is 839 # not specified a generic default is used. This proc does not 840 # define the label; see 'define_label'. 'new_label' attempts to 841 # ensure that label names are unique. 842 proc new_label {{base_name label}} { 843 variable _label_num 844 845 return [_compute_label ${base_name}[incr _label_num]] 846 } 847 848 # Define a label named NAME. Ordinarily, NAME comes from a call 849 # to 'new_label', but this is not required. 850 proc define_label {name} { 851 _emit "${name}:" 852 } 853 854 # A higher-level interface to label handling. 855 # 856 # ARGS is a list of label descriptors. Each one is either a 857 # single element, or a list of two elements -- a name and some 858 # text. For each descriptor, 'new_label' is invoked. If the list 859 # form is used, the second element in the list is passed as an 860 # argument. The label name is used to define a variable in the 861 # enclosing scope; this can be used to refer to the label later. 862 # The label name is also used to define a new proc whose name is 863 # the label name plus a trailing ":". This proc takes a body as 864 # an argument and can be used to define the label at that point; 865 # then the body, if any, is evaluated in the caller's context. 866 # 867 # For example: 868 # 869 # declare_labels int_label 870 # something { ... $int_label } ;# refer to the label 871 # int_label: constant { ... } ;# define the label 872 proc declare_labels {args} { 873 foreach arg $args { 874 set name [lindex $arg 0] 875 set text [lindex $arg 1] 876 877 if { $text == "" } { 878 set text $name 879 } 880 881 upvar $name label_var 882 set label_var [new_label $text] 883 884 proc ${name}: {args} [format { 885 define_label %s 886 uplevel $args 887 } $label_var] 888 } 889 } 890 891 # This is a miniature assembler for location expressions. It is 892 # suitable for use in the attributes to a DIE. Its output is 893 # prefixed with "=" to make it automatically use DW_FORM_block. 894 # BODY is split by lines, and each line is taken to be a list. 895 # (FIXME should use 'info complete' here.) 896 # Each list's first element is the opcode, either short or long 897 # forms are accepted. 898 # FIXME argument handling 899 # FIXME move docs 900 proc _location {body} { 901 variable _constants 902 variable _cu_label 903 variable _cu_version 904 variable _cu_addr_size 905 variable _cu_offset_size 906 907 foreach line [split $body \n] { 908 # Ignore blank lines, and allow embedded comments. 909 if {[lindex $line 0] == "" || [regexp -- {^[ \t]*#} $line]} { 910 continue 911 } 912 set opcode [_map_name [lindex $line 0] _OP] 913 _op .byte $_constants($opcode) $opcode 914 915 switch -exact -- $opcode { 916 DW_OP_addr { 917 _op .${_cu_addr_size}byte [lindex $line 1] 918 } 919 920 DW_OP_regx { 921 _op .uleb128 [lindex $line 1] 922 } 923 924 DW_OP_pick - 925 DW_OP_const1u - 926 DW_OP_const1s { 927 _op .byte [lindex $line 1] 928 } 929 930 DW_OP_const2u - 931 DW_OP_const2s { 932 _op .2byte [lindex $line 1] 933 } 934 935 DW_OP_const4u - 936 DW_OP_const4s { 937 _op .4byte [lindex $line 1] 938 } 939 940 DW_OP_const8u - 941 DW_OP_const8s { 942 _op .8byte [lindex $line 1] 943 } 944 945 DW_OP_constu { 946 _op .uleb128 [lindex $line 1] 947 } 948 DW_OP_consts { 949 _op .sleb128 [lindex $line 1] 950 } 951 952 DW_OP_plus_uconst { 953 _op .uleb128 [lindex $line 1] 954 } 955 956 DW_OP_piece { 957 _op .uleb128 [lindex $line 1] 958 } 959 960 DW_OP_bit_piece { 961 _op .uleb128 [lindex $line 1] 962 _op .uleb128 [lindex $line 2] 963 } 964 965 DW_OP_skip - 966 DW_OP_bra { 967 _op .2byte [lindex $line 1] 968 } 969 970 DW_OP_implicit_value { 971 set l1 [new_label "value_start"] 972 set l2 [new_label "value_end"] 973 _op .uleb128 "$l2 - $l1" 974 define_label $l1 975 foreach value [lrange $line 1 end] { 976 switch -regexp -- $value { 977 {^0x[[:xdigit:]]{1,2}$} {_op .byte $value} 978 {^0x[[:xdigit:]]{4}$} {_op .2byte $value} 979 {^0x[[:xdigit:]]{8}$} {_op .4byte $value} 980 {^0x[[:xdigit:]]{16}$} {_op .8byte $value} 981 default { 982 error "bad value '$value' in DW_OP_implicit_value" 983 } 984 } 985 } 986 define_label $l2 987 } 988 989 DW_OP_implicit_pointer - 990 DW_OP_GNU_implicit_pointer { 991 if {[llength $line] != 3} { 992 error "usage: $opcode LABEL OFFSET" 993 } 994 995 # Here label is a section offset. 996 set label [lindex $line 1] 997 if { $_cu_version == 2 } { 998 _op .${_cu_addr_size}byte $label 999 } else { 1000 _op .${_cu_offset_size}byte $label 1001 } 1002 _op .sleb128 [lindex $line 2] 1003 } 1004 1005 DW_OP_GNU_variable_value { 1006 if {[llength $line] != 2} { 1007 error "usage: $opcode LABEL" 1008 } 1009 1010 # Here label is a section offset. 1011 set label [lindex $line 1] 1012 if { $_cu_version == 2 } { 1013 _op .${_cu_addr_size}byte $label 1014 } else { 1015 _op .${_cu_offset_size}byte $label 1016 } 1017 } 1018 1019 DW_OP_deref_size { 1020 if {[llength $line] != 2} { 1021 error "usage: DW_OP_deref_size SIZE" 1022 } 1023 1024 _op .byte [lindex $line 1] 1025 } 1026 1027 DW_OP_bregx { 1028 _op .uleb128 [lindex $line 1] 1029 _op .sleb128 [lindex $line 2] 1030 } 1031 1032 default { 1033 if {[llength $line] > 1} { 1034 error "Unimplemented: operands in location for $opcode" 1035 } 1036 } 1037 } 1038 } 1039 } 1040 1041 # Emit a DWARF CU. 1042 # OPTIONS is a list with an even number of elements containing 1043 # option-name and option-value pairs. 1044 # Current options are: 1045 # is_64 0|1 - boolean indicating if you want to emit 64-bit DWARF 1046 # default = 0 (32-bit) 1047 # version n - DWARF version number to emit 1048 # default = 4 1049 # addr_size n - the size of addresses in bytes: 4, 8, or default 1050 # default = default 1051 # fission 0|1 - boolean indicating if generating Fission debug info 1052 # default = 0 1053 # BODY is Tcl code that emits the DIEs which make up the body of 1054 # the CU. It is evaluated in the caller's context. 1055 proc cu {options body} { 1056 variable _constants 1057 variable _cu_count 1058 variable _abbrev_section 1059 variable _abbrev_num 1060 variable _cu_label 1061 variable _cu_version 1062 variable _cu_addr_size 1063 variable _cu_offset_size 1064 1065 # Establish the defaults. 1066 set is_64 0 1067 set _cu_version 4 1068 set _cu_addr_size default 1069 set fission 0 1070 set section ".debug_info" 1071 set _abbrev_section ".debug_abbrev" 1072 1073 foreach { name value } $options { 1074 set value [uplevel 1 "subst \"$value\""] 1075 switch -exact -- $name { 1076 is_64 { set is_64 $value } 1077 version { set _cu_version $value } 1078 addr_size { set _cu_addr_size $value } 1079 fission { set fission $value } 1080 default { error "unknown option $name" } 1081 } 1082 } 1083 if {$_cu_addr_size == "default"} { 1084 if {[is_64_target]} { 1085 set _cu_addr_size 8 1086 } else { 1087 set _cu_addr_size 4 1088 } 1089 } 1090 set _cu_offset_size [expr { $is_64 ? 8 : 4 }] 1091 if { $fission } { 1092 set section ".debug_info.dwo" 1093 set _abbrev_section ".debug_abbrev.dwo" 1094 } 1095 1096 if {$_cu_version < 4} { 1097 set _constants(SPECIAL_expr) $_constants(DW_FORM_block) 1098 } else { 1099 set _constants(SPECIAL_expr) $_constants(DW_FORM_exprloc) 1100 } 1101 1102 _section $section 1103 1104 set cu_num [incr _cu_count] 1105 set my_abbrevs [_compute_label "abbrev${cu_num}_begin"] 1106 set _abbrev_num 1 1107 1108 set _cu_label [_compute_label "cu${cu_num}_begin"] 1109 set start_label [_compute_label "cu${cu_num}_start"] 1110 set end_label [_compute_label "cu${cu_num}_end"] 1111 1112 define_label $_cu_label 1113 if {$is_64} { 1114 _op .4byte 0xffffffff 1115 _op .8byte "$end_label - $start_label" 1116 } else { 1117 _op .4byte "$end_label - $start_label" 1118 } 1119 define_label $start_label 1120 _op .2byte $_cu_version Version 1121 _op .${_cu_offset_size}byte $my_abbrevs Abbrevs 1122 _op .byte $_cu_addr_size "Pointer size" 1123 1124 _defer_output $_abbrev_section { 1125 define_label $my_abbrevs 1126 } 1127 1128 uplevel $body 1129 1130 _defer_output $_abbrev_section { 1131 # Emit the terminator. 1132 _op .byte 0x0 "Abbrev end - Terminator" 1133 } 1134 1135 define_label $end_label 1136 } 1137 1138 # Emit a DWARF TU. 1139 # OPTIONS is a list with an even number of elements containing 1140 # option-name and option-value pairs. 1141 # Current options are: 1142 # is_64 0|1 - boolean indicating if you want to emit 64-bit DWARF 1143 # default = 0 (32-bit) 1144 # version n - DWARF version number to emit 1145 # default = 4 1146 # addr_size n - the size of addresses in bytes: 4, 8, or default 1147 # default = default 1148 # fission 0|1 - boolean indicating if generating Fission debug info 1149 # default = 0 1150 # SIGNATURE is the 64-bit signature of the type. 1151 # TYPE_LABEL is the label of the type defined by this TU, 1152 # or "" if there is no type (i.e., type stubs in Fission). 1153 # BODY is Tcl code that emits the DIEs which make up the body of 1154 # the TU. It is evaluated in the caller's context. 1155 proc tu {options signature type_label body} { 1156 variable _cu_count 1157 variable _abbrev_section 1158 variable _abbrev_num 1159 variable _cu_label 1160 variable _cu_version 1161 variable _cu_addr_size 1162 variable _cu_offset_size 1163 1164 # Establish the defaults. 1165 set is_64 0 1166 set _cu_version 4 1167 set _cu_addr_size default 1168 set fission 0 1169 set section ".debug_types" 1170 set _abbrev_section ".debug_abbrev" 1171 1172 foreach { name value } $options { 1173 switch -exact -- $name { 1174 is_64 { set is_64 $value } 1175 version { set _cu_version $value } 1176 addr_size { set _cu_addr_size $value } 1177 fission { set fission $value } 1178 default { error "unknown option $name" } 1179 } 1180 } 1181 if {$_cu_addr_size == "default"} { 1182 if {[is_64_target]} { 1183 set _cu_addr_size 8 1184 } else { 1185 set _cu_addr_size 4 1186 } 1187 } 1188 set _cu_offset_size [expr { $is_64 ? 8 : 4 }] 1189 if { $fission } { 1190 set section ".debug_types.dwo" 1191 set _abbrev_section ".debug_abbrev.dwo" 1192 } 1193 1194 _section $section 1195 1196 set cu_num [incr _cu_count] 1197 set my_abbrevs [_compute_label "abbrev${cu_num}_begin"] 1198 set _abbrev_num 1 1199 1200 set _cu_label [_compute_label "cu${cu_num}_begin"] 1201 set start_label [_compute_label "cu${cu_num}_start"] 1202 set end_label [_compute_label "cu${cu_num}_end"] 1203 1204 define_label $_cu_label 1205 if {$is_64} { 1206 _op .4byte 0xffffffff 1207 _op .8byte "$end_label - $start_label" 1208 } else { 1209 _op .4byte "$end_label - $start_label" 1210 } 1211 define_label $start_label 1212 _op .2byte $_cu_version Version 1213 _op .${_cu_offset_size}byte $my_abbrevs Abbrevs 1214 _op .byte $_cu_addr_size "Pointer size" 1215 _op .8byte $signature Signature 1216 if { $type_label != "" } { 1217 uplevel declare_labels $type_label 1218 upvar $type_label my_type_label 1219 if {$is_64} { 1220 _op .8byte "$my_type_label - $_cu_label" 1221 } else { 1222 _op .4byte "$my_type_label - $_cu_label" 1223 } 1224 } else { 1225 if {$is_64} { 1226 _op .8byte 0 1227 } else { 1228 _op .4byte 0 1229 } 1230 } 1231 1232 _defer_output $_abbrev_section { 1233 define_label $my_abbrevs 1234 } 1235 1236 uplevel $body 1237 1238 _defer_output $_abbrev_section { 1239 # Emit the terminator. 1240 _op .byte 0x0 "Abbrev end - Terminator" 1241 } 1242 1243 define_label $end_label 1244 } 1245 1246 # Emit a DWARF .debug_ranges unit. 1247 # OPTIONS is a list with an even number of elements containing 1248 # option-name and option-value pairs. 1249 # Current options are: 1250 # is_64 0|1 - boolean indicating if you want to emit 64-bit DWARF 1251 # default = 0 (32-bit) 1252 # 1253 # BODY is Tcl code that emits the content of the .debug_ranges 1254 # unit, it is evaluated in the caller's context. 1255 proc ranges {options body} { 1256 variable _debug_ranges_64_bit 1257 1258 foreach { name value } $options { 1259 switch -exact -- $name { 1260 is_64 { set _debug_ranges_64_bit [subst $value] } 1261 default { error "unknown option $name" } 1262 } 1263 } 1264 1265 set section ".debug_ranges" 1266 _section $section 1267 1268 proc sequence { body } { 1269 variable _debug_ranges_64_bit 1270 1271 # Emit the sequence of addresses. 1272 1273 proc base { addr } { 1274 variable _debug_ranges_64_bit 1275 1276 if { $_debug_ranges_64_bit } then { 1277 _op .8byte 0xffffffffffffffff "Base Marker" 1278 _op .8byte $addr "Base Address" 1279 } else { 1280 _op .4byte 0xffffffff "Base Marker" 1281 _op .4byte $addr "Base Address" 1282 } 1283 } 1284 1285 proc range { start end } { 1286 variable _debug_ranges_64_bit 1287 1288 if { $_debug_ranges_64_bit } then { 1289 _op .8byte $start "Start Address" 1290 _op .8byte $end "End Address" 1291 } else { 1292 _op .4byte $start "Start Address" 1293 _op .4byte $end "End Address" 1294 } 1295 } 1296 1297 uplevel $body 1298 1299 # End of the sequence. 1300 if { $_debug_ranges_64_bit } then { 1301 _op .8byte 0x0 "End of Sequence Marker (Part 1)" 1302 _op .8byte 0x0 "End of Sequence Marker (Part 2)" 1303 } else { 1304 _op .4byte 0x0 "End of Sequence Marker (Part 1)" 1305 _op .4byte 0x0 "End of Sequence Marker (Part 2)" 1306 } 1307 } 1308 1309 uplevel $body 1310 } 1311 1312 1313 # Emit a DWARF .debug_line unit. 1314 # OPTIONS is a list with an even number of elements containing 1315 # option-name and option-value pairs. 1316 # Current options are: 1317 # is_64 0|1 - boolean indicating if you want to emit 64-bit DWARF 1318 # default = 0 (32-bit) 1319 # version n - DWARF version number to emit 1320 # default = 4 1321 # addr_size n - the size of addresses in bytes: 4, 8, or default 1322 # default = default 1323 # 1324 # LABEL is the label of the current unit (which is probably 1325 # referenced by a DW_AT_stmt_list), or "" if there is no such 1326 # label. 1327 # 1328 # BODY is Tcl code that emits the parts which make up the body of 1329 # the line unit. It is evaluated in the caller's context. The 1330 # following commands are available for the BODY section: 1331 # 1332 # include_dir "dirname" -- adds a new include directory 1333 # 1334 # file_name "file.c" idx -- adds a new file name. IDX is a 1335 # 1-based index referencing an include directory or 0 for 1336 # current directory. 1337 1338 proc lines {options label body} { 1339 variable _line_count 1340 variable _line_saw_file 1341 variable _line_saw_program 1342 variable _line_header_end_label 1343 1344 # Establish the defaults. 1345 set is_64 0 1346 set _unit_version 4 1347 set _unit_addr_size default 1348 set _line_saw_program 0 1349 set _line_saw_file 0 1350 set _default_is_stmt 1 1351 1352 foreach { name value } $options { 1353 switch -exact -- $name { 1354 is_64 { set is_64 $value } 1355 version { set _unit_version $value } 1356 addr_size { set _unit_addr_size $value } 1357 default_is_stmt { set _default_is_stmt $value } 1358 default { error "unknown option $name" } 1359 } 1360 } 1361 if {$_unit_addr_size == "default"} { 1362 if {[is_64_target]} { 1363 set _unit_addr_size 8 1364 } else { 1365 set _unit_addr_size 4 1366 } 1367 } 1368 1369 set unit_num [incr _line_count] 1370 1371 set section ".debug_line" 1372 _section $section 1373 1374 if { "$label" != "" } { 1375 # Define the user-provided label at this point. 1376 $label: 1377 } 1378 1379 set unit_len_label [_compute_label "line${_line_count}_start"] 1380 set unit_end_label [_compute_label "line${_line_count}_end"] 1381 set header_len_label [_compute_label "line${_line_count}_header_start"] 1382 set _line_header_end_label [_compute_label "line${_line_count}_header_end"] 1383 1384 if {$is_64} { 1385 _op .4byte 0xffffffff 1386 _op .8byte "$unit_end_label - $unit_len_label" "unit_length" 1387 } else { 1388 _op .4byte "$unit_end_label - $unit_len_label" "unit_length" 1389 } 1390 1391 define_label $unit_len_label 1392 1393 _op .2byte $_unit_version version 1394 1395 if {$is_64} { 1396 _op .8byte "$_line_header_end_label - $header_len_label" "header_length" 1397 } else { 1398 _op .4byte "$_line_header_end_label - $header_len_label" "header_length" 1399 } 1400 1401 define_label $header_len_label 1402 1403 _op .byte 1 "minimum_instruction_length" 1404 _op .byte $_default_is_stmt "default_is_stmt" 1405 _op .byte 1 "line_base" 1406 _op .byte 1 "line_range" 1407 _op .byte 10 "opcode_base" 1408 1409 # The standard_opcode_lengths table. The number of arguments 1410 # for each of the standard opcodes. Generating 9 entries here 1411 # matches the use of 10 in the opcode_base above. These 9 1412 # entries match the 9 standard opcodes for DWARF2, making use 1413 # of only 9 should be fine, even if we are generating DWARF3 1414 # or DWARF4. 1415 _op .byte 0 "standard opcode 1" 1416 _op .byte 1 "standard opcode 2" 1417 _op .byte 1 "standard opcode 3" 1418 _op .byte 1 "standard opcode 4" 1419 _op .byte 1 "standard opcode 5" 1420 _op .byte 0 "standard opcode 6" 1421 _op .byte 0 "standard opcode 7" 1422 _op .byte 0 "standard opcode 8" 1423 _op .byte 1 "standard opcode 9" 1424 1425 proc include_dir {dirname} { 1426 _op .ascii [_quote $dirname] 1427 } 1428 1429 proc file_name {filename diridx} { 1430 variable _line_saw_file 1431 if "! $_line_saw_file" { 1432 # Terminate the dir list. 1433 _op .byte 0 "Terminator." 1434 set _line_saw_file 1 1435 } 1436 1437 _op .ascii [_quote $filename] 1438 _op .sleb128 $diridx 1439 _op .sleb128 0 "mtime" 1440 _op .sleb128 0 "length" 1441 } 1442 1443 proc program {statements} { 1444 variable _line_saw_program 1445 variable _line_header_end_label 1446 variable _line 1447 1448 set _line 1 1449 1450 if "! $_line_saw_program" { 1451 # Terminate the file list. 1452 _op .byte 0 "Terminator." 1453 define_label $_line_header_end_label 1454 set _line_saw_program 1 1455 } 1456 1457 proc DW_LNE_set_address {addr} { 1458 _op .byte 0 1459 set start [new_label "set_address_start"] 1460 set end [new_label "set_address_end"] 1461 _op .uleb128 "${end} - ${start}" 1462 define_label ${start} 1463 _op .byte 2 1464 if {[is_64_target]} { 1465 _op .8byte ${addr} 1466 } else { 1467 _op .4byte ${addr} 1468 } 1469 define_label ${end} 1470 } 1471 1472 proc DW_LNE_end_sequence {} { 1473 variable _line 1474 _op .byte 0 1475 _op .uleb128 1 1476 _op .byte 1 1477 set _line 1 1478 } 1479 1480 proc DW_LNE_user { len opcode } { 1481 set DW_LNE_lo_usr 0x80 1482 set DW_LNE_hi_usr 0xff 1483 if { $DW_LNE_lo_usr <= $opcode 1484 && $opcode <= $DW_LNE_hi_usr } { 1485 _op .byte 0 1486 _op .uleb128 $len 1487 _op .byte $opcode 1488 for {set i 1} {$i < $len} {incr i} { 1489 _op .byte 0 1490 } 1491 } else { 1492 error "unknown vendor specific extended opcode: $opcode" 1493 } 1494 } 1495 1496 proc DW_LNS_copy {} { 1497 _op .byte 1 1498 } 1499 1500 proc DW_LNS_negate_stmt {} { 1501 _op .byte 6 1502 } 1503 1504 proc DW_LNS_advance_pc {offset} { 1505 _op .byte 2 1506 _op .uleb128 ${offset} 1507 } 1508 1509 proc DW_LNS_advance_line {offset} { 1510 variable _line 1511 _op .byte 3 1512 _op .sleb128 ${offset} 1513 set _line [expr $_line + $offset] 1514 } 1515 1516 # A pseudo line number program instruction, that can be used instead 1517 # of DW_LNS_advance_line. Rather than writing: 1518 # {DW_LNS_advance_line [expr $line1 - 1]} 1519 # {DW_LNS_advance_line [expr $line2 - $line1]} 1520 # {DW_LNS_advance_line [expr $line3 - $line2]} 1521 # we can just write: 1522 # {line $line1} 1523 # {line $line2} 1524 # {line $line3} 1525 proc line {line} { 1526 variable _line 1527 set offset [expr $line - $_line] 1528 DW_LNS_advance_line $offset 1529 } 1530 1531 proc DW_LNS_set_file {num} { 1532 _op .byte 4 1533 _op .sleb128 ${num} 1534 } 1535 1536 foreach statement $statements { 1537 uplevel 1 $statement 1538 } 1539 } 1540 1541 uplevel $body 1542 1543 rename include_dir "" 1544 rename file_name "" 1545 1546 # Terminate dir list if we saw no files. 1547 if "! $_line_saw_file" { 1548 _op .byte 0 "Terminator." 1549 } 1550 1551 # Terminate the file list. 1552 if "! $_line_saw_program" { 1553 _op .byte 0 "Terminator." 1554 define_label $_line_header_end_label 1555 } 1556 1557 define_label $unit_end_label 1558 } 1559 1560 proc _empty_array {name} { 1561 upvar $name the_array 1562 1563 catch {unset the_array} 1564 set the_array(_) {} 1565 unset the_array(_) 1566 } 1567 1568 # Emit a .gnu_debugaltlink section with the given file name and 1569 # build-id. The buildid should be represented as a hexadecimal 1570 # string, like "ffeeddcc". 1571 proc gnu_debugaltlink {filename buildid} { 1572 _defer_output .gnu_debugaltlink { 1573 _op .ascii [_quote $filename] 1574 foreach {a b} [split $buildid {}] { 1575 _op .byte 0x$a$b 1576 } 1577 } 1578 } 1579 1580 proc _note {type name hexdata} { 1581 set namelen [expr [string length $name] + 1] 1582 1583 # Name size. 1584 _op .4byte $namelen 1585 # Data size. 1586 _op .4byte [expr [string length $hexdata] / 2] 1587 # Type. 1588 _op .4byte $type 1589 # The name. 1590 _op .ascii [_quote $name] 1591 # Alignment. 1592 set align 2 1593 set total [expr {($namelen + (1 << $align) - 1) & -(1 << $align)}] 1594 for {set i $namelen} {$i < $total} {incr i} { 1595 _op .byte 0 1596 } 1597 # The data. 1598 foreach {a b} [split $hexdata {}] { 1599 _op .byte 0x$a$b 1600 } 1601 } 1602 1603 # Emit a note section holding the given build-id. 1604 proc build_id {buildid} { 1605 _defer_output {.note.gnu.build-id a note} { 1606 # From elf/common.h. 1607 set NT_GNU_BUILD_ID 3 1608 1609 _note $NT_GNU_BUILD_ID GNU $buildid 1610 } 1611 } 1612 1613 # The top-level interface to the DWARF assembler. 1614 # FILENAME is the name of the file where the generated assembly 1615 # code is written. 1616 # BODY is Tcl code to emit the assembly. It is evaluated via 1617 # "eval" -- not uplevel as you might expect, because it is 1618 # important to run the body in the Dwarf namespace. 1619 # 1620 # A typical invocation is something like: 1621 # Dwarf::assemble $file { 1622 # cu 0 2 8 { 1623 # compile_unit { 1624 # ... 1625 # } 1626 # } 1627 # cu 0 2 8 { 1628 # ... 1629 # } 1630 # } 1631 proc assemble {filename body} { 1632 variable _initialized 1633 variable _output_file 1634 variable _deferred_output 1635 variable _defer 1636 variable _label_num 1637 variable _strings 1638 variable _cu_count 1639 variable _line_count 1640 variable _line_saw_file 1641 variable _line_saw_program 1642 variable _line_header_end_label 1643 variable _debug_ranges_64_bit 1644 1645 if {!$_initialized} { 1646 _read_constants 1647 set _initialized 1 1648 } 1649 1650 set _output_file [open $filename w] 1651 set _cu_count 0 1652 _empty_array _deferred_output 1653 set _defer "" 1654 set _label_num 0 1655 _empty_array _strings 1656 1657 set _line_count 0 1658 set _line_saw_file 0 1659 set _line_saw_program 0 1660 set _debug_ranges_64_bit [is_64_target] 1661 1662 # Not "uplevel" here, because we want to evaluate in this 1663 # namespace. This is somewhat bad because it means we can't 1664 # readily refer to outer variables. 1665 eval $body 1666 1667 _write_deferred_output 1668 1669 catch {close $_output_file} 1670 set _output_file {} 1671 } 1672} 1673