| blob | 8b0cf77412dbea9c3a4fc783f873f47ae64c7cb1 |
1 # Copyright 2010-2023 Free Software Foundation, Inc.
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/>.
16 # Return true if the target supports DWARF-2 and uses gas.
17 # For now pick a sampling of likely targets.
18 proc dwarf2_support {} {
19 if {[istarget *-*-linux*]
20 || [istarget *-*-gnu*]
21 || [istarget *-*-elf*]
22 || [istarget *-*-openbsd*]
23 || [istarget arm*-*-eabi*]
24 || [istarget powerpc-*-eabi*]} {
25 return 1
26 }
28 return 0
29 }
31 # Use 'objcopy --extract-dwo to extract DWO information from
32 # OBJECT_FILE and place it into DWO_FILE.
33 #
34 # Return 0 on success, otherwise, return -1.
35 proc extract_dwo_information { object_file dwo_file } {
36 set objcopy [gdb_find_objcopy]
37 set command "$objcopy --extract-dwo $object_file $dwo_file"
38 verbose -log "Executing $command"
39 set result [catch "exec $command" output]
40 verbose -log "objcopy --extract-dwo output: $output"
41 if { $result == 1 } {
42 return -1
43 }
44 return 0
45 }
47 # Use 'objcopy --strip-dwo to remove DWO information from
48 # FILENAME.
49 #
50 # Return 0 on success, otherwise, return -1.
51 proc strip_dwo_information { filename } {
52 set objcopy [gdb_find_objcopy]
53 set command "$objcopy --strip-dwo $filename"
54 verbose -log "Executing $command"
55 set result [catch "exec $command" output]
56 verbose -log "objcopy --strip-dwo output: $output"
57 if { $result == 1 } {
58 return -1
59 }
60 return 0
61 }
63 # Build an executable, with the debug information split out into a
64 # separate .dwo file.
65 #
66 # This function is based on build_executable_from_specs in
67 # lib/gdb.exp, but with threading support, and rust support removed.
68 #
69 # TESTNAME is the name of the test; this is passed to 'untested' if
70 # something fails.
71 #
72 # EXECUTABLE is the executable to create, this can be an absolute
73 # path, or a relative path, in which case the EXECUTABLE will be
74 # created in the standard output directory.
75 #
76 # OPTIONS is passed to the final link, using gdb_compile. If OPTIONS
77 # contains any option that indicates threads is required, of if the
78 # option rust is included, then this function will return failure.
79 #
80 # ARGS is a series of lists. Each list is a spec for one source file
81 # that will be compiled to make EXECUTABLE. Each spec in ARGS has the
82 # form:
83 # [ SOURCE OPTIONS ]
84 # or:
85 # [ SOURCE OPTIONS OBJFILE ]
86 #
87 # Where SOURCE is the path to the source file to compile. This can be
88 # absolute, or relative to the standard global ${subdir}/${srcdir}/
89 # path.
90 #
91 # OPTIONS are the options to use when compiling SOURCE into an object
92 # file.
93 #
94 # OBJFILE is optional, if present this is the name of the object file
95 # to create for SOURCE. If this is not provided then a suitable name
96 # will be auto-generated.
97 #
98 # If OPTIONS contains the option 'split-dwo' then the debug
99 # information is extracted from the object file created by compiling
100 # SOURCE and placed into a file with a dwo extension. The name of
101 # this file is generated based on the name of the object file that was
102 # created (with the .o replaced with .dwo).
103 proc build_executable_and_dwo_files { testname executable options args } {
104 global subdir
105 global srcdir
107 if {![regexp "^/" "$executable"]} {
108 set binfile [standard_output_file $executable]
109 } else {
110 set binfile $executable
111 }
113 set func gdb_compile
114 if {[lsearch -regexp $options \
115 {^(pthreads|shlib|shlib_pthreads|openmp)$}] != -1} {
116 # Currently don't support compiling thread based tests here.
117 # If this is required then look to build_executable_from_specs
118 # for inspiration.
119 return -1
120 }
121 if {[lsearch -exact $options rust] != -1} {
122 # Currently don't support compiling rust tests here. If this
123 # is required then look to build_executable_from_specs for
124 # inspiration.
125 return -1
126 }
128 # Must be run on local host due to use of objcopy.
129 if [is_remote host] {
130 return -1
131 }
133 set objects {}
134 set i 0
135 foreach spec $args {
136 if {[llength $spec] < 2} {
137 error "invalid spec length"
138 return -1
139 }
141 verbose -log "APB: SPEC: $spec"
143 set s [lindex $spec 0]
144 set local_options [lindex $spec 1]
146 if {![regexp "^/" "$s"]} {
147 set s "$srcdir/$subdir/$s"
148 }
150 if {[llength $spec] > 2} {
151 set objfile [lindex $spec 2]
152 } else {
153 set objfile "${binfile}${i}.o"
154 incr i
155 }
157 if { [$func "${s}" "${objfile}" object $local_options] != "" } {
158 untested $testname
159 return -1
160 }
162 lappend objects "$objfile"
164 if {[lsearch -exact $local_options "split-dwo"] >= 0} {
165 # Split out the DWO file.
166 set dwo_file "[file rootname ${objfile}].dwo"
168 if { [extract_dwo_information $objfile $dwo_file] == -1 } {
169 untested $testname
170 return -1
171 }
173 if { [strip_dwo_information $objfile] == -1 } {
174 untested $testname
175 return -1
176 }
177 }
178 }
180 verbose -log "APB: OBJECTS = $objects"
182 set ret [$func $objects "${binfile}" executable $options]
183 if { $ret != "" } {
184 untested $testname
185 return -1
186 }
188 return 0
189 }
191 # Utility function for procs shared_gdb_*.
193 proc init_shared_gdb {} {
194 global shared_gdb_enabled
195 global shared_gdb_started
197 if { ! [info exists shared_gdb_enabled] } {
198 set shared_gdb_enabled 0
199 set shared_gdb_started 0
200 }
201 }
203 # Cluster of four procs:
204 # - shared_gdb_enable
205 # - shared_gdb_disable
206 # - shared_gdb_start_use SRC OPTIONS
207 # - shared_gdb_end_use
208 #
209 # Can be used like so:
210 #
211 # {
212 # if { $share } shared_gdb_enable
213 # ...
214 # shared_gdb_start_use $src $options
215 # ...
216 # shared_gdb_end_use
217 # ...
218 # shared_gdb_start_use $src $options
219 # ...
220 # shared_gdb_end_use
221 # ...
222 # if { $share } shared_gdb_disable
223 # }
224 #
225 # to write functionalty that could share ($share == 1) or could not
226 # share ($share == 0) a gdb session between two uses.
228 proc shared_gdb_enable {} {
229 set me shared_gdb_enable
231 init_shared_gdb
232 global shared_gdb_enabled
233 global shared_gdb_started
235 if { $shared_gdb_enabled } {
236 error "$me: gdb sharing already enabled"
237 }
238 set shared_gdb_enabled 1
240 if { $shared_gdb_started } {
241 error "$me: gdb sharing not stopped"
242 }
243 }
245 # See above.
247 proc shared_gdb_disable {} {
248 init_shared_gdb
249 global shared_gdb_enabled
250 global shared_gdb_started
252 if { ! $shared_gdb_enabled } {
253 error "$me: gdb sharing not enabled"
254 }
255 set shared_gdb_enabled 0
257 if { $shared_gdb_started } {
258 gdb_exit
259 set shared_gdb_started 0
260 }
261 }
263 # Share the current gdb session.
265 proc share_gdb { src options } {
266 global shared_gdb_started
267 global shared_gdb_src
268 global shared_gdb_options
270 set shared_gdb_started 1
271 set shared_gdb_src $src
272 set shared_gdb_options $options
273 }
275 # See above.
277 proc shared_gdb_start_use { src options } {
278 set me shared_gdb_start_use
280 init_shared_gdb
281 global shared_gdb_enabled
282 global shared_gdb_started
283 global shared_gdb_src
284 global shared_gdb_options
286 set do_start 1
287 if { $shared_gdb_enabled && $shared_gdb_started } {
288 if { $shared_gdb_src != $src
289 || $shared_gdb_options != $options } {
290 error "$me: gdb sharing inconsistent"
291 }
293 set do_start 0
294 }
296 if { $do_start } {
297 set exe [standard_temp_file func_addr[pid].x]
299 gdb_compile $src $exe executable $options
301 gdb_exit
302 gdb_start
303 gdb_load "$exe"
305 if { $shared_gdb_enabled } {
306 share_gdb $src $options
307 }
308 }
309 }
311 # See above.
313 proc shared_gdb_end_use {} {
314 init_shared_gdb
315 global shared_gdb_enabled
317 if { ! $shared_gdb_enabled } {
318 gdb_exit
319 }
320 }
322 # Enable gdb session sharing within BODY.
324 proc with_shared_gdb { body } {
325 shared_gdb_enable
326 set code [catch { uplevel 1 $body } result]
327 shared_gdb_disable
329 # Return as appropriate.
330 if { $code == 1 } {
331 global errorInfo errorCode
332 return -code error -errorinfo $errorInfo -errorcode $errorCode $result
333 } elseif { $code > 1 } {
334 return -code $code $result
335 }
337 return $result
338 }
340 # Return a list of expressions about function FUNC's address and length.
341 # The first expression is the address of function FUNC, and the second
342 # one is FUNC's length. SRC is the source file having function FUNC.
343 # An internal label ${func}_label must be defined inside FUNC:
344 #
345 # int main (void)
346 # {
347 # asm ("main_label: .globl main_label");
348 # return 0;
349 # }
350 #
351 # This label is needed to compute the start address of function FUNC.
352 # If the compiler is gcc, we can do the following to get function start
353 # and end address too:
354 #
355 # asm ("func_start: .globl func_start");
356 # static void func (void) {}
357 # asm ("func_end: .globl func_end");
358 #
359 # however, this isn't portable, because other compilers, such as clang,
360 # may not guarantee the order of global asms and function. The code
361 # becomes:
362 #
363 # asm ("func_start: .globl func_start");
364 # asm ("func_end: .globl func_end");
365 # static void func (void) {}
366 #
368 proc function_range { func src {options {debug}} } {
369 global decimal gdb_prompt
371 shared_gdb_start_use $src $options
373 # Compute the label offset, and we can get the function start address
374 # by "${func}_label - $func_label_offset".
375 set func_label_offset ""
376 set test "p ${func}_label - ${func}"
377 gdb_test_multiple $test $test {
378 -re ".* = ($decimal)\r\n$gdb_prompt $" {
379 set func_label_offset $expect_out(1,string)
380 }
381 }
383 # Compute the function length.
384 global hex
385 set func_length ""
386 set test "disassemble $func"
387 gdb_test_multiple $test $test {
388 -re ".*$hex <\\+($decimal)>:\[^\r\n\]+\r\nEnd of assembler dump\.\r\n$gdb_prompt $" {
389 set func_length $expect_out(1,string)
390 }
391 }
393 # Compute the size of the last instruction.
394 # For C++, GDB appends arguments to the names of functions if they don't
395 # have a linkage name. For example, asking gdb to disassemble a C++ main
396 # will print the function name as main() or main(int argc, char **argv).
397 # Take this into account by optionally allowing an argument list after
398 # the function name.
399 set func_pattern "$func\(\?\:\\(\.\*\\)\)?"
400 if { $func_length != 0 } {
401 set func_pattern "$func_pattern\\+$func_length"
402 }
403 set test "with print asm-demangle on -- x/2i $func+$func_length"
404 gdb_test_multiple $test $test {
405 -re ".*($hex) <$func_pattern>:\[^\r\n\]+\r\n\[ \]+($hex).*\.\r\n$gdb_prompt $" {
406 set start $expect_out(1,string)
407 set end $expect_out(2,string)
409 set func_length [expr $func_length + $end - $start]
410 }
411 }
413 shared_gdb_end_use
415 return [list "${func}_label - $func_label_offset" $func_length]
416 }
418 # Extract the start, length, and end for function called NAME and
419 # create suitable variables in the callers scope.
420 # Return the list of created variables.
421 proc get_func_info { name {options {debug}} } {
422 global srcdir subdir srcfile
424 upvar 1 "${name}_start" func_start
425 upvar 1 "${name}_len" func_len
426 upvar 1 "${name}_end" func_end
428 lassign [function_range ${name} \
429 [list ${srcdir}/${subdir}/$srcfile] \
430 ${options}] \
431 func_start func_len
432 set func_end "$func_start + $func_len"
434 return [list \
435 "${name}_start" \
436 "${name}_len" \
437 "${name}_end"]
438 }
440 # A DWARF assembler.
441 #
442 # All the variables in this namespace are private to the
443 # implementation. Also, any procedure whose name starts with "_" is
444 # private as well. Do not use these.
445 #
446 # Exported functions are documented at their definition.
447 #
448 # In addition to the hand-written functions documented below, this
449 # module automatically generates a function for each DWARF tag. For
450 # most tags, two forms are made: a full name, and one with the
451 # "DW_TAG_" prefix stripped. For example, you can use either
452 # 'DW_TAG_compile_unit' or 'compile_unit' interchangeably.
453 #
454 # There are two exceptions to this rule: DW_TAG_variable and
455 # DW_TAG_namespace. For these, the full name must always be used,
456 # as the short name conflicts with Tcl builtins. (Should future
457 # versions of Tcl or DWARF add more conflicts, this list will grow.
458 # If you want to be safe you should always use the full names.)
459 #
460 # Each tag procedure is defined like:
461 #
462 # proc DW_TAG_mumble {{attrs {}} {children {}}} { ... }
463 #
464 # ATTRS is an optional list of attributes.
465 # It is run through 'subst' in the caller's context before processing.
466 #
467 # Each attribute in the list has one of two forms:
468 # 1. { NAME VALUE }
469 # 2. { NAME VALUE FORM }
470 #
471 # In each case, NAME is the attribute's name.
472 # This can either be the full name, like 'DW_AT_name', or a shortened
473 # name, like 'name'. These are fully equivalent.
474 #
475 # Besides DWARF standard attributes, assembler supports 'macro' attribute
476 # which will be substituted by one or more standard or macro attributes.
477 # supported macro attributes are:
478 #
479 # - MACRO_AT_range { FUNC }
480 # It is substituted by DW_AT_low_pc and DW_AT_high_pc with the start and
481 # end address of function FUNC in file $srcdir/$subdir/$srcfile.
482 #
483 # - MACRO_AT_func { FUNC }
484 # It is substituted by DW_AT_name with FUNC and MACRO_AT_range.
485 #
486 # If FORM is given, it should name a DW_FORM_ constant.
487 # This can either be the short form, like 'DW_FORM_addr', or a
488 # shortened version, like 'addr'. If the form is given, VALUE
489 # is its value; see below. In some cases, additional processing
490 # is done; for example, DW_FORM_strp manages the .debug_str
491 # section automatically.
492 #
493 # If FORM is 'SPECIAL_expr', then VALUE is treated as a location
494 # expression. The effective form is then DW_FORM_block or DW_FORM_exprloc
495 # for DWARF version >= 4, and VALUE is passed to the (internal)
496 # '_location' proc to be translated.
497 # This proc implements a miniature DW_OP_ assembler.
498 #
499 # If FORM is not given, it is guessed:
500 # * If VALUE starts with the "@" character, the rest of VALUE is
501 # looked up as a DWARF constant, and DW_FORM_sdata is used. For
502 # example, '@DW_LANG_c89' could be used.
503 # * If VALUE starts with the ":" character, then it is a label
504 # reference. The rest of VALUE is taken to be the name of a label,
505 # and DW_FORM_ref4 is used. See 'new_label' and 'define_label'.
506 # * If VALUE starts with the "%" character, then it is a label
507 # reference too, but DW_FORM_ref_addr is used.
508 # * Otherwise, if the attribute name has a default form (f.i. DW_FORM_addr for
509 # DW_AT_low_pc), then that one is used.
510 # * Otherwise, an error is reported. Either specify a form explicitly, or
511 # add a default for the the attribute name in _default_form.
512 #
513 # CHILDREN is just Tcl code that can be used to define child DIEs. It
514 # is evaluated in the caller's context.
515 #
516 # Currently this code is missing nice support for CFA handling, and
517 # probably other things as well.
519 namespace eval Dwarf {
520 # True if the module has been initialized.
521 variable _initialized 0
523 # Constants from dwarf2.h.
524 variable _constants
525 # DW_AT short names.
526 variable _AT
527 # DW_FORM short names.
528 variable _FORM
529 # DW_OP short names.
530 variable _OP
532 # The current output file.
533 variable _output_file
535 # Note: The _cu_ values here also apply to type units (TUs).
536 # Think of a TU as a special kind of CU.
538 # Current CU count.
539 variable _cu_count
541 # The current CU's base label.
542 variable _cu_label
544 # The current CU's version.
545 variable _cu_version
547 # The current CU's address size.
548 variable _cu_addr_size
549 # The current CU's offset size.
550 variable _cu_offset_size
552 # Label generation number.
553 variable _label_num
555 # The deferred output array. The index is the section name; the
556 # contents hold the data for that section.
557 variable _deferred_output
559 # If empty, we should write directly to the output file.
560 # Otherwise, this is the name of a section to write to.
561 variable _defer
563 # The abbrev section. Typically .debug_abbrev but can be .debug_abbrev.dwo
564 # for Fission.
565 variable _abbrev_section
567 # The next available abbrev number in the current CU's abbrev
568 # table.
569 variable _abbrev_num
571 # The string table for this assembly. The key is the string; the
572 # value is the label for that string.
573 variable _strings
575 # Current .debug_line unit count.
576 variable _line_count
578 # A Label for line table header generation.
579 variable _line_header_end_label
581 # The address size for debug ranges section.
582 variable _debug_ranges_64_bit
584 # The index into the .debug_addr section (used for fission
585 # generation).
586 variable _debug_addr_index
588 # Flag, true if the current CU is contains fission information,
589 # otherwise false.
590 variable _cu_is_fission
592 proc _process_one_constant {name value} {
593 variable _constants
594 variable _AT
595 variable _FORM
596 variable _OP
598 set _constants($name) $value
600 if {![regexp "^DW_(\[A-Z\]+)_(\[A-Za-z0-9_\]+)$" $name \
601 ignore prefix name2]} {
602 error "non-matching name: $name"
603 }
605 if {$name2 == "lo_user" || $name2 == "hi_user"} {
606 return
607 }
609 # We only try to shorten some very common things.
610 # FIXME: CFA?
611 switch -exact -- $prefix {
612 TAG {
613 # Create two procedures for the tag. These call
614 # _handle_DW_TAG with the full tag name baked in; this
615 # does all the actual work.
616 proc $name {{attrs {}} {children {}}} \
617 "_handle_DW_TAG $name \$attrs \$children"
619 # Filter out ones that are known to clash.
620 if {$name2 == "variable" || $name2 == "namespace"} {
621 set name2 "tag_$name2"
622 }
624 if {[info commands $name2] != {}} {
625 error "duplicate proc name: from $name"
626 }
628 proc $name2 {{attrs {}} {children {}}} \
629 "_handle_DW_TAG $name \$attrs \$children"
630 }
632 AT {
633 set _AT($name2) $name
634 }
636 FORM {
637 set _FORM($name2) $name
638 }
640 OP {
641 set _OP($name2) $name
642 }
644 default {
645 return
646 }
647 }
648 }
650 proc _read_constants {} {
651 global srcdir hex decimal
653 # DWARF name-matching regexp.
654 set dwrx "DW_\[a-zA-Z0-9_\]+"
655 # Whitespace regexp.
656 set ws "\[ \t\]+"
658 set fd [open [file join $srcdir .. .. include dwarf2.h]]
659 while {![eof $fd]} {
660 set line [gets $fd]
661 if {[regexp -- "^${ws}($dwrx)${ws}=${ws}($hex|$decimal),?$" \
662 $line ignore name value ignore2]} {
663 _process_one_constant $name $value
664 }
665 }
666 close $fd
668 set fd [open [file join $srcdir .. .. include dwarf2.def]]
669 while {![eof $fd]} {
670 set line [gets $fd]
671 if {[regexp -- \
672 "^DW_\[A-Z_\]+${ws}\\(($dwrx),${ws}($hex|$decimal)\\)$" \
673 $line ignore name value ignore2]} {
674 _process_one_constant $name $value
675 }
676 }
677 close $fd
678 }
680 proc _quote {string} {
681 # FIXME
682 return "\"${string}\\0\""
683 }
685 proc _nz_quote {string} {
686 # For now, no quoting is done.
687 return "\"${string}\""
688 }
690 proc _handle_DW_FORM {form value} {
691 switch -exact -- $form {
692 DW_FORM_string {
693 _op .ascii [_quote $value]
694 }
696 DW_FORM_flag_present {
697 # We don't need to emit anything.
698 }
700 DW_FORM_data4 -
701 DW_FORM_ref4 {
702 _op .4byte $value
703 }
705 DW_FORM_ref_addr {
706 variable _cu_offset_size
707 variable _cu_version
708 variable _cu_addr_size
710 if {$_cu_version == 2} {
711 set size $_cu_addr_size
712 } else {
713 set size $_cu_offset_size
714 }
716 _op .${size}byte $value
717 }
719 DW_FORM_GNU_ref_alt -
720 DW_FORM_GNU_strp_alt -
721 DW_FORM_sec_offset {
722 variable _cu_offset_size
723 _op_offset $_cu_offset_size $value
724 }
726 DW_FORM_ref1 -
727 DW_FORM_flag -
728 DW_FORM_data1 {
729 _op .byte $value
730 }
732 DW_FORM_sdata {
733 _op .sleb128 $value
734 }
736 DW_FORM_ref_udata -
737 DW_FORM_udata -
738 DW_FORM_loclistx -
739 DW_FORM_rnglistx {
740 _op .uleb128 $value
741 }
743 DW_FORM_addr {
744 variable _cu_addr_size
746 _op .${_cu_addr_size}byte $value
747 }
749 DW_FORM_GNU_addr_index {
750 variable _debug_addr_index
751 variable _cu_addr_size
753 _op .uleb128 ${_debug_addr_index}
754 incr _debug_addr_index
756 _defer_output .debug_addr {
757 _op .${_cu_addr_size}byte $value
758 }
759 }
761 DW_FORM_data2 -
762 DW_FORM_ref2 {
763 _op .2byte $value
764 }
766 DW_FORM_data8 -
767 DW_FORM_ref8 -
768 DW_FORM_ref_sig8 {
769 _op .8byte $value
770 }
772 DW_FORM_data16 {
773 _op .8byte $value
774 }
776 DW_FORM_strp {
777 variable _strings
778 variable _cu_offset_size
780 if {![info exists _strings($value)]} {
781 set _strings($value) [new_label strp]
782 _defer_output .debug_str {
783 define_label $_strings($value)
784 _op .ascii [_quote $value]
785 }
786 }
788 _op_offset $_cu_offset_size $_strings($value) "strp: $value"
789 }
791 SPECIAL_expr {
792 variable _cu_version
793 variable _cu_addr_size
794 variable _cu_offset_size
796 set l1 [new_label "expr_start"]
797 set l2 [new_label "expr_end"]
798 _op .uleb128 "$l2 - $l1" "expression"
799 define_label $l1
800 _location $value $_cu_version $_cu_addr_size $_cu_offset_size
801 define_label $l2
802 }
804 DW_FORM_block1 {
805 set len [string length $value]
806 if {$len > 255} {
807 error "DW_FORM_block1 length too long"
808 }
809 _op .byte $len
810 _op .ascii [_nz_quote $value]
811 }
813 DW_FORM_block2 -
814 DW_FORM_block4 -
816 DW_FORM_block -
818 DW_FORM_ref2 -
819 DW_FORM_indirect -
820 DW_FORM_exprloc -
822 DW_FORM_strx -
823 DW_FORM_strx1 -
824 DW_FORM_strx2 -
825 DW_FORM_strx3 -
826 DW_FORM_strx4 -
828 DW_FORM_GNU_str_index -
830 default {
831 error "unhandled form $form"
832 }
833 }
834 }
836 proc _guess_form {value varname} {
837 upvar $varname new_value
839 switch -exact -- [string range $value 0 0] {
840 @ {
841 # Constant reference.
842 variable _constants
844 set new_value $_constants([string range $value 1 end])
845 # Just the simplest.
846 return DW_FORM_sdata
847 }
849 : {
850 # Label reference.
851 variable _cu_label
853 set new_value "[string range $value 1 end] - $_cu_label"
855 return DW_FORM_ref4
856 }
858 % {
859 # Label reference, an offset from .debug_info.
860 set new_value "[string range $value 1 end]"
862 return DW_FORM_ref_addr
863 }
865 default {
866 return ""
867 }
868 }
869 }
871 proc _default_form { attr } {
872 switch -exact -- $attr {
873 DW_AT_low_pc {
874 return DW_FORM_addr
875 }
876 DW_AT_producer -
877 DW_AT_comp_dir -
878 DW_AT_linkage_name -
879 DW_AT_MIPS_linkage_name -
880 DW_AT_name {
881 return DW_FORM_string
882 }
883 DW_AT_GNU_addr_base {
884 return DW_FORM_sec_offset
885 }
886 }
887 return ""
888 }
890 # Map NAME to its canonical form.
891 proc _map_name {name ary} {
892 variable $ary
894 if {[info exists ${ary}($name)]} {
895 set name [set ${ary}($name)]
896 }
898 return $name
899 }
901 proc _handle_attribute { attr_name attr_value attr_form } {
902 variable _abbrev_section
903 variable _constants
904 variable _cu_version
906 _handle_DW_FORM $attr_form $attr_value
908 _defer_output $_abbrev_section {
909 if { $attr_form eq "SPECIAL_expr" } {
910 if { $_cu_version < 4 } {
911 set attr_form_comment "DW_FORM_block"
912 } else {
913 set attr_form_comment "DW_FORM_exprloc"
914 }
915 } else {
916 set attr_form_comment $attr_form
917 }
918 _op .uleb128 $_constants($attr_name) $attr_name
919 _op .uleb128 $_constants($attr_form) $attr_form_comment
920 }
921 }
923 # Handle macro attribute MACRO_AT_range.
925 proc _handle_macro_at_range { attr_value } {
926 variable _cu_is_fission
928 if {[llength $attr_value] != 1} {
929 error "usage: MACRO_AT_range { func }"
930 }
932 set func [lindex $attr_value 0]
933 global srcdir subdir srcfile
934 set src ${srcdir}/${subdir}/${srcfile}
935 set result [function_range $func $src]
937 set form DW_FORM_addr
938 if { $_cu_is_fission } {
939 set form DW_FORM_GNU_addr_index
940 }
942 _handle_attribute DW_AT_low_pc [lindex $result 0] $form
943 _handle_attribute DW_AT_high_pc \
944 "[lindex $result 0] + [lindex $result 1]" $form
945 }
947 # Handle macro attribute MACRO_AT_func.
949 proc _handle_macro_at_func { attr_value } {
950 if {[llength $attr_value] != 1} {
951 error "usage: MACRO_AT_func { func file }"
952 }
953 _handle_attribute DW_AT_name [lindex $attr_value 0] DW_FORM_string
954 _handle_macro_at_range $attr_value
955 }
957 proc _handle_DW_TAG {tag_name {attrs {}} {children {}}} {
958 variable _abbrev_section
959 variable _abbrev_num
960 variable _constants
962 set has_children [expr {[string length $children] > 0}]
963 set my_abbrev [incr _abbrev_num]
965 # We somewhat wastefully emit a new abbrev entry for each tag.
966 # There's no reason for this other than laziness.
967 _defer_output $_abbrev_section {
968 _op .uleb128 $my_abbrev "Abbrev start"
969 _op .uleb128 $_constants($tag_name) $tag_name
970 _op .byte $has_children "has_children"
971 }
973 _op .uleb128 $my_abbrev "Abbrev ($tag_name)"
975 foreach attr $attrs {
976 set attr_name [_map_name [lindex $attr 0] _AT]
978 # When the length of ATTR is greater than 2, the last
979 # element of the list must be a form. The second through
980 # the penultimate elements are joined together and
981 # evaluated using subst. This allows constructs such as
982 # [gdb_target_symbol foo] to be used.
984 if {[llength $attr] > 2} {
985 set attr_value [uplevel 2 [list subst [join [lrange $attr 1 end-1]]]]
986 } else {
987 set attr_value [uplevel 2 [list subst [lindex $attr 1]]]
988 }
990 if { [string equal "MACRO_AT_func" $attr_name] } {
991 _handle_macro_at_func $attr_value
992 } elseif { [string equal "MACRO_AT_range" $attr_name] } {
993 _handle_macro_at_range $attr_value
994 } else {
995 if {[llength $attr] > 2} {
996 set attr_form [uplevel 2 [list subst [lindex $attr end]]]
998 if { [string index $attr_value 0] == ":" } {
999 # It is a label, get its value.
1000 _guess_form $attr_value attr_value
1001 }
1002 } else {
1003 set attr_form [_guess_form $attr_value attr_value]
1004 if { $attr_form eq "" } {
1005 set attr_form [_default_form $attr_name]
1006 }
1007 if { $attr_form eq "" } {
1008 error "No form for $attr_name $attr_value"
1009 }
1010 }
1011 set attr_form [_map_name $attr_form _FORM]
1013 _handle_attribute $attr_name $attr_value $attr_form
1014 }
1015 }
1017 _defer_output $_abbrev_section {
1018 # Terminator.
1019 _op .byte 0x0 "DW_AT - Terminator"
1020 _op .byte 0x0 "DW_FORM - Terminator"
1021 }
1023 if {$has_children} {
1024 uplevel 2 $children
1026 # Terminate children.
1027 _op .byte 0x0 "Terminate children"
1028 }
1029 }
1031 proc _emit {string} {
1032 variable _output_file
1033 variable _defer
1034 variable _deferred_output
1036 if {$_defer == ""} {
1037 puts $_output_file $string
1038 } else {
1039 append _deferred_output($_defer) ${string}\n
1040 }
1041 }
1043 proc _section {name {flags ""} {type ""}} {
1044 if {$flags == "" && $type == ""} {
1045 _emit " .section $name"
1046 } elseif {$type == ""} {
1047 _emit " .section $name, \"$flags\""
1048 } else {
1049 _emit " .section $name, \"$flags\", %$type"
1050 }
1051 }
1053 # SECTION_SPEC is a list of arguments to _section.
1054 proc _defer_output {section_spec body} {
1055 variable _defer
1056 variable _deferred_output
1058 set old_defer $_defer
1059 set _defer [lindex $section_spec 0]
1061 if {![info exists _deferred_output($_defer)]} {
1062 set _deferred_output($_defer) ""
1063 eval _section $section_spec
1064 }
1066 uplevel $body
1068 set _defer $old_defer
1069 }
1071 proc _defer_to_string {body} {
1072 variable _defer
1073 variable _deferred_output
1075 set old_defer $_defer
1076 set _defer temp
1078 set _deferred_output($_defer) ""
1080 uplevel $body
1082 set result $_deferred_output($_defer)
1083 unset _deferred_output($_defer)
1085 set _defer $old_defer
1086 return $result
1087 }
1089 proc _write_deferred_output {} {
1090 variable _output_file
1091 variable _deferred_output
1093 foreach section [array names _deferred_output] {
1094 # The data already has a newline.
1095 puts -nonewline $_output_file $_deferred_output($section)
1096 }
1098 # Save some memory.
1099 unset _deferred_output
1100 }
1102 proc _op {name value {comment ""}} {
1103 set text " ${name} ${value}"
1104 if {$comment != ""} {
1105 # Try to make stuff line up nicely.
1106 while {[string length $text] < 40} {
1107 append text " "
1108 }
1109 append text "/* ${comment} */"
1110 }
1111 _emit $text
1112 }
1114 proc _op_offset { size offset {comment ""} } {
1115 if { $size == 4 } {
1116 _op .4byte $offset $comment
1117 } elseif { $size == 8 } {
1118 if {[is_64_target]} {
1119 _op .8byte $offset $comment
1120 } else {
1121 # This allows us to emit 64-bit dwarf for
1122 # 32-bit targets.
1123 if { [target_endianness] == "little" } {
1124 _op .4byte $offset "$comment (lsw)"
1125 _op .4byte 0 "$comment (msw)"
1126 } else {
1127 _op .4byte 0 "$comment (msw)"
1128 _op .4byte $offset "$comment (lsw)"
1129 }
1130 }
1131 } else {
1132 error "Don't know how to handle offset size $size"
1133 }
1134 }
1136 proc _compute_label {name} {
1137 return ".L${name}"
1138 }
1140 # Return a name suitable for use as a label. If BASE_NAME is
1141 # specified, it is incorporated into the label name; this is to
1142 # make debugging the generated assembler easier. If BASE_NAME is
1143 # not specified a generic default is used. This proc does not
1144 # define the label; see 'define_label'. 'new_label' attempts to
1145 # ensure that label names are unique.
1146 proc new_label {{base_name label}} {
1147 variable _label_num
1149 return [_compute_label ${base_name}[incr _label_num]]
1150 }
1152 # Define a label named NAME. Ordinarily, NAME comes from a call
1153 # to 'new_label', but this is not required.
1154 proc define_label {name} {
1155 _emit "${name}:"
1156 }
1158 # A higher-level interface to label handling.
1159 #
1160 # ARGS is a list of label descriptors. Each one is either a
1161 # single element, or a list of two elements -- a name and some
1162 # text. For each descriptor, 'new_label' is invoked. If the list
1163 # form is used, the second element in the list is passed as an
1164 # argument. The label name is used to define a variable in the
1165 # enclosing scope; this can be used to refer to the label later.
1166 # The label name is also used to define a new proc whose name is
1167 # the label name plus a trailing ":". This proc takes a body as
1168 # an argument and can be used to define the label at that point;
1169 # then the body, if any, is evaluated in the caller's context.
1170 #
1171 # For example:
1172 #
1173 # declare_labels int_label
1174 # something { ... $int_label } ;# refer to the label
1175 # int_label: constant { ... } ;# define the label
1176 proc declare_labels {args} {
1177 foreach arg $args {
1178 set name [lindex $arg 0]
1179 set text [lindex $arg 1]
1181 if { $text == "" } {
1182 set text $name
1183 }
1185 upvar $name label_var
1186 set label_var [new_label $text]
1188 proc ${name}: {args} [format {
1189 define_label %s
1190 uplevel $args
1191 } $label_var]
1192 }
1193 }
1195 # Assign elements from LINE to the elements of an array named
1196 # "argvec" in the caller scope. The keys used are named in ARGS.
1197 # If the wrong number of elements appear in LINE, error.
1198 proc _get_args {line op args} {
1199 if {[llength $line] != [llength $args] + 1} {
1200 error "usage: $op [string toupper $args]"
1201 }
1203 upvar argvec argvec
1204 foreach var $args value [lreplace $line 0 0] {
1205 set argvec($var) $value
1206 }
1207 }
1209 # This is a miniature assembler for location expressions. It is
1210 # suitable for use in the attributes to a DIE. Its output is
1211 # prefixed with "=" to make it automatically use DW_FORM_block.
1212 #
1213 # BODY is split by lines, and each line is taken to be a list.
1214 #
1215 # DWARF_VERSION is the DWARF version for the section where the location
1216 # description is found.
1217 #
1218 # ADDR_SIZE is the length in bytes (4 or 8) of an address on the target
1219 # machine (typically found in the header of the section where the location
1220 # description is found).
1221 #
1222 # OFFSET_SIZE is the length in bytes (4 or 8) of an offset into a DWARF
1223 # section. This typically depends on whether 32-bit or 64-bit DWARF is
1224 # used, as indicated in the header of the section where the location
1225 # description is found.
1226 #
1227 # (FIXME should use 'info complete' here.)
1228 # Each list's first element is the opcode, either short or long
1229 # forms are accepted.
1230 # FIXME argument handling
1231 # FIXME move docs
1232 proc _location { body dwarf_version addr_size offset_size } {
1233 variable _constants
1235 foreach line [split $body \n] {
1236 # Ignore blank lines, and allow embedded comments.
1237 if {[lindex $line 0] == "" || [regexp -- {^[ \t]*#} $line]} {
1238 continue
1239 }
1240 set opcode [_map_name [lindex $line 0] _OP]
1241 _op .byte $_constants($opcode) $opcode
1243 array unset argvec *
1244 switch -exact -- $opcode {
1245 DW_OP_addr {
1246 _get_args $line $opcode size
1247 _op .${addr_size}byte $argvec(size)
1248 }
1250 DW_OP_GNU_addr_index {
1251 variable _debug_addr_index
1252 variable _cu_addr_size
1254 _op .uleb128 ${_debug_addr_index}
1255 incr _debug_addr_index
1257 _defer_output .debug_addr {
1258 _op .${_cu_addr_size}byte [lindex $line 1]
1259 }
1260 }
1262 DW_OP_regx {
1263 _get_args $line $opcode register
1264 _op .uleb128 $argvec(register)
1265 }
1267 DW_OP_pick -
1268 DW_OP_const1u -
1269 DW_OP_const1s {
1270 _get_args $line $opcode const
1271 _op .byte $argvec(const)
1272 }
1274 DW_OP_const2u -
1275 DW_OP_const2s {
1276 _get_args $line $opcode const
1277 _op .2byte $argvec(const)
1278 }
1280 DW_OP_const4u -
1281 DW_OP_const4s {
1282 _get_args $line $opcode const
1283 _op .4byte $argvec(const)
1284 }
1286 DW_OP_const8u -
1287 DW_OP_const8s {
1288 _get_args $line $opcode const
1289 _op .8byte $argvec(const)
1290 }
1292 DW_OP_constu {
1293 _get_args $line $opcode const
1294 _op .uleb128 $argvec(const)
1295 }
1296 DW_OP_consts {
1297 _get_args $line $opcode const
1298 _op .sleb128 $argvec(const)
1299 }
1301 DW_OP_plus_uconst {
1302 _get_args $line $opcode const
1303 _op .uleb128 $argvec(const)
1304 }
1306 DW_OP_piece {
1307 _get_args $line $opcode size
1308 _op .uleb128 $argvec(size)
1309 }
1311 DW_OP_bit_piece {
1312 _get_args $line $opcode size offset
1313 _op .uleb128 $argvec(size)
1314 _op .uleb128 $argvec(offset)
1315 }
1317 DW_OP_skip -
1318 DW_OP_bra {
1319 _get_args $line $opcode label
1320 _op .2byte $argvec(label)
1321 }
1323 DW_OP_implicit_value {
1324 set l1 [new_label "value_start"]
1325 set l2 [new_label "value_end"]
1326 _op .uleb128 "$l2 - $l1"
1327 define_label $l1
1328 foreach value [lrange $line 1 end] {
1329 switch -regexp -- $value {
1330 {^0x[[:xdigit:]]{1,2}$} {_op .byte $value}
1331 {^0x[[:xdigit:]]{4}$} {_op .2byte $value}
1332 {^0x[[:xdigit:]]{8}$} {_op .4byte $value}
1333 {^0x[[:xdigit:]]{16}$} {_op .8byte $value}
1334 default {
1335 error "bad value '$value' in DW_OP_implicit_value"
1336 }
1337 }
1338 }
1339 define_label $l2
1340 }
1342 DW_OP_implicit_pointer -
1343 DW_OP_GNU_implicit_pointer {
1344 _get_args $line $opcode label offset
1346 # Here label is a section offset.
1347 if { $dwarf_version == 2 } {
1348 _op .${addr_size}byte $argvec(label)
1349 } else {
1350 _op_offset $offset_size $argvec(label)
1351 }
1352 _op .sleb128 $argvec(offset)
1353 }
1355 DW_OP_GNU_variable_value {
1356 _get_args $line $opcode label
1358 # Here label is a section offset.
1359 if { $dwarf_version == 2 } {
1360 _op .${addr_size}byte $argvec(label)
1361 } else {
1362 _op_offset $offset_size $argvec(label)
1363 }
1364 }
1366 DW_OP_deref_size {
1367 _get_args $line $opcode size
1368 _op .byte $argvec(size)
1369 }
1371 DW_OP_bregx {
1372 _get_args $line $opcode register offset
1373 _op .uleb128 $argvec(register)
1374 _op .sleb128 $argvec(offset)
1375 }
1377 DW_OP_fbreg {
1378 _get_args $line $opcode offset
1379 _op .sleb128 $argvec(offset)
1380 }
1382 DW_OP_fbreg {
1383 _op .sleb128 [lindex $line 1]
1384 }
1386 default {
1387 if {[llength $line] > 1} {
1388 error "Unimplemented: operands in location for $opcode"
1389 }
1390 }
1391 }
1392 }
1393 }
1395 # Return a label that references the current position in the
1396 # .debug_addr table. When a user is creating split DWARF they
1397 # will define two CUs, the first will be the split DWARF content,
1398 # and the second will be the non-split stub CU. The split DWARF
1399 # CU fills in the .debug_addr section, but the non-split CU
1400 # includes a reference to the start of the section. The label
1401 # returned by this proc provides that reference.
1402 proc debug_addr_label {} {
1403 variable _debug_addr_index
1405 set lbl [new_label "debug_addr_idx_${_debug_addr_index}_"]
1406 _defer_output .debug_addr {
1407 define_label $lbl
1408 }
1409 return $lbl
1410 }
1412 # Emit a DWARF CU.
1413 # OPTIONS is a list with an even number of elements containing
1414 # option-name and option-value pairs.
1415 # Current options are:
1416 # is_64 0|1 - boolean indicating if you want to emit 64-bit DWARF
1417 # default = 0 (32-bit)
1418 # version n - DWARF version number to emit
1419 # default = 4
1420 # addr_size n - the size of addresses in bytes: 4, 8, or default
1421 # default = default
1422 # fission 0|1 - boolean indicating if generating Fission debug info
1423 # default = 0
1424 # label <label>
1425 # - string indicating label to be defined at the start
1426 # of the CU header.
1427 # default = ""
1428 # BODY is Tcl code that emits the DIEs which make up the body of
1429 # the CU. It is evaluated in the caller's context.
1430 proc cu {options body} {
1431 variable _constants
1432 variable _cu_count
1433 variable _abbrev_section
1434 variable _abbrev_num
1435 variable _cu_label
1436 variable _cu_version
1437 variable _cu_addr_size
1438 variable _cu_offset_size
1439 variable _cu_is_fission
1441 # Establish the defaults.
1442 set is_64 0
1443 set _cu_version 4
1444 set _cu_addr_size default
1445 set _cu_is_fission 0
1446 set section ".debug_info"
1447 set _abbrev_section ".debug_abbrev"
1448 set label ""
1450 foreach { name value } $options {
1451 set value [uplevel 1 "subst \"$value\""]
1452 switch -exact -- $name {
1453 is_64 { set is_64 $value }
1454 version { set _cu_version $value }
1455 addr_size { set _cu_addr_size $value }
1456 fission { set _cu_is_fission $value }
1457 label { set label $value }
1458 default { error "unknown option $name" }
1459 }
1460 }
1461 if {$_cu_addr_size == "default"} {
1462 if {[is_64_target]} {
1463 set _cu_addr_size 8
1464 } else {
1465 set _cu_addr_size 4
1466 }
1467 }
1468 set _cu_offset_size [expr { $is_64 ? 8 : 4 }]
1469 if { $_cu_is_fission } {
1470 set section ".debug_info.dwo"
1471 set _abbrev_section ".debug_abbrev.dwo"
1472 }
1474 if {$_cu_version < 4} {
1475 set _constants(SPECIAL_expr) $_constants(DW_FORM_block)
1476 } else {
1477 set _constants(SPECIAL_expr) $_constants(DW_FORM_exprloc)
1478 }
1480 _section $section
1482 set cu_num [incr _cu_count]
1483 set my_abbrevs [_compute_label "abbrev${cu_num}_begin"]
1484 set _abbrev_num 1
1486 set _cu_label [_compute_label "cu${cu_num}_begin"]
1487 set start_label [_compute_label "cu${cu_num}_start"]
1488 set end_label [_compute_label "cu${cu_num}_end"]
1490 if { $label != "" } {
1491 upvar $label my_label
1492 set my_label $_cu_label
1493 }
1495 define_label $_cu_label
1496 if {$is_64} {
1497 _op .4byte 0xffffffff
1498 _op .8byte "$end_label - $start_label"
1499 } else {
1500 _op .4byte "$end_label - $start_label"
1501 }
1502 define_label $start_label
1503 _op .2byte $_cu_version Version
1505 # The CU header for DWARF 4 and 5 are slightly different.
1506 if { $_cu_version == 5 } {
1507 _op .byte 0x1 "DW_UT_compile"
1508 _op .byte $_cu_addr_size "Pointer size"
1509 _op_offset $_cu_offset_size $my_abbrevs Abbrevs
1510 } else {
1511 _op_offset $_cu_offset_size $my_abbrevs Abbrevs
1512 _op .byte $_cu_addr_size "Pointer size"
1513 }
1515 _defer_output $_abbrev_section {
1516 define_label $my_abbrevs
1517 }
1519 uplevel $body
1521 _defer_output $_abbrev_section {
1522 # Emit the terminator.
1523 _op .byte 0x0 "Abbrev end - Terminator"
1524 }
1526 define_label $end_label
1527 }
1529 # Emit a DWARF TU.
1530 # OPTIONS is a list with an even number of elements containing
1531 # option-name and option-value pairs.
1532 # Current options are:
1533 # is_64 0|1 - boolean indicating if you want to emit 64-bit DWARF
1534 # default = 0 (32-bit)
1535 # version n - DWARF version number to emit
1536 # default = 4
1537 # addr_size n - the size of addresses in bytes: 4, 8, or default
1538 # default = default
1539 # fission 0|1 - boolean indicating if generating Fission debug info
1540 # default = 0
1541 # SIGNATURE is the 64-bit signature of the type.
1542 # TYPE_LABEL is the label of the type defined by this TU,
1543 # or "" if there is no type (i.e., type stubs in Fission).
1544 # BODY is Tcl code that emits the DIEs which make up the body of
1545 # the TU. It is evaluated in the caller's context.
1546 proc tu {options signature type_label body} {
1547 variable _cu_count
1548 variable _abbrev_section
1549 variable _abbrev_num
1550 variable _cu_label
1551 variable _cu_version
1552 variable _cu_addr_size
1553 variable _cu_offset_size
1554 variable _cu_is_fission
1556 # Establish the defaults.
1557 set is_64 0
1558 set _cu_version 4
1559 set _cu_addr_size default
1560 set _cu_is_fission 0
1561 set section ".debug_types"
1562 set _abbrev_section ".debug_abbrev"
1563 set label ""
1565 foreach { name value } $options {
1566 set value [uplevel 1 "subst \"$value\""]
1567 switch -exact -- $name {
1568 is_64 { set is_64 $value }
1569 version { set _cu_version $value }
1570 addr_size { set _cu_addr_size $value }
1571 fission { set _cu_is_fission $value }
1572 label { set label $value }
1573 default { error "unknown option $name" }
1574 }
1575 }
1576 if {$_cu_addr_size == "default"} {
1577 if {[is_64_target]} {
1578 set _cu_addr_size 8
1579 } else {
1580 set _cu_addr_size 4
1581 }
1582 }
1583 set _cu_offset_size [expr { $is_64 ? 8 : 4 }]
1584 if { $_cu_version == 5 } {
1585 set section ".debug_info"
1586 }
1587 if { $_cu_is_fission } {
1588 set section "$section.dwo"
1589 set _abbrev_section "$section.dwo"
1590 }
1592 _section $section
1594 set cu_num [incr _cu_count]
1595 set my_abbrevs [_compute_label "abbrev${cu_num}_begin"]
1596 set _abbrev_num 1
1598 set _cu_label [_compute_label "cu${cu_num}_begin"]
1599 set start_label [_compute_label "cu${cu_num}_start"]
1600 set end_label [_compute_label "cu${cu_num}_end"]
1602 if { $label != "" } {
1603 upvar $label my_label
1604 set my_label $_cu_label
1605 }
1607 define_label $_cu_label
1608 if {$is_64} {
1609 _op .4byte 0xffffffff
1610 _op .8byte "$end_label - $start_label"
1611 } else {
1612 _op .4byte "$end_label - $start_label"
1613 }
1614 define_label $start_label
1615 _op .2byte $_cu_version Version
1617 # The CU header for DWARF 4 and 5 are slightly different.
1618 if { $_cu_version == 5 } {
1619 _op .byte 0x2 "DW_UT_type"
1620 _op .byte $_cu_addr_size "Pointer size"
1621 _op_offset $_cu_offset_size $my_abbrevs Abbrevs
1622 } else {
1623 _op_offset $_cu_offset_size $my_abbrevs Abbrevs
1624 _op .byte $_cu_addr_size "Pointer size"
1625 }
1627 _op .8byte $signature Signature
1628 if { $type_label != "" } {
1629 uplevel declare_labels $type_label
1630 upvar $type_label my_type_label
1631 if {$is_64} {
1632 _op .8byte "$my_type_label - $_cu_label"
1633 } else {
1634 _op .4byte "$my_type_label - $_cu_label"
1635 }
1636 } else {
1637 if {$is_64} {
1638 _op .8byte 0
1639 } else {
1640 _op .4byte 0
1641 }
1642 }
1644 _defer_output $_abbrev_section {
1645 define_label $my_abbrevs
1646 }
1648 uplevel $body
1650 _defer_output $_abbrev_section {
1651 # Emit the terminator.
1652 _op .byte 0x0 "Abbrev end - Terminator"
1653 }
1655 define_label $end_label
1656 }
1658 # Emit a DWARF .debug_ranges unit.
1659 # OPTIONS is a list with an even number of elements containing
1660 # option-name and option-value pairs.
1661 # Current options are:
1662 # is_64 0|1 - boolean indicating if you want to emit 64-bit DWARF
1663 # default = 0 (32-bit)
1664 #
1665 # BODY is Tcl code that emits the content of the .debug_ranges
1666 # unit, it is evaluated in the caller's context.
1667 proc ranges {options body} {
1668 variable _debug_ranges_64_bit
1670 foreach { name value } $options {
1671 switch -exact -- $name {
1672 is_64 { set _debug_ranges_64_bit [subst $value] }
1673 default { error "unknown option $name" }
1674 }
1675 }
1677 set section ".debug_ranges"
1678 _section $section
1680 proc sequence { body } {
1681 variable _debug_ranges_64_bit
1683 # Emit the sequence of addresses.
1685 proc base { addr } {
1686 variable _debug_ranges_64_bit
1688 if {$_debug_ranges_64_bit} {
1689 _op .8byte 0xffffffffffffffff "Base Marker"
1690 _op .8byte $addr "Base Address"
1691 } else {
1692 _op .4byte 0xffffffff "Base Marker"
1693 _op .4byte $addr "Base Address"
1694 }
1695 }
1697 proc range { start end } {
1698 variable _debug_ranges_64_bit
1700 if {$_debug_ranges_64_bit} {
1701 _op .8byte $start "Start Address"
1702 _op .8byte $end "End Address"
1703 } else {
1704 _op .4byte $start "Start Address"
1705 _op .4byte $end "End Address"
1706 }
1707 }
1709 uplevel $body
1711 # End of the sequence.
1712 if {$_debug_ranges_64_bit} {
1713 _op .8byte 0x0 "End of Sequence Marker (Part 1)"
1714 _op .8byte 0x0 "End of Sequence Marker (Part 2)"
1715 } else {
1716 _op .4byte 0x0 "End of Sequence Marker (Part 1)"
1717 _op .4byte 0x0 "End of Sequence Marker (Part 2)"
1718 }
1719 }
1721 uplevel $body
1722 }
1724 # Emit a DWARF .debug_rnglists section.
1725 #
1726 # The target address size is based on the current target's address size.
1727 #
1728 # BODY must be Tcl code that emits the content of the section. It is
1729 # evaluated in the caller's context.
1730 #
1731 # The `is-64 true|false` options tells whether to use 64-bit DWARF instead
1732 # of 32-bit DWARF. The default is 32-bit.
1734 proc rnglists { options body } {
1735 variable _debug_rnglists_addr_size
1736 variable _debug_rnglists_offset_size
1737 variable _debug_rnglists_is_64_dwarf
1739 parse_options {{"is-64" "false"}}
1741 if [is_64_target] {
1742 set _debug_rnglists_addr_size 8
1743 } else {
1744 set _debug_rnglists_addr_size 4
1745 }
1747 if { ${is-64} } {
1748 set _debug_rnglists_offset_size 8
1749 set _debug_rnglists_is_64_dwarf true
1750 } else {
1751 set _debug_rnglists_offset_size 4
1752 set _debug_rnglists_is_64_dwarf false
1753 }
1755 _section ".debug_rnglists"
1757 # Count of tables in the section.
1758 variable _debug_rnglists_table_count 0
1760 # Compute the label name for list at index LIST_IDX, for the current
1761 # table.
1763 proc _compute_list_label { list_idx } {
1764 variable _debug_rnglists_table_count
1766 return ".Lrnglists_table_${_debug_rnglists_table_count}_list_${list_idx}"
1767 }
1769 with_override Dwarf::table Dwarf::_rnglists_table {
1770 uplevel $body
1771 }
1772 }
1774 # Generate one rnglists table (header + offset array + range lists).
1775 #
1776 # This proc is meant to be used within proc rnglists' body. It is made
1777 # available as `table` while inside proc rnglists' body.
1778 #
1779 # BODY must be Tcl code that emits the content of the table. It may call
1780 # the LIST_ procedure to generate rnglists. It is evaluated in the
1781 # caller's context.
1782 #
1783 # The `post-header-label` option can be used to define a label just after
1784 # the header of the table. This is the label that a DW_AT_rnglists_base
1785 # attribute will usually refer to.
1786 #
1787 # The `with-offset-array true|false` option can be used to control whether
1788 # the headers of the location list tables have an array of offset. The
1789 # default is true.
1791 proc _rnglists_table { options body } {
1792 variable _debug_rnglists_table_count
1793 variable _debug_rnglists_addr_size
1794 variable _debug_rnglists_offset_size
1795 variable _debug_rnglists_is_64_dwarf
1797 parse_options {
1798 {post-header-label ""}
1799 {with-offset-array true}
1800 }
1802 # Count of lists in the table.
1803 variable _debug_rnglists_list_count 0
1805 # Generate the lists ops first, because we need to know how many
1806 # lists there are to generate the header and offset table.
1807 set lists_ops [_defer_to_string {
1808 with_override Dwarf::list_ Dwarf::_rnglists_list {
1809 uplevel $body
1810 }
1811 }]
1813 set post_unit_len_label \
1814 [_compute_label "rnglists_table_${_debug_rnglists_table_count}_post_unit_len"]
1815 set post_header_label \
1816 [_compute_label "rnglists_table_${_debug_rnglists_table_count}_post_header"]
1817 set table_end_label \
1818 [_compute_label "rnglists_table_${_debug_rnglists_table_count}_end"]
1820 # Emit the table header.
1821 if { $_debug_rnglists_is_64_dwarf } {
1822 _op .4byte 0xffffffff "unit length 1/2"
1823 _op .8byte "$table_end_label - $post_unit_len_label" "unit length 2/2"
1824 } else {
1825 _op .4byte "$table_end_label - $post_unit_len_label" "unit length"
1826 }
1828 define_label $post_unit_len_label
1830 _op .2byte 5 "dwarf version"
1831 _op .byte $_debug_rnglists_addr_size "address size"
1832 _op .byte 0 "segment selector size"
1834 if { ${with-offset-array} } {
1835 _op .4byte "$_debug_rnglists_list_count" "offset entry count"
1836 } else {
1837 _op .4byte 0 "offset entry count"
1838 }
1840 define_label $post_header_label
1842 # Define the user post-header label, if provided.
1843 if { ${post-header-label} != "" } {
1844 define_label ${post-header-label}
1845 }
1847 # Emit the offset array.
1848 if { ${with-offset-array} } {
1849 for {set list_idx 0} {$list_idx < $_debug_rnglists_list_count} {incr list_idx} {
1850 set list_label [_compute_list_label $list_idx]
1851 _op_offset $_debug_rnglists_offset_size \
1852 "$list_label - $post_header_label" \
1853 "offset of list $list_idx"
1854 }
1855 }
1857 # Emit the actual list data.
1858 _emit "$lists_ops"
1860 define_label $table_end_label
1862 incr _debug_rnglists_table_count
1863 }
1865 # Generate one rnglists range list.
1866 #
1867 # This proc is meant to be used within proc _rnglists_table's body. It is
1868 # made available as `list_` while inside proc _rnglists_table's body.
1869 #
1870 # BODY may call the various procs defined below to generate list entries.
1871 # They correspond to the range list entry kinds described in section 2.17.3
1872 # of the DWARF 5 spec.
1873 #
1874 # To define a label pointing to the beginning of the list, use the
1875 # conventional way of declaring and defining labels:
1876 #
1877 # declare_labels the_list
1878 #
1879 # the_list: list_ { ... }
1881 proc _rnglists_list { body } {
1882 variable _debug_rnglists_list_count
1884 # Define a label for this list. It is used to build the offset
1885 # array later.
1886 set list_label [_compute_list_label $_debug_rnglists_list_count]
1887 define_label $list_label
1889 with_override Dwarf::start_end Dwarf::_rnglists_start_end {
1890 uplevel $body
1891 }
1893 # Emit end of list.
1894 _op .byte 0x00 "DW_RLE_end_of_list"
1896 incr _debug_rnglists_list_count
1897 }
1899 # Emit a rnglists DW_RLE_start_end entry.
1900 #
1901 # This proc is meant to be used within proc _rnglists_list's body. It is
1902 # made available as `start_end` while inside proc _rnglists_list's body.
1904 proc _rnglists_start_end { start end } {
1905 variable _debug_rnglists_addr_size
1907 _op .byte 0x06 "DW_RLE_start_end"
1908 _op .${_debug_rnglists_addr_size}byte $start "start"
1909 _op .${_debug_rnglists_addr_size}byte $end "end"
1910 }
1912 # Emit a DWARF .debug_loclists section.
1913 #
1914 # The target address size is based on the current target's address size.
1915 #
1916 # BODY must be Tcl code that emits the content of the section. It is
1917 # evaluated in the caller's context.
1918 #
1919 # The `is-64 true|false` options tells whether to use 64-bit DWARF instead
1920 # of 32-bit DWARF. The default is 32-bit.
1922 proc loclists { options body } {
1923 variable _debug_loclists_addr_size
1924 variable _debug_loclists_offset_size
1925 variable _debug_loclists_is_64_dwarf
1927 parse_options {{"is-64" "false"}}
1929 if [is_64_target] {
1930 set _debug_loclists_addr_size 8
1931 } else {
1932 set _debug_loclists_addr_size 4
1933 }
1935 if { ${is-64} } {
1936 set _debug_loclists_offset_size 8
1937 set _debug_loclists_is_64_dwarf true
1938 } else {
1939 set _debug_loclists_offset_size 4
1940 set _debug_loclists_is_64_dwarf false
1941 }
1943 _section ".debug_loclists"
1945 # Count of tables in the section.
1946 variable _debug_loclists_table_count 0
1948 # Compute the label name for list at index LIST_IDX, for the current
1949 # table.
1951 proc _compute_list_label { list_idx } {
1952 variable _debug_loclists_table_count
1954 return ".Lloclists_table_${_debug_loclists_table_count}_list_${list_idx}"
1955 }
1957 with_override Dwarf::table Dwarf::_loclists_table {
1958 uplevel $body
1959 }
1960 }
1962 # Generate one loclists table (header + offset array + location lists).
1963 #
1964 # This proc is meant to be used within proc loclists' body. It is made
1965 # available as `table` while inside proc rnglists' body.
1966 #
1967 # BODY must be Tcl code that emits the content of the table. It may call
1968 # the LIST_ procedure to generate rnglists. It is evaluated in the
1969 # caller's context.
1970 #
1971 # The `post-header-label` option can be used to define a label just after
1972 # the header of the table. This is the label that a DW_AT_loclists_base
1973 # attribute will usually refer to.
1974 #
1975 # The `with-offset-array true|false` option can be used to control
1976 # whether the headers of the location list tables have an array of
1977 # offset. The default is true.
1979 proc _loclists_table { options body } {
1980 variable _debug_loclists_table_count
1981 variable _debug_loclists_addr_size
1982 variable _debug_loclists_offset_size
1983 variable _debug_loclists_is_64_dwarf
1985 parse_options {
1986 {post-header-label ""}
1987 {with-offset-array true}
1988 }
1990 # Count of lists in the table.
1991 variable _debug_loclists_list_count 0
1993 # Generate the lists ops first, because we need to know how many
1994 # lists there are to generate the header and offset table.
1995 set lists_ops [_defer_to_string {
1996 with_override Dwarf::list_ Dwarf::_loclists_list {
1997 uplevel $body
1998 }
1999 }]
2001 set post_unit_len_label \
2002 [_compute_label "loclists_table_${_debug_loclists_table_count}_post_unit_len"]
2003 set post_header_label \
2004 [_compute_label "loclists_table_${_debug_loclists_table_count}_post_header"]
2005 set table_end_label \
2006 [_compute_label "loclists_table_${_debug_loclists_table_count}_end"]
2008 # Emit the table header.
2009 if { $_debug_loclists_is_64_dwarf } {
2010 _op .4byte 0xffffffff "unit length 1/2"
2011 _op .8byte "$table_end_label - $post_unit_len_label" "unit length 2/2"
2012 } else {
2013 _op .4byte "$table_end_label - $post_unit_len_label" "unit length"
2014 }
2016 define_label $post_unit_len_label
2018 _op .2byte 5 "DWARF version"
2019 _op .byte $_debug_loclists_addr_size "address size"
2020 _op .byte 0 "segment selector size"
2022 if { ${with-offset-array} } {
2023 _op .4byte "$_debug_loclists_list_count" "offset entry count"
2024 } else {
2025 _op .4byte 0 "offset entry count"
2026 }
2028 define_label $post_header_label
2030 # Define the user post-header label, if provided.
2031 if { ${post-header-label} != "" } {
2032 define_label ${post-header-label}
2033 }
2035 # Emit the offset array.
2036 if { ${with-offset-array} } {
2037 for {set list_idx 0} {$list_idx < $_debug_loclists_list_count} {incr list_idx} {
2038 set list_label [_compute_list_label $list_idx]
2039 _op_offset $_debug_loclists_offset_size \
2040 "$list_label - $post_header_label" \
2041 "offset of list $list_idx"
2042 }
2043 }
2045 # Emit the actual list data.
2046 _emit "$lists_ops"
2048 define_label $table_end_label
2050 incr _debug_loclists_table_count
2051 }
2053 # Generate one loclists location list.
2054 #
2055 # This proc is meant to be used within proc _loclists_table's body. It is
2056 # made available as `list_` while inside proc _loclists_table's body.
2057 #
2058 # BODY may call the various procs defined below to generate list
2059 # entries. They correspond to the location list entry kinds
2060 # described in section 2.6.2 of the DWARF 5 spec.
2061 #
2062 # To define a label pointing to the beginning of the list, use
2063 # the conventional way of declaring and defining labels:
2064 #
2065 # declare_labels the_list
2066 #
2067 # the_list: list_ {
2068 # ...
2069 # }
2071 proc _loclists_list { body } {
2072 variable _debug_loclists_list_count
2074 # Count the location descriptions in this list.
2075 variable _debug_loclists_locdesc_count 0
2077 # Define a label for this list. It is used to build the offset
2078 # array later.
2079 set list_label [_compute_list_label $_debug_loclists_list_count]
2080 define_label $list_label
2082 with_override Dwarf::start_length Dwarf::_loclists_start_length {
2083 with_override Dwarf::base_address Dwarf::_loclists_base_address {
2084 with_override Dwarf::start_end Dwarf::_loclists_start_end {
2085 uplevel $body
2086 }}}
2088 # Emit end of list.
2089 _op .byte 0x00 "DW_LLE_end_of_list"
2091 incr _debug_loclists_list_count
2092 }
2094 # Emit a DW_LLE_start_length entry.
2095 #
2096 # This proc is meant to be used within proc _loclists_list's body. It is
2097 # made available as `start_length` while inside proc _loclists_list's body.
2099 proc _loclists_start_length { start length locdesc } {
2100 variable _debug_loclists_is_64_dwarf
2101 variable _debug_loclists_addr_size
2102 variable _debug_loclists_offset_size
2103 variable _debug_loclists_table_count
2104 variable _debug_loclists_list_count
2105 variable _debug_loclists_locdesc_count
2107 set locdesc [uplevel [list subst $locdesc]]
2109 _op .byte 0x08 "DW_LLE_start_length"
2111 # Start and end of the address range.
2112 _op .${_debug_loclists_addr_size}byte $start "start"
2113 _op .uleb128 $length "length"
2115 # Length of location description.
2116 set locdesc_start_label ".Lloclists_table_${_debug_loclists_table_count}_list_${_debug_loclists_list_count}_locdesc_${_debug_loclists_locdesc_count}_start"
2117 set locdesc_end_label ".Lloclists_table_${_debug_loclists_table_count}_list_${_debug_loclists_list_count}_locdesc_${_debug_loclists_locdesc_count}_end"
2118 _op .uleb128 "$locdesc_end_label - $locdesc_start_label" "locdesc length"
2120 define_label $locdesc_start_label
2121 set dwarf_version 5
2122 _location $locdesc $dwarf_version $_debug_loclists_addr_size $_debug_loclists_offset_size
2123 define_label $locdesc_end_label
2125 incr _debug_loclists_locdesc_count
2126 }
2128 # Emit a DW_LLE_start_end entry.
2129 #
2130 # This proc is meant to be used within proc _loclists_list's body. It is
2131 # made available as `start_end` while inside proc _loclists_list's body.
2133 proc _loclists_start_end { start end locdesc } {
2134 variable _debug_loclists_is_64_dwarf
2135 variable _debug_loclists_addr_size
2136 variable _debug_loclists_offset_size
2137 variable _debug_loclists_table_count
2138 variable _debug_loclists_list_count
2139 variable _debug_loclists_locdesc_count
2141 set locdesc [uplevel [list subst $locdesc]]
2143 _op .byte 0x07 "DW_LLE_start_end"
2145 # Start and end of the address range.
2146 _op .${_debug_loclists_addr_size}byte $start "start"
2147 _op .${_debug_loclists_addr_size}byte $end "end"
2149 # Length of location description.
2150 set locdesc_start_label ".Lloclists_table_${_debug_loclists_table_count}_list_${_debug_loclists_list_count}_locdesc_${_debug_loclists_locdesc_count}_start"
2151 set locdesc_end_label ".Lloclists_table_${_debug_loclists_table_count}_list_${_debug_loclists_list_count}_locdesc_${_debug_loclists_locdesc_count}_end"
2152 _op .uleb128 "$locdesc_end_label - $locdesc_start_label" "locdesc length"
2154 define_label $locdesc_start_label
2155 set dwarf_version 5
2156 _location $locdesc $dwarf_version $_debug_loclists_addr_size $_debug_loclists_offset_size
2157 define_label $locdesc_end_label
2159 incr _debug_loclists_locdesc_count
2160 }
2162 # Emit a DW_LLE_base_address entry.
2163 proc _loclists_base_address {addr} {
2164 variable _debug_loclists_addr_size
2165 variable _debug_loclists_locdesc_count
2166 _op .byte 0x06 "DW_LLE_base_address"
2167 _op .${_debug_loclists_addr_size}byte $addr "base_address"
2168 incr _debug_loclists_locdesc_count
2169 }
2171 # Emit a DWARF .debug_macro section.
2172 #
2173 # BODY must be Tcl code that emits the content of the section. It is
2174 # evaluated in the caller's context. The body can use the `unit` proc
2175 # (see `_macro_unit`) to generate macro units.
2177 proc macro { body } {
2178 _section ".debug_macro"
2180 with_override Dwarf::unit Dwarf::_macro_unit {
2181 uplevel $body
2182 }
2183 }
2185 # Generate one macro unit.
2186 #
2187 # This proc is meant to be used within proc macro's body. It is made
2188 # available as `unit` while inside proc macro's body.
2189 #
2190 # BODY must be Tcl code that emits the content of the unit. It may call
2191 # procedures defined below, prefixed with `_macro_unit_`, to generate the
2192 # unit's content. It is evaluated in the caller's context.
2193 #
2194 # The `is-64 true|false` options tells whether to use 64-bit DWARF instead
2195 # of 32-bit DWARF. The default is 32-bit.
2196 #
2197 # If specified, the `debug-line-offset-label` option is the name of a label
2198 # to use for the unit header's `debug_line_offset` field value. If
2199 # omitted, the unit header will not contain the `debug_line_offset` field.
2201 proc _macro_unit { options body } {
2202 parse_options {
2203 {"is-64" "false"}
2204 {"debug-line-offset-label" ""}
2205 }
2207 _op .2byte 5 "version"
2209 # Flags:
2210 #
2211 # offset_size_flag = set if is-64 is true
2212 # debug_line_offset_flag = set if debug-line-offset-label is set
2213 # opcode_operands_table_flag = 0
2214 set flags 0
2216 if { ${is-64} } {
2217 set flags [expr $flags | 0x1]
2218 }
2220 if { ${debug-line-offset-label} != "" } {
2221 set flags [expr $flags | 0x2]
2222 }
2224 _op .byte $flags "flags"
2226 if { ${debug-line-offset-label} != "" } {
2227 _op_offset [expr ${is-64} ? 8 : 4] ${debug-line-offset-label} \
2228 "debug_line offset"
2229 }
2231 with_override Dwarf::define Dwarf::_macro_unit_define {
2232 with_override Dwarf::start_file Dwarf::_macro_unit_start_file {
2233 with_override Dwarf::end_file Dwarf::_macro_unit_end_file {
2234 uplevel $body
2235 }}}
2236 }
2238 # Emit a DW_MACRO_define entry.
2240 proc _macro_unit_define { lineno text } {
2241 _op .byte 0x1 "DW_MACRO_define"
2242 _op .uleb128 $lineno "Line number"
2243 _op .asciz "\"$text\"" "Macro definition"
2244 }
2246 # Emit a DW_MACRO_start_file entry.
2248 proc _macro_unit_start_file { lineno file_idx } {
2249 _op .byte 0x3 "DW_MACRO_start_file"
2250 _op .uleb128 $lineno
2251 _op .uleb128 $file_idx
2252 }
2254 # Emit a DW_MACRO_end_file entry.
2256 proc _macro_unit_end_file {} {
2257 _op .byte 0x4 "DW_MACRO_end_file"
2258 }
2260 # Emit a DWARF .debug_line unit.
2261 # OPTIONS is a list with an even number of elements containing
2262 # option-name and option-value pairs.
2263 # Current options are:
2264 # is_64 0|1 - boolean indicating if you want to emit 64-bit DWARF
2265 # default = 0 (32-bit)
2266 # version n - DWARF version number to emit
2267 # default = 4
2268 # addr_size n - the size of addresses in bytes: 4, 8, or default
2269 # default = default
2270 # seg_sel_size n
2271 # - the size of segment selector_size in bytes:
2272 # default = 0
2273 #
2274 # LABEL is the label of the current unit (which is probably
2275 # referenced by a DW_AT_stmt_list), or "" if there is no such
2276 # label.
2277 #
2278 # BODY is Tcl code that emits the parts which make up the body of
2279 # the line unit. It is evaluated in the caller's context. The
2280 # following commands are available for the BODY section:
2281 #
2282 # include_dir "dirname" -- adds a new include directory
2283 #
2284 # file_name "file.c" idx -- adds a new file name. IDX is a
2285 # 1-based index referencing an include directory or 0 for
2286 # current directory.
2288 proc lines {options label body} {
2289 variable _line_count
2290 variable _line_include_dirs
2291 variable _line_file_names
2292 variable _line_header_finalized
2293 variable _line_header_end_label
2294 variable _line_unit_version
2295 variable _line_is_64
2296 variable _line_string_form
2298 # Establish the defaults.
2299 set _line_is_64 0
2300 set _line_unit_version 4
2301 set _unit_addr_size default
2302 set _line_include_dirs {}
2303 set _line_file_names {}
2304 set _line_header_finalized 0
2305 set _default_is_stmt 1
2306 set _seg_sel_size 0
2307 #set _line_string_form string
2308 set _line_string_form line_strp
2310 foreach { name value } $options {
2311 switch -exact -- $name {
2312 is_64 { set _line_is_64 $value }
2313 version { set _line_unit_version $value }
2314 addr_size { set _unit_addr_size $value }
2315 seg_sel_size { set _seg_sel_size $value }
2316 default_is_stmt { set _default_is_stmt $value }
2317 string_form { set _line_string_form $value }
2318 default { error "unknown option $name" }
2319 }
2320 }
2321 if {$_unit_addr_size == "default"} {
2322 if {[is_64_target]} {
2323 set _unit_addr_size 8
2324 } else {
2325 set _unit_addr_size 4
2326 }
2327 }
2329 set unit_num [incr _line_count]
2331 set section ".debug_line"
2332 _section $section
2334 if { "$label" != "" } {
2335 # Define the user-provided label at this point.
2336 $label:
2337 }
2339 set unit_len_label [_compute_label "line${_line_count}_start"]
2340 set unit_end_label [_compute_label "line${_line_count}_end"]
2341 set header_len_label [_compute_label "line${_line_count}_header_start"]
2342 set _line_header_end_label [_compute_label "line${_line_count}_header_end"]
2344 if {$_line_is_64} {
2345 _op .4byte 0xffffffff
2346 _op .8byte "$unit_end_label - $unit_len_label" "unit_length"
2347 } else {
2348 _op .4byte "$unit_end_label - $unit_len_label" "unit_length"
2349 }
2351 define_label $unit_len_label
2353 _op .2byte $_line_unit_version version
2355 if { $_line_unit_version >= 5 } {
2356 _op .byte $_unit_addr_size "address_size"
2357 # Hardcode to 0 for now.
2358 _op .byte $_seg_sel_size "seg_sel_size"
2359 }
2361 if {$_line_is_64} {
2362 _op .8byte "$_line_header_end_label - $header_len_label" "header_length"
2363 } else {
2364 _op .4byte "$_line_header_end_label - $header_len_label" "header_length"
2365 }
2367 define_label $header_len_label
2369 _op .byte 1 "minimum_instruction_length"
2370 if { $_line_unit_version >= 4 } {
2371 # Assume non-VLIW for now.
2372 _op .byte 1 "maximum_operations_per_instruction"
2373 }
2374 _op .byte $_default_is_stmt "default_is_stmt"
2375 _op .byte 1 "line_base"
2376 _op .byte 1 "line_range"
2377 _op .byte 11 "opcode_base"
2379 # The standard_opcode_lengths table. The number of arguments
2380 # for each of the standard opcodes. Generating 10 entries here
2381 # matches the use of 11 in the opcode_base above. These 10
2382 # entries match the 9 standard opcodes for DWARF2 plus
2383 # DW_LNS_prologue_end from DWARF3.
2384 _op .byte 0 "standard opcode 1"
2385 _op .byte 1 "standard opcode 2"
2386 _op .byte 1 "standard opcode 3"
2387 _op .byte 1 "standard opcode 4"
2388 _op .byte 1 "standard opcode 5"
2389 _op .byte 0 "standard opcode 6"
2390 _op .byte 0 "standard opcode 7"
2391 _op .byte 0 "standard opcode 8"
2392 _op .byte 1 "standard opcode 9"
2393 _op .byte 0 "standard opcode 10"
2395 # Add a directory entry to the line table header's directory table.
2396 #
2397 # Return the index by which this entry can be referred to.
2398 proc include_dir {dirname} {
2399 variable _line_include_dirs
2400 lappend _line_include_dirs $dirname
2402 if { $Dwarf::_line_unit_version >= 5 } {
2403 return [expr [llength $_line_include_dirs] - 1]
2404 } else {
2405 return [llength $_line_include_dirs]
2406 }
2407 }
2409 # Add a file name entry to the line table header's file names table.
2410 #
2411 # Return the index by which this entry can be referred to.
2412 proc file_name {filename diridx} {
2413 variable _line_file_names
2414 lappend _line_file_names $filename $diridx
2416 if { $Dwarf::_line_unit_version >= 5 } {
2417 return [expr [llength $_line_file_names] - 1]
2418 } else {
2419 return [llength $_line_file_names]
2420 }
2421 }
2423 proc _line_finalize_header {} {
2424 variable _line_header_finalized
2425 if { $_line_header_finalized } {
2426 return
2427 }
2428 set _line_header_finalized 1
2430 variable _line_include_dirs
2431 variable _line_file_names
2433 variable _line_unit_version
2434 variable _line_is_64
2435 variable _line_string_form
2436 if { $_line_unit_version >= 5 } {
2437 _op .byte 1 "directory_entry_format_count"
2438 _op .uleb128 1 \
2439 "directory_entry_format (content type code: DW_LNCT_path)"
2440 switch $_line_string_form {
2441 string {
2442 _op .uleb128 0x08 \
2443 "directory_entry_format (form: DW_FORM_string)"
2444 }
2445 line_strp {
2446 _op .uleb128 0x1f \
2447 "directory_entry_format (form: DW_FORM_line_strp)"
2448 }
2449 }
2451 set nr_dirs [llength $_line_include_dirs]
2452 _op .byte $nr_dirs "directory_count"
2454 foreach dirname $_line_include_dirs {
2455 switch $_line_string_form {
2456 string {
2457 _op .ascii [_quote $dirname]
2458 }
2459 line_strp {
2460 declare_labels string_ptr
2461 _defer_output .debug_line_str {
2462 string_ptr:
2463 _op .ascii [_quote $dirname]
2464 }
2465 _op_offset [expr $_line_is_64 ? 8 : 4] $string_ptr
2466 }
2467 }
2468 }
2470 _op .byte 2 "file_name_entry_format_count"
2471 _op .uleb128 1 \
2472 "file_name_entry_format (content type code: DW_LNCT_path)"
2473 switch $_line_string_form {
2474 string {
2475 _op .uleb128 0x08 \
2476 "directory_entry_format (form: DW_FORM_string)"
2477 }
2478 line_strp {
2479 _op .uleb128 0x1f \
2480 "directory_entry_format (form: DW_FORM_line_strp)"
2481 }
2482 }
2483 _op .uleb128 2 \
2484 "file_name_entry_format (content type code: DW_LNCT_directory_index)"
2485 _op .uleb128 0x0f \
2486 "file_name_entry_format (form: DW_FORM_udata)"
2488 set nr_files [expr [llength $_line_file_names] / 2]
2489 _op .byte $nr_files "file_names_count"
2491 foreach { filename diridx } $_line_file_names {
2492 switch $_line_string_form {
2493 string {
2494 _op .ascii [_quote $filename]
2495 }
2496 line_strp {
2497 declare_labels string_ptr
2498 _defer_output .debug_line_str {
2499 string_ptr:
2500 _op .ascii [_quote $filename]
2501 }
2502 _op_offset [expr $_line_is_64 ? 8 : 4] $string_ptr
2503 }
2504 }
2505 _op .uleb128 $diridx
2506 }
2507 } else {
2508 foreach dirname $_line_include_dirs {
2509 _op .ascii [_quote $dirname]
2510 }
2512 _op .byte 0 "Terminator (include_directories)"
2514 foreach { filename diridx } $_line_file_names {
2515 _op .ascii [_quote $filename]
2516 _op .sleb128 $diridx
2517 _op .sleb128 0 "mtime"
2518 _op .sleb128 0 "length"
2519 }
2521 _op .byte 0 "Terminator (file_names)"
2522 }
2524 set _line_include_dirs {}
2525 set _line_file_names {}
2527 variable _line_header_end_label
2528 define_label $_line_header_end_label
2529 }
2531 proc program { body } {
2532 variable _line_header_end_label
2533 variable _line
2536 set _line 1
2538 _line_finalize_header
2540 proc DW_LNE_set_address {addr} {
2541 _op .byte 0
2542 set start [new_label "set_address_start"]
2543 set end [new_label "set_address_end"]
2544 _op .uleb128 "${end} - ${start}"
2545 define_label ${start}
2546 _op .byte 2
2547 if {[is_64_target]} {
2548 _op .8byte ${addr}
2549 } else {
2550 _op .4byte ${addr}
2551 }
2552 define_label ${end}
2553 }
2555 proc DW_LNE_end_sequence {} {
2556 variable _line
2557 _op .byte 0
2558 _op .uleb128 1
2559 _op .byte 1
2560 set _line 1
2561 }
2563 proc DW_LNE_user { len opcode } {
2564 set DW_LNE_lo_usr 0x80
2565 set DW_LNE_hi_usr 0xff
2566 if { $DW_LNE_lo_usr <= $opcode
2567 && $opcode <= $DW_LNE_hi_usr } {
2568 _op .byte 0
2569 _op .uleb128 $len
2570 _op .byte $opcode
2571 for {set i 1} {$i < $len} {incr i} {
2572 _op .byte 0
2573 }
2574 } else {
2575 error "unknown vendor specific extended opcode: $opcode"
2576 }
2577 }
2579 proc DW_LNS_copy {} {
2580 _op .byte 1
2581 }
2583 proc DW_LNS_negate_stmt {} {
2584 _op .byte 6
2585 }
2587 proc DW_LNS_set_prologue_end {} {
2588 _op .byte 0x0a
2589 }
2591 proc DW_LNS_advance_pc {offset} {
2592 _op .byte 2
2593 _op .uleb128 ${offset}
2594 }
2596 proc DW_LNS_advance_line {offset} {
2597 variable _line
2598 _op .byte 3
2599 _op .sleb128 ${offset}
2600 set _line [expr $_line + $offset]
2601 }
2603 # A pseudo line number program instruction, that can be used instead
2604 # of DW_LNS_advance_line. Rather than writing:
2605 # {DW_LNS_advance_line [expr $line1 - 1]}
2606 # {DW_LNS_advance_line [expr $line2 - $line1]}
2607 # {DW_LNS_advance_line [expr $line3 - $line2]}
2608 # we can just write:
2609 # {line $line1}
2610 # {line $line2}
2611 # {line $line3}
2612 proc line {line} {
2613 variable _line
2614 set offset [expr $line - $_line]
2615 DW_LNS_advance_line $offset
2616 }
2618 proc DW_LNS_set_file {num} {
2619 _op .byte 4
2620 _op .sleb128 ${num}
2621 }
2623 uplevel $body
2624 }
2626 uplevel $body
2628 rename include_dir ""
2629 rename file_name ""
2631 _line_finalize_header
2633 define_label $unit_end_label
2634 }
2636 # Emit a DWARF .debug_aranges entry.
2638 proc arange { options arange_start arange_length } {
2639 parse_options {
2640 { comment "" }
2641 { seg_sel "" }
2642 }
2644 if { $comment != "" } {
2645 # Wrap
2646 set comment " ($comment)"
2647 }
2649 if { $seg_sel != "" } {
2650 variable _seg_size
2651 if { $_seg_size == 8 } {
2652 set seg_op .8byte
2653 } elseif { $_seg_size == 4 } {
2654 set seg_op .4byte
2655 } else {
2656 error \
2657 "Don't know how to handle segment selector size $_seg_size"
2658 }
2659 _op $seg_op $seg_sel "Address range segment selector$comment"
2660 }
2662 variable _addr_size
2663 if { $_addr_size == 8 } {
2664 set addr_op .8byte
2665 } elseif { $_addr_size == 4 } {
2666 set addr_op .4byte
2667 }
2669 _op $addr_op $arange_start "Address range start$comment"
2670 _op $addr_op $arange_length "Address range length$comment"
2671 }
2673 # Emit a DWARF .debug_aranges unit.
2674 #
2675 # OPTIONS is a list with an even number of elements containing
2676 # option-name and option-value pairs.
2677 # Current options are:
2678 # is_64 0|1 - boolean indicating if you want to emit 64-bit DWARF
2679 # default = 0 (32-bit)
2680 # cu_is_64 0|1 - boolean indicating if LABEL refers to a 64-bit DWARF CU
2681 # default = 0 (32-bit)
2682 # section_version n
2683 # - section version number to emit
2684 # default = 2
2685 # seg_size n - the size of the adress selector in bytes: 0, 4, or 8
2686 # default = 0
2687 #
2688 # LABEL is the label of the corresponding CU.
2689 #
2690 # BODY is Tcl code that emits the parts which make up the body of
2691 # the aranges unit. It is evaluated in the caller's context. The
2692 # following commands are available for the BODY section:
2693 #
2694 # arange [-c <comment>] [<segment selector>] <start> <length>
2695 # -- adds an address range.
2697 proc aranges { options label body } {
2698 variable _addr_size
2699 variable _seg_size
2701 # Handle options.
2702 parse_options {
2703 { is_64 0 }
2704 { cu_is_64 0 }
2705 { section_version 2 }
2706 { seg_size 0 }
2707 }
2708 set _seg_size $seg_size
2710 if { [is_64_target] } {
2711 set _addr_size 8
2712 } else {
2713 set _addr_size 4
2714 }
2716 # Switch to .debug_aranges section.
2717 _section .debug_aranges
2719 # Keep track of offset from start of section entry to determine
2720 # padding amount.
2721 set offset 0
2723 # Initial length.
2724 declare_labels aranges_start aranges_end
2725 set length "$aranges_end - $aranges_start"
2726 set comment "Length"
2727 if { $is_64 } {
2728 _op .4byte 0xffffffff
2729 _op .8byte $length $comment
2730 incr offset 12
2731 } else {
2732 _op .4byte $length $comment
2733 incr offset 4
2734 }
2736 # Start label.
2737 aranges_start:
2739 # Section version.
2740 _op .2byte $section_version "Section version"
2741 incr offset 2
2743 # Offset into .debug_info.
2744 upvar $label my_label
2745 if { $cu_is_64 } {
2746 _op .8byte $my_label "Offset into .debug_info"
2747 incr offset 8
2748 } else {
2749 _op .4byte $my_label "Offset into .debug_info"
2750 incr offset 4
2751 }
2753 # Address size.
2754 _op .byte $_addr_size "Address size"
2755 incr offset
2757 # Segment selector size.
2758 _op .byte $_seg_size "Segment selector size"
2759 incr offset
2761 # Padding.
2762 set tuple_size [expr 2 * $_addr_size + $_seg_size]
2763 while { 1 } {
2764 if { [expr $offset % $tuple_size] == 0 } {
2765 break
2766 }
2767 _op .byte 0 "Pad to $tuple_size byte boundary"
2768 incr offset
2769 }
2771 # Range tuples.
2772 uplevel $body
2774 # Terminator tuple.
2775 set comment "Terminator"
2776 if { $_seg_size == 0 } {
2777 arange {comment $comment} 0 0
2778 } else {
2779 arange {comment $comment seg_sel 0} 0 0
2780 }
2782 # End label.
2783 aranges_end:
2784 }
2786 # Emit a .debug_loc entry.
2788 proc _loc_entry { start end location_description } {
2789 # Determine how to emit addresses.
2790 variable _addr_size
2791 if { $_addr_size == 8 } {
2792 set addr_op .8byte
2793 } elseif { $_addr_size == 4 } {
2794 set addr_op .4byte
2795 }
2797 # Emit start and end address.
2798 _op $addr_op $start "Start address"
2799 _op $addr_op $end "End address"
2801 declare_labels location_description_start
2802 declare_labels location_description_end
2804 # Emit length of location description.
2805 set len "$location_description_end - $location_description_start"
2806 _op .2byte $len "Location description length"
2808 # Tag start of location description.
2809 define_label $location_description_start
2811 # Emit location description.
2812 variable _cu_version
2813 variable _cu_offset_size
2814 _location $location_description $_cu_version $_addr_size \
2815 $_cu_offset_size
2817 # Tag end of location description.
2818 define_label $location_description_end
2819 }
2821 # Emit a DWARF .debug_loc contribution.
2822 #
2823 # OPTIONS is a list with an even number of elements containing
2824 # option-name and option-value pairs.
2825 # Current options are:
2826 # cu_is_64 0|1 - boolean indicating if references from location
2827 # descriptions refer to a 64-bit DWARF CU.
2828 # default = 0 (32-bit)
2829 # cu_version n - section version of DWARF CU referenced from location
2830 # descriptions.
2831 # default = 4
2832 #
2833 # BODY is Tcl code that emits the parts which make up the body of
2834 # the debug_loc contribution. It is evaluated in the caller's context.
2835 # The following command is available for the BODY section:
2836 #
2837 # entry <start> <end> <location description>
2838 # -- emit a .debug_loc entry
2840 proc loc { options body } {
2841 # Handle options.
2842 parse_options {
2843 { cu_version 4 }
2844 { cu_is_64 0 }
2845 }
2847 # Export for use in BODY.
2848 variable _addr_size
2849 if { [is_64_target] } {
2850 set _addr_size 8
2851 } else {
2852 set _addr_size 4
2853 }
2854 variable _cu_version
2855 set _cu_version $cu_version
2856 variable _cu_offset_size
2857 if { $cu_is_64 == 1 } {
2858 set _cu_offset_size 8
2859 } else {
2860 set _cu_offset_size 4
2861 }
2863 # Switch to .debug_loc section.
2864 _section .debug_loc
2866 # Introduce command 'entry'.
2867 with_override Dwarf::entry Dwarf::_loc_entry {
2868 # Emit entries.
2869 uplevel $body
2870 }
2872 # Determine how to emit addresses.
2873 if { $_addr_size == 8 } {
2874 set addr_op .8byte
2875 } elseif { $_addr_size == 4 } {
2876 set addr_op .4byte
2877 }
2879 # Emit <End of list>.
2880 set comment "<End of list>"
2881 _op $addr_op 0 "$comment (Part 1/2)"
2882 _op $addr_op 0 "$comment (Part 2/2)"
2883 }
2885 proc _empty_array {name} {
2886 upvar $name the_array
2888 catch {unset the_array}
2889 set the_array(_) {}
2890 unset the_array(_)
2891 }
2893 # Emit a .gnu_debugaltlink section with the given file name and
2894 # build-id. The buildid should be represented as a hexadecimal
2895 # string, like "ffeeddcc".
2896 proc gnu_debugaltlink {filename buildid} {
2897 _defer_output .gnu_debugaltlink {
2898 _op .ascii [_quote $filename]
2899 foreach {a b} [split $buildid {}] {
2900 _op .byte 0x$a$b
2901 }
2902 }
2903 }
2905 proc _note {type name hexdata} {
2906 set namelen [expr [string length $name] + 1]
2908 # Name size.
2909 _op .4byte $namelen
2910 # Data size.
2911 _op .4byte [expr [string length $hexdata] / 2]
2912 # Type.
2913 _op .4byte $type
2914 # The name.
2915 _op .ascii [_quote $name]
2916 # Alignment.
2917 set align 2
2918 set total [expr {($namelen + (1 << $align) - 1) & -(1 << $align)}]
2919 for {set i $namelen} {$i < $total} {incr i} {
2920 _op .byte 0
2921 }
2922 # The data.
2923 foreach {a b} [split $hexdata {}] {
2924 _op .byte 0x$a$b
2925 }
2926 }
2928 # Emit a note section holding the given build-id.
2929 proc build_id {buildid} {
2930 _defer_output {.note.gnu.build-id a note} {
2931 # From elf/common.h.
2932 set NT_GNU_BUILD_ID 3
2934 _note $NT_GNU_BUILD_ID GNU $buildid
2935 }
2936 }
2938 # Emit a dummy CU.
2939 proc dummy_cu {} {
2940 # Generate a CU with default options and empty body.
2941 cu {label dummy_cu} {
2942 }
2944 # Generate an .debug_aranges entry for the dummy CU.
2945 aranges {} dummy_cu {
2946 }
2947 }
2949 # Emit a DWARF .debug_names section.
2950 #
2951 # OPTIONS is a list with an even number of elements containing
2952 # option-name and option-value pairs.
2953 # Current options are:
2954 # is_64 0|1 - boolean indicating if the section contains 64-bit DWARF.
2955 # default = 0 (32-bit)
2956 # version n - section version.
2957 # default = 5.
2958 #
2959 # BODY is Tcl code that emits the parts which make up the body of
2960 # the .debug_names section. It is evaluated in the caller's context.
2961 # The following commands are available for the BODY section:
2962 #
2963 # cu <cu-label>
2964 # -- add a CU.
2965 #
2966 # name <name> <tag> <cu> <hash>
2967 # -- add a name.
2969 proc debug_names { options body } {
2970 global decimal
2972 parse_options {
2973 { is_64 0 }
2974 { version 5 }
2975 }
2977 variable _debug_names_offset_size
2978 if { $is_64 == 1 } {
2979 set _debug_names_offset_size 8
2980 } else {
2981 set _debug_names_offset_size 4
2982 }
2984 # Section start.
2985 set section ".debug_names"
2986 _section $section
2988 # Header - initial length.
2989 declare_labels debug_names_start debug_names_end
2990 set length "$debug_names_end - $debug_names_start"
2991 set comment "Initial_length"
2992 if { $is_64 } {
2993 _op .4byte 0xffffffff
2994 _op .8byte $length $comment
2995 } else {
2996 _op .4byte $length $comment
2997 }
2999 # Header - start label.
3000 debug_names_start:
3002 # Header - version + padding.
3003 _op .2byte $version "Version"
3004 _op .2byte 0 "Padding"
3006 # Parse the body.
3007 variable _debug_names_cus
3008 set _debug_names_cus []
3009 proc _debug_names_cu { cu } {
3010 variable _debug_names_cus
3011 lappend _debug_names_cus $cu
3012 }
3013 variable _debug_names_tus
3014 set _debug_names_tus []
3015 proc _debug_names_tu { tu } {
3016 variable _debug_names_tus
3017 lappend _debug_names_tus $tu
3018 }
3019 variable _debug_names
3020 set _debug_names []
3021 proc _debug_names_name { name tag cu hash } {
3022 variable _debug_names
3023 declare_labels entry_pool_offset
3024 lappend _debug_names [list $name $tag $cu $hash $entry_pool_offset]
3025 }
3026 with_override Dwarf::cu Dwarf::_debug_names_cu {
3027 with_override Dwarf::tu Dwarf::_debug_names_tu {
3028 with_override Dwarf::name Dwarf::_debug_names_name {
3029 uplevel $body
3030 }}}
3032 # Header - CU / TU / foreign TU count.
3033 _op .4byte [llength $_debug_names_cus] "Comp_unit_count"
3034 _op .4byte [llength $_debug_names_tus] "Local_type_unit_count"
3035 _op .4byte 0 "Foreign_type_unit_count"
3037 # Header - bucket count.
3038 _op .4byte 1 "Bucket_count"
3040 # Header - name count.
3041 _op .4byte [llength $_debug_names] "Name_count"
3043 # Header - abbreviation table size.
3044 declare_labels debug_names_abbrev_table_start \
3045 debug_names_abbrev_table_end
3046 set abbrev_table_size \
3047 "$debug_names_abbrev_table_end - $debug_names_abbrev_table_start"
3048 _op .4byte $abbrev_table_size "Abbrev_table_size"
3050 # Header - augmentation string.
3051 _op .4byte 4 "Augmentation_string_size"
3052 _op .ascii [_quote GDB] "Augmentation_string"
3054 # List of CUs.
3055 set comment "CU offset"
3056 foreach cu $_debug_names_cus {
3057 upvar $cu tmp
3058 if { $is_64 } {
3059 _op .8byte $tmp $comment
3060 } else {
3061 _op .4byte $tmp $comment
3062 }
3063 }
3065 # List of Local TUs.
3066 set comment "TU offset"
3067 foreach tu $_debug_names_tus {
3068 upvar $tu tmp
3069 if { $is_64 } {
3070 _op .8byte $tmp $comment
3071 } else {
3072 _op .4byte $tmp $comment
3073 }
3074 }
3076 # List of Foreign TUs.
3077 #
3079 # Hash Lookup Table - array of buckets.
3080 _op .4byte 1 "bucket: hash array index 1"
3082 # Hash Lookup Table - array of hashes.
3083 foreach idx $_debug_names {
3084 set name [lindex $idx 0]
3085 set hash [lindex $idx 3]
3086 _op .4byte $hash "hash: $name"
3087 }
3089 # Name Table - array of string offsets.
3090 foreach idx $_debug_names {
3091 set name [lindex $idx 0]
3093 variable _strings
3094 if {![info exists _strings($name)]} {
3095 set _strings($name) [new_label strp]
3096 _defer_output .debug_str {
3097 define_label $_strings($name)
3098 _op .ascii [_quote $name]
3099 }
3100 }
3102 _op_offset $_debug_names_offset_size $_strings($name) "name: $name"
3103 }
3105 # Name Table - array of entry offsets.
3106 set base_label ""
3107 foreach idx $_debug_names {
3108 set name [lindex $idx 0]
3109 set label [lindex $idx 4]
3110 if { [string equal $base_label ""]} {
3111 set base_label $label
3112 }
3113 _op_offset $_debug_names_offset_size "$label - $base_label" \
3114 "entry pool offset: $name"
3115 }
3117 # Abbreviations Table.
3118 debug_names_abbrev_table_start:
3119 set abbrev 1
3120 variable _constants
3121 foreach idx $_debug_names {
3122 set name [lindex $idx 0]
3123 set tag [lindex $idx 1]
3124 set cu [lindex $idx 2]
3126 if { [regexp "^CU-($decimal)$" $cu dummy cu_index] } {
3127 set attr_name compile_unit
3128 set attr_val 1
3129 } elseif { [regexp "^TU-($decimal)$" $cu dummy cu_index] } {
3130 set attr_name type_unit
3131 set attr_val 2
3132 } else {
3133 set cu_index [lsearch -exact $_debug_names_cus $cu]
3134 if { $cu_index == -1 } {
3135 set attr_name type_unit
3136 set attr_val 2
3137 } else {
3138 set attr_name compile_unit
3139 set attr_val 1
3140 }
3141 }
3143 _op .byte $abbrev "abbrev $abbrev"
3144 _op .uleb128 $_constants(DW_TAG_$tag) "DW_TAG_$tag"
3145 _op .byte $attr_val "DW_IDX_$attr_name (attribute)"
3146 _op .byte 0x0f "DW_FORM_udata (form)"
3147 _op .byte 0 "abbrev terminator (attribute)"
3148 _op .byte 0 "abbrev terminator (form)"
3149 incr abbrev
3150 }
3151 _op .byte 0 "Abbreviations Table terminator"
3152 debug_names_abbrev_table_end:
3154 # Entry Pool
3155 set abbrev 1
3156 foreach idx $_debug_names {
3157 set name [lindex $idx 0]
3158 set cu [lindex $idx 2]
3159 set label [lindex $idx 4]
3161 if { [regexp "^CU-($decimal)$" $cu dummy cu_index] } {
3162 set comment "$name: CU index"
3163 } elseif { [regexp "^TU-($decimal)$" $cu dummy cu_index] } {
3164 set comment "$name: TU index"
3165 } else {
3166 set cu_index [lsearch -exact $_debug_names_cus $cu]
3167 if { $cu_index == -1 } {
3168 set cu_index [lsearch -exact $_debug_names_tus $cu]
3169 set comment "$name: TU index"
3170 } else {
3171 set comment "$name: CU index"
3172 }
3173 }
3174 define_label $label
3175 _op .byte $abbrev "$name: abbrev"
3176 _op .uleb128 $cu_index $comment
3177 _op .byte 0 "$name: terminator"
3178 incr abbrev
3179 }
3181 # Section end.
3182 debug_names_end:
3183 }
3185 # The top-level interface to the DWARF assembler.
3186 # OPTIONS is a list with an even number of elements containing
3187 # option-name and option-value pairs.
3188 # Current options are:
3189 # filename <string>
3190 # - the name of the file where the generated assembly
3191 # code is written.
3192 # default = "".
3193 # file_id <tcl channel identifier>
3194 # - open file where the generated assemble core is written.
3195 # default = "".
3196 # add_dummy_cus <0|1>
3197 # - Whether to add dummy CUs before and after the CUs
3198 # added in the BODY.
3199 # default = 1.
3200 # As a special case, if OPTIONS is a list of length 1, it's
3201 # interpreted as specifing the filename.
3202 # BODY is Tcl code to emit the assembly. It is evaluated via
3203 # "eval" -- not uplevel as you might expect, because it is
3204 # important to run the body in the Dwarf namespace.
3205 #
3206 # A typical invocation is something like:
3207 # Dwarf::assemble $file {
3208 # cu 0 2 8 {
3209 # compile_unit {
3210 # ...
3211 # }
3212 # }
3213 # cu 0 2 8 {
3214 # ...
3215 # }
3216 # }
3217 proc assemble {options body} {
3218 variable _initialized
3219 variable _output_file
3220 variable _deferred_output
3221 variable _defer
3222 variable _label_num
3223 variable _strings
3224 variable _cu_count
3225 variable _line_count
3226 variable _line_header_end_label
3227 variable _debug_ranges_64_bit
3228 variable _debug_addr_index
3230 if { [llength $options] == 1 } {
3231 set options [list filename [lindex $options 0]]
3232 }
3234 parse_options {
3235 { filename "" }
3236 { file_id "" }
3237 { add_dummy_cus 1 }
3238 }
3240 if {!$_initialized} {
3241 _read_constants
3242 set _initialized 1
3243 }
3245 if { $file_id != "" } {
3246 set _output_file $file_id
3247 } else {
3248 set _output_file [open $filename w]
3249 }
3251 set _cu_count -1
3252 _empty_array _deferred_output
3253 set _defer ""
3254 set _label_num 0
3255 _empty_array _strings
3257 set _line_count 0
3258 set _debug_ranges_64_bit [is_64_target]
3260 set _debug_addr_index 0
3262 # Dummy CU at the start to ensure that the first CU in $body is not
3263 # the first in .debug_info.
3264 if { $add_dummy_cus } {
3265 dummy_cu
3266 }
3268 with_shared_gdb {
3269 # Not "uplevel" here, because we want to evaluate in this
3270 # namespace. This is somewhat bad because it means we can't
3271 # readily refer to outer variables.
3272 eval $body
3273 }
3275 # Dummy CU at the end to ensure that the last CU in $body is not
3276 # the last in .debug_info.
3277 if { $add_dummy_cus } {
3278 dummy_cu
3279 }
3281 _write_deferred_output
3283 _section .note.GNU-stack "" progbits
3285 if { $file_id == "" } {
3286 catch {close $_output_file}
3287 }
3288 set _output_file {}
3289 }
3290 }