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