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