]>
Commit | Line | Data |
---|---|---|
1d506c26 | 1 | # Copyright 2010-2024 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 | ||
d4c45423 | 107 | if {![regexp "^/" "$executable"]} { |
61dee722 AB |
108 | set binfile [standard_output_file $executable] |
109 | } else { | |
110 | set binfile $executable | |
111 | } | |
112 | ||
61dee722 AB |
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. | |
6b4646ce DE |
119 | return -1 |
120 | } | |
61dee722 AB |
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 | } | |
127 | ||
128 | # Must be run on local host due to use of objcopy. | |
129 | if [is_remote host] { | |
130 | return -1 | |
131 | } | |
132 | ||
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 | } | |
140 | ||
141 | verbose -log "APB: SPEC: $spec" | |
142 | ||
143 | set s [lindex $spec 0] | |
144 | set local_options [lindex $spec 1] | |
145 | ||
d4c45423 | 146 | if {![regexp "^/" "$s"]} { |
61dee722 AB |
147 | set s "$srcdir/$subdir/$s" |
148 | } | |
149 | ||
150 | if {[llength $spec] > 2} { | |
151 | set objfile [lindex $spec 2] | |
152 | } else { | |
153 | set objfile "${binfile}${i}.o" | |
154 | incr i | |
155 | } | |
156 | ||
157 | if { [$func "${s}" "${objfile}" object $local_options] != "" } { | |
158 | untested $testname | |
159 | return -1 | |
160 | } | |
161 | ||
162 | lappend objects "$objfile" | |
163 | ||
164 | if {[lsearch -exact $local_options "split-dwo"] >= 0} { | |
165 | # Split out the DWO file. | |
166 | set dwo_file "[file rootname ${objfile}].dwo" | |
167 | ||
168 | if { [extract_dwo_information $objfile $dwo_file] == -1 } { | |
169 | untested $testname | |
170 | return -1 | |
171 | } | |
172 | ||
173 | if { [strip_dwo_information $objfile] == -1 } { | |
174 | untested $testname | |
175 | return -1 | |
176 | } | |
177 | } | |
178 | } | |
179 | ||
180 | verbose -log "APB: OBJECTS = $objects" | |
181 | ||
182 | set ret [$func $objects "${binfile}" executable $options] | |
183 | if { $ret != "" } { | |
184 | untested $testname | |
185 | return -1 | |
186 | } | |
6b4646ce DE |
187 | |
188 | return 0 | |
189 | } | |
190 | ||
fc6a9385 TV |
191 | # Utility function for procs shared_gdb_*. |
192 | ||
193 | proc init_shared_gdb {} { | |
194 | global shared_gdb_enabled | |
195 | global shared_gdb_started | |
196 | ||
197 | if { ! [info exists shared_gdb_enabled] } { | |
198 | set shared_gdb_enabled 0 | |
199 | set shared_gdb_started 0 | |
200 | } | |
201 | } | |
202 | ||
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. | |
227 | ||
228 | proc shared_gdb_enable {} { | |
229 | set me shared_gdb_enable | |
230 | ||
231 | init_shared_gdb | |
232 | global shared_gdb_enabled | |
233 | global shared_gdb_started | |
234 | ||
235 | if { $shared_gdb_enabled } { | |
236 | error "$me: gdb sharing already enabled" | |
237 | } | |
238 | set shared_gdb_enabled 1 | |
239 | ||
240 | if { $shared_gdb_started } { | |
241 | error "$me: gdb sharing not stopped" | |
242 | } | |
243 | } | |
244 | ||
245 | # See above. | |
246 | ||
247 | proc shared_gdb_disable {} { | |
248 | init_shared_gdb | |
249 | global shared_gdb_enabled | |
250 | global shared_gdb_started | |
251 | ||
252 | if { ! $shared_gdb_enabled } { | |
253 | error "$me: gdb sharing not enabled" | |
254 | } | |
255 | set shared_gdb_enabled 0 | |
256 | ||
257 | if { $shared_gdb_started } { | |
258 | gdb_exit | |
259 | set shared_gdb_started 0 | |
260 | } | |
261 | } | |
262 | ||
2899c914 TV |
263 | # Share the current gdb session. |
264 | ||
265 | proc share_gdb { src options } { | |
266 | global shared_gdb_started | |
267 | global shared_gdb_src | |
268 | global shared_gdb_options | |
269 | ||
270 | set shared_gdb_started 1 | |
271 | set shared_gdb_src $src | |
272 | set shared_gdb_options $options | |
273 | } | |
274 | ||
fc6a9385 TV |
275 | # See above. |
276 | ||
277 | proc shared_gdb_start_use { src options } { | |
278 | set me shared_gdb_start_use | |
279 | ||
280 | init_shared_gdb | |
281 | global shared_gdb_enabled | |
282 | global shared_gdb_started | |
283 | global shared_gdb_src | |
284 | global shared_gdb_options | |
285 | ||
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 | } | |
292 | ||
293 | set do_start 0 | |
294 | } | |
295 | ||
296 | if { $do_start } { | |
16fbc917 | 297 | set exe [standard_temp_file func_addr.x] |
fc6a9385 TV |
298 | |
299 | gdb_compile $src $exe executable $options | |
300 | ||
301 | gdb_exit | |
302 | gdb_start | |
303 | gdb_load "$exe" | |
304 | ||
305 | if { $shared_gdb_enabled } { | |
2899c914 | 306 | share_gdb $src $options |
fc6a9385 TV |
307 | } |
308 | } | |
309 | } | |
310 | ||
311 | # See above. | |
312 | ||
313 | proc shared_gdb_end_use {} { | |
314 | init_shared_gdb | |
315 | global shared_gdb_enabled | |
316 | ||
317 | if { ! $shared_gdb_enabled } { | |
318 | gdb_exit | |
319 | } | |
320 | } | |
321 | ||
322 | # Enable gdb session sharing within BODY. | |
323 | ||
324 | proc with_shared_gdb { body } { | |
325 | shared_gdb_enable | |
326 | set code [catch { uplevel 1 $body } result] | |
327 | shared_gdb_disable | |
328 | ||
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 | } | |
336 | ||
337 | return $result | |
338 | } | |
339 | ||
876c4df9 YQ |
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 | # | |
367 | ||
6a354911 | 368 | proc function_range { func src {options {debug}} } { |
876c4df9 YQ |
369 | global decimal gdb_prompt |
370 | ||
fc6a9385 | 371 | shared_gdb_start_use $src $options |
876c4df9 YQ |
372 | |
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 | } | |
382 | ||
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 | } | |
392 | ||
393 | # Compute the size of the last instruction. | |
244a9a81 NCK |
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" | |
03eddd80 | 402 | } |
2acccd0a | 403 | set test "with print asm-demangle on -- x/2i $func+$func_length" |
876c4df9 | 404 | gdb_test_multiple $test $test { |
03eddd80 | 405 | -re ".*($hex) <$func_pattern>:\[^\r\n\]+\r\n\[ \]+($hex).*\.\r\n$gdb_prompt $" { |
876c4df9 YQ |
406 | set start $expect_out(1,string) |
407 | set end $expect_out(2,string) | |
408 | ||
409 | set func_length [expr $func_length + $end - $start] | |
410 | } | |
411 | } | |
412 | ||
fc6a9385 TV |
413 | shared_gdb_end_use |
414 | ||
876c4df9 YQ |
415 | return [list "${func}_label - $func_label_offset" $func_length] |
416 | } | |
417 | ||
21b0982c AB |
418 | # Extract the start, length, and end for function called NAME and |
419 | # create suitable variables in the callers scope. | |
41505c0f | 420 | # Return the list of created variables. |
21b0982c AB |
421 | proc get_func_info { name {options {debug}} } { |
422 | global srcdir subdir srcfile | |
423 | ||
424 | upvar 1 "${name}_start" func_start | |
425 | upvar 1 "${name}_len" func_len | |
426 | upvar 1 "${name}_end" func_end | |
427 | ||
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" | |
41505c0f TV |
433 | |
434 | return [list \ | |
435 | "${name}_start" \ | |
436 | "${name}_len" \ | |
437 | "${name}_end"] | |
21b0982c AB |
438 | } |
439 | ||
1d24041a TT |
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 | # | |
876c4df9 YQ |
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 | # | |
10da644d | 479 | # - MACRO_AT_range { FUNC } |
876c4df9 | 480 | # It is substituted by DW_AT_low_pc and DW_AT_high_pc with the start and |
10da644d | 481 | # end address of function FUNC in file $srcdir/$subdir/$srcfile. |
876c4df9 | 482 | # |
10da644d | 483 | # - MACRO_AT_func { FUNC } |
876c4df9 YQ |
484 | # It is substituted by DW_AT_name with FUNC and MACRO_AT_range. |
485 | # | |
1d24041a TT |
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 | |
eab9267c MW |
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. | |
1d24041a TT |
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'. | |
f13a9a0c YQ |
506 | # * If VALUE starts with the "%" character, then it is a label |
507 | # reference too, but DW_FORM_ref_addr is used. | |
7d72802b TV |
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. | |
1d24041a TT |
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. | |
518 | ||
519 | namespace eval Dwarf { | |
520 | # True if the module has been initialized. | |
521 | variable _initialized 0 | |
522 | ||
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 | |
531 | ||
532 | # The current output file. | |
533 | variable _output_file | |
534 | ||
4f22ed5c DE |
535 | # Note: The _cu_ values here also apply to type units (TUs). |
536 | # Think of a TU as a special kind of CU. | |
537 | ||
1d24041a TT |
538 | # Current CU count. |
539 | variable _cu_count | |
540 | ||
541 | # The current CU's base label. | |
542 | variable _cu_label | |
543 | ||
544 | # The current CU's version. | |
545 | variable _cu_version | |
546 | ||
547 | # The current CU's address size. | |
548 | variable _cu_addr_size | |
549 | # The current CU's offset size. | |
550 | variable _cu_offset_size | |
551 | ||
552 | # Label generation number. | |
553 | variable _label_num | |
554 | ||
555 | # The deferred output array. The index is the section name; the | |
556 | # contents hold the data for that section. | |
557 | variable _deferred_output | |
558 | ||
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 | |
562 | ||
6c9e2db4 DE |
563 | # The abbrev section. Typically .debug_abbrev but can be .debug_abbrev.dwo |
564 | # for Fission. | |
565 | variable _abbrev_section | |
566 | ||
1d24041a TT |
567 | # The next available abbrev number in the current CU's abbrev |
568 | # table. | |
569 | variable _abbrev_num | |
570 | ||
571 | # The string table for this assembly. The key is the string; the | |
572 | # value is the label for that string. | |
573 | variable _strings | |
574 | ||
6ef37366 PM |
575 | # Current .debug_line unit count. |
576 | variable _line_count | |
577 | ||
28d2bfb9 AB |
578 | # A Label for line table header generation. |
579 | variable _line_header_end_label | |
580 | ||
581 | # The address size for debug ranges section. | |
582 | variable _debug_ranges_64_bit | |
583 | ||
61dee722 AB |
584 | # The index into the .debug_addr section (used for fission |
585 | # generation). | |
586 | variable _debug_addr_index | |
587 | ||
588 | # Flag, true if the current CU is contains fission information, | |
589 | # otherwise false. | |
590 | variable _cu_is_fission | |
591 | ||
1d24041a TT |
592 | proc _process_one_constant {name value} { |
593 | variable _constants | |
594 | variable _AT | |
595 | variable _FORM | |
596 | variable _OP | |
597 | ||
598 | set _constants($name) $value | |
599 | ||
600 | if {![regexp "^DW_(\[A-Z\]+)_(\[A-Za-z0-9_\]+)$" $name \ | |
601 | ignore prefix name2]} { | |
602 | error "non-matching name: $name" | |
603 | } | |
604 | ||
605 | if {$name2 == "lo_user" || $name2 == "hi_user"} { | |
606 | return | |
607 | } | |
608 | ||
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" | |
618 | ||
619 | # Filter out ones that are known to clash. | |
620 | if {$name2 == "variable" || $name2 == "namespace"} { | |
621 | set name2 "tag_$name2" | |
622 | } | |
623 | ||
624 | if {[info commands $name2] != {}} { | |
625 | error "duplicate proc name: from $name" | |
626 | } | |
627 | ||
628 | proc $name2 {{attrs {}} {children {}}} \ | |
629 | "_handle_DW_TAG $name \$attrs \$children" | |
630 | } | |
631 | ||
632 | AT { | |
633 | set _AT($name2) $name | |
634 | } | |
635 | ||
636 | FORM { | |
637 | set _FORM($name2) $name | |
638 | } | |
639 | ||
640 | OP { | |
641 | set _OP($name2) $name | |
642 | } | |
643 | ||
644 | default { | |
645 | return | |
646 | } | |
647 | } | |
648 | } | |
649 | ||
650 | proc _read_constants {} { | |
651 | global srcdir hex decimal | |
1d24041a TT |
652 | |
653 | # DWARF name-matching regexp. | |
654 | set dwrx "DW_\[a-zA-Z0-9_\]+" | |
655 | # Whitespace regexp. | |
656 | set ws "\[ \t\]+" | |
657 | ||
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 | |
667 | ||
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 | |
1d24041a TT |
678 | } |
679 | ||
680 | proc _quote {string} { | |
681 | # FIXME | |
682 | return "\"${string}\\0\"" | |
683 | } | |
684 | ||
b6807d98 TT |
685 | proc _nz_quote {string} { |
686 | # For now, no quoting is done. | |
687 | return "\"${string}\"" | |
688 | } | |
689 | ||
1d24041a TT |
690 | proc _handle_DW_FORM {form value} { |
691 | switch -exact -- $form { | |
692 | DW_FORM_string { | |
693 | _op .ascii [_quote $value] | |
694 | } | |
695 | ||
4d051f3a | 696 | DW_FORM_implicit_const - |
1d24041a TT |
697 | DW_FORM_flag_present { |
698 | # We don't need to emit anything. | |
699 | } | |
700 | ||
701 | DW_FORM_data4 - | |
702 | DW_FORM_ref4 { | |
703 | _op .4byte $value | |
704 | } | |
705 | ||
706 | DW_FORM_ref_addr { | |
707 | variable _cu_offset_size | |
708 | variable _cu_version | |
709 | variable _cu_addr_size | |
710 | ||
711 | if {$_cu_version == 2} { | |
712 | set size $_cu_addr_size | |
713 | } else { | |
714 | set size $_cu_offset_size | |
715 | } | |
716 | ||
717 | _op .${size}byte $value | |
718 | } | |
719 | ||
a7308ce0 TT |
720 | DW_FORM_GNU_ref_alt - |
721 | DW_FORM_GNU_strp_alt - | |
6ef37366 PM |
722 | DW_FORM_sec_offset { |
723 | variable _cu_offset_size | |
a5ac8e7f | 724 | _op_offset $_cu_offset_size $value |
6ef37366 PM |
725 | } |
726 | ||
1d24041a TT |
727 | DW_FORM_ref1 - |
728 | DW_FORM_flag - | |
729 | DW_FORM_data1 { | |
730 | _op .byte $value | |
731 | } | |
732 | ||
733 | DW_FORM_sdata { | |
734 | _op .sleb128 $value | |
735 | } | |
736 | ||
737 | DW_FORM_ref_udata - | |
962effa7 | 738 | DW_FORM_udata - |
ecfda20d | 739 | DW_FORM_loclistx - |
962effa7 | 740 | DW_FORM_rnglistx { |
1d24041a TT |
741 | _op .uleb128 $value |
742 | } | |
743 | ||
744 | DW_FORM_addr { | |
745 | variable _cu_addr_size | |
746 | ||
747 | _op .${_cu_addr_size}byte $value | |
748 | } | |
749 | ||
61dee722 AB |
750 | DW_FORM_GNU_addr_index { |
751 | variable _debug_addr_index | |
752 | variable _cu_addr_size | |
753 | ||
754 | _op .uleb128 ${_debug_addr_index} | |
755 | incr _debug_addr_index | |
756 | ||
757 | _defer_output .debug_addr { | |
758 | _op .${_cu_addr_size}byte $value | |
759 | } | |
760 | } | |
761 | ||
1d24041a TT |
762 | DW_FORM_data2 - |
763 | DW_FORM_ref2 { | |
764 | _op .2byte $value | |
765 | } | |
766 | ||
767 | DW_FORM_data8 - | |
768 | DW_FORM_ref8 - | |
769 | DW_FORM_ref_sig8 { | |
770 | _op .8byte $value | |
771 | } | |
772 | ||
0224619f JK |
773 | DW_FORM_data16 { |
774 | _op .8byte $value | |
775 | } | |
776 | ||
1d24041a TT |
777 | DW_FORM_strp { |
778 | variable _strings | |
779 | variable _cu_offset_size | |
780 | ||
781 | if {![info exists _strings($value)]} { | |
782 | set _strings($value) [new_label strp] | |
1e7fcccb | 783 | _defer_output .debug_str { |
1d24041a TT |
784 | define_label $_strings($value) |
785 | _op .ascii [_quote $value] | |
786 | } | |
787 | } | |
788 | ||
a5ac8e7f | 789 | _op_offset $_cu_offset_size $_strings($value) "strp: $value" |
1d24041a TT |
790 | } |
791 | ||
792 | SPECIAL_expr { | |
6b0933da SM |
793 | variable _cu_version |
794 | variable _cu_addr_size | |
795 | variable _cu_offset_size | |
796 | ||
1d24041a TT |
797 | set l1 [new_label "expr_start"] |
798 | set l2 [new_label "expr_end"] | |
799 | _op .uleb128 "$l2 - $l1" "expression" | |
800 | define_label $l1 | |
6b0933da | 801 | _location $value $_cu_version $_cu_addr_size $_cu_offset_size |
1d24041a TT |
802 | define_label $l2 |
803 | } | |
804 | ||
b6807d98 TT |
805 | DW_FORM_block1 { |
806 | set len [string length $value] | |
807 | if {$len > 255} { | |
808 | error "DW_FORM_block1 length too long" | |
809 | } | |
810 | _op .byte $len | |
811 | _op .ascii [_nz_quote $value] | |
812 | } | |
813 | ||
1d24041a TT |
814 | DW_FORM_block2 - |
815 | DW_FORM_block4 - | |
816 | ||
817 | DW_FORM_block - | |
1d24041a TT |
818 | |
819 | DW_FORM_ref2 - | |
820 | DW_FORM_indirect - | |
1d24041a TT |
821 | DW_FORM_exprloc - |
822 | ||
cf532bd1 | 823 | DW_FORM_strx - |
15f18d14 AT |
824 | DW_FORM_strx1 - |
825 | DW_FORM_strx2 - | |
826 | DW_FORM_strx3 - | |
827 | DW_FORM_strx4 - | |
cf532bd1 | 828 | |
1d24041a | 829 | DW_FORM_GNU_str_index - |
1d24041a TT |
830 | |
831 | default { | |
832 | error "unhandled form $form" | |
833 | } | |
834 | } | |
835 | } | |
836 | ||
837 | proc _guess_form {value varname} { | |
838 | upvar $varname new_value | |
839 | ||
840 | switch -exact -- [string range $value 0 0] { | |
841 | @ { | |
842 | # Constant reference. | |
843 | variable _constants | |
844 | ||
845 | set new_value $_constants([string range $value 1 end]) | |
846 | # Just the simplest. | |
847 | return DW_FORM_sdata | |
848 | } | |
849 | ||
850 | : { | |
851 | # Label reference. | |
852 | variable _cu_label | |
853 | ||
854 | set new_value "[string range $value 1 end] - $_cu_label" | |
855 | ||
856 | return DW_FORM_ref4 | |
857 | } | |
858 | ||
f13a9a0c | 859 | % { |
456ba0fa TV |
860 | # Label reference, an offset from .debug_info. |
861 | set new_value "[string range $value 1 end]" | |
f13a9a0c YQ |
862 | |
863 | return DW_FORM_ref_addr | |
864 | } | |
865 | ||
1d24041a | 866 | default { |
7d72802b TV |
867 | return "" |
868 | } | |
869 | } | |
870 | } | |
871 | ||
872 | proc _default_form { attr } { | |
873 | switch -exact -- $attr { | |
874 | DW_AT_low_pc { | |
875 | return DW_FORM_addr | |
876 | } | |
877 | DW_AT_producer - | |
878 | DW_AT_comp_dir - | |
879 | DW_AT_linkage_name - | |
880 | DW_AT_MIPS_linkage_name - | |
881 | DW_AT_name { | |
1d24041a TT |
882 | return DW_FORM_string |
883 | } | |
61dee722 AB |
884 | DW_AT_GNU_addr_base { |
885 | return DW_FORM_sec_offset | |
886 | } | |
1d24041a | 887 | } |
7d72802b | 888 | return "" |
1d24041a TT |
889 | } |
890 | ||
891 | # Map NAME to its canonical form. | |
892 | proc _map_name {name ary} { | |
893 | variable $ary | |
894 | ||
895 | if {[info exists ${ary}($name)]} { | |
896 | set name [set ${ary}($name)] | |
897 | } | |
898 | ||
899 | return $name | |
900 | } | |
901 | ||
02ad9cf1 YQ |
902 | proc _handle_attribute { attr_name attr_value attr_form } { |
903 | variable _abbrev_section | |
904 | variable _constants | |
8cd6d968 | 905 | variable _cu_version |
02ad9cf1 YQ |
906 | |
907 | _handle_DW_FORM $attr_form $attr_value | |
908 | ||
909 | _defer_output $_abbrev_section { | |
8cd6d968 MW |
910 | if { $attr_form eq "SPECIAL_expr" } { |
911 | if { $_cu_version < 4 } { | |
912 | set attr_form_comment "DW_FORM_block" | |
913 | } else { | |
914 | set attr_form_comment "DW_FORM_exprloc" | |
915 | } | |
916 | } else { | |
917 | set attr_form_comment $attr_form | |
918 | } | |
02ad9cf1 | 919 | _op .uleb128 $_constants($attr_name) $attr_name |
8cd6d968 | 920 | _op .uleb128 $_constants($attr_form) $attr_form_comment |
4d051f3a TT |
921 | if {$attr_form eq "DW_FORM_implicit_const"} { |
922 | _op .sleb128 $attr_value "the constant" | |
923 | } | |
02ad9cf1 YQ |
924 | } |
925 | } | |
926 | ||
876c4df9 YQ |
927 | # Handle macro attribute MACRO_AT_range. |
928 | ||
929 | proc _handle_macro_at_range { attr_value } { | |
61dee722 AB |
930 | variable _cu_is_fission |
931 | ||
10da644d TV |
932 | if {[llength $attr_value] != 1} { |
933 | error "usage: MACRO_AT_range { func }" | |
876c4df9 YQ |
934 | } |
935 | ||
936 | set func [lindex $attr_value 0] | |
10da644d TV |
937 | global srcdir subdir srcfile |
938 | set src ${srcdir}/${subdir}/${srcfile} | |
876c4df9 YQ |
939 | set result [function_range $func $src] |
940 | ||
61dee722 AB |
941 | set form DW_FORM_addr |
942 | if { $_cu_is_fission } { | |
943 | set form DW_FORM_GNU_addr_index | |
944 | } | |
945 | ||
946 | _handle_attribute DW_AT_low_pc [lindex $result 0] $form | |
876c4df9 | 947 | _handle_attribute DW_AT_high_pc \ |
61dee722 | 948 | "[lindex $result 0] + [lindex $result 1]" $form |
876c4df9 YQ |
949 | } |
950 | ||
951 | # Handle macro attribute MACRO_AT_func. | |
952 | ||
953 | proc _handle_macro_at_func { attr_value } { | |
10da644d | 954 | if {[llength $attr_value] != 1} { |
876c4df9 YQ |
955 | error "usage: MACRO_AT_func { func file }" |
956 | } | |
957 | _handle_attribute DW_AT_name [lindex $attr_value 0] DW_FORM_string | |
958 | _handle_macro_at_range $attr_value | |
959 | } | |
960 | ||
d8ad643f TT |
961 | # Return the next available abbrev number in the current CU's abbrev |
962 | # table. | |
963 | proc _get_abbrev_num {} { | |
964 | variable _abbrev_num | |
965 | set res $_abbrev_num | |
966 | incr _abbrev_num | |
967 | return $res | |
968 | } | |
969 | ||
1d24041a | 970 | proc _handle_DW_TAG {tag_name {attrs {}} {children {}}} { |
6c9e2db4 | 971 | variable _abbrev_section |
1d24041a TT |
972 | variable _abbrev_num |
973 | variable _constants | |
974 | ||
975 | set has_children [expr {[string length $children] > 0}] | |
d8ad643f | 976 | set my_abbrev [_get_abbrev_num] |
1d24041a TT |
977 | |
978 | # We somewhat wastefully emit a new abbrev entry for each tag. | |
979 | # There's no reason for this other than laziness. | |
6c9e2db4 | 980 | _defer_output $_abbrev_section { |
1d24041a TT |
981 | _op .uleb128 $my_abbrev "Abbrev start" |
982 | _op .uleb128 $_constants($tag_name) $tag_name | |
983 | _op .byte $has_children "has_children" | |
984 | } | |
985 | ||
986 | _op .uleb128 $my_abbrev "Abbrev ($tag_name)" | |
987 | ||
988 | foreach attr $attrs { | |
989 | set attr_name [_map_name [lindex $attr 0] _AT] | |
2223449a KB |
990 | |
991 | # When the length of ATTR is greater than 2, the last | |
992 | # element of the list must be a form. The second through | |
993 | # the penultimate elements are joined together and | |
994 | # evaluated using subst. This allows constructs such as | |
995 | # [gdb_target_symbol foo] to be used. | |
996 | ||
997 | if {[llength $attr] > 2} { | |
998 | set attr_value [uplevel 2 [list subst [join [lrange $attr 1 end-1]]]] | |
999 | } else { | |
1000 | set attr_value [uplevel 2 [list subst [lindex $attr 1]]] | |
1001 | } | |
876c4df9 YQ |
1002 | |
1003 | if { [string equal "MACRO_AT_func" $attr_name] } { | |
1004 | _handle_macro_at_func $attr_value | |
1005 | } elseif { [string equal "MACRO_AT_range" $attr_name] } { | |
1006 | _handle_macro_at_range $attr_value | |
1d24041a | 1007 | } else { |
876c4df9 | 1008 | if {[llength $attr] > 2} { |
f13a9a0c YQ |
1009 | set attr_form [uplevel 2 [list subst [lindex $attr end]]] |
1010 | ||
1011 | if { [string index $attr_value 0] == ":" } { | |
1012 | # It is a label, get its value. | |
1013 | _guess_form $attr_value attr_value | |
1014 | } | |
876c4df9 YQ |
1015 | } else { |
1016 | set attr_form [_guess_form $attr_value attr_value] | |
7d72802b TV |
1017 | if { $attr_form eq "" } { |
1018 | set attr_form [_default_form $attr_name] | |
1019 | } | |
1020 | if { $attr_form eq "" } { | |
1021 | error "No form for $attr_name $attr_value" | |
1022 | } | |
876c4df9 YQ |
1023 | } |
1024 | set attr_form [_map_name $attr_form _FORM] | |
1d24041a | 1025 | |
876c4df9 YQ |
1026 | _handle_attribute $attr_name $attr_value $attr_form |
1027 | } | |
1d24041a TT |
1028 | } |
1029 | ||
6c9e2db4 | 1030 | _defer_output $_abbrev_section { |
1d24041a | 1031 | # Terminator. |
c40907bf TV |
1032 | _op .byte 0x0 "DW_AT - Terminator" |
1033 | _op .byte 0x0 "DW_FORM - Terminator" | |
1d24041a TT |
1034 | } |
1035 | ||
1036 | if {$has_children} { | |
1037 | uplevel 2 $children | |
1038 | ||
1039 | # Terminate children. | |
1040 | _op .byte 0x0 "Terminate children" | |
1041 | } | |
1042 | } | |
1043 | ||
1044 | proc _emit {string} { | |
1045 | variable _output_file | |
1046 | variable _defer | |
1047 | variable _deferred_output | |
1048 | ||
1049 | if {$_defer == ""} { | |
1050 | puts $_output_file $string | |
1051 | } else { | |
1052 | append _deferred_output($_defer) ${string}\n | |
1053 | } | |
1054 | } | |
1055 | ||
dc294be5 TT |
1056 | proc _section {name {flags ""} {type ""}} { |
1057 | if {$flags == "" && $type == ""} { | |
1058 | _emit " .section $name" | |
1059 | } elseif {$type == ""} { | |
1060 | _emit " .section $name, \"$flags\"" | |
1061 | } else { | |
1062 | _emit " .section $name, \"$flags\", %$type" | |
1063 | } | |
1d24041a TT |
1064 | } |
1065 | ||
dc294be5 TT |
1066 | # SECTION_SPEC is a list of arguments to _section. |
1067 | proc _defer_output {section_spec body} { | |
1d24041a TT |
1068 | variable _defer |
1069 | variable _deferred_output | |
1070 | ||
1071 | set old_defer $_defer | |
dc294be5 | 1072 | set _defer [lindex $section_spec 0] |
1d24041a TT |
1073 | |
1074 | if {![info exists _deferred_output($_defer)]} { | |
1075 | set _deferred_output($_defer) "" | |
dc294be5 | 1076 | eval _section $section_spec |
1d24041a TT |
1077 | } |
1078 | ||
1079 | uplevel $body | |
1080 | ||
1081 | set _defer $old_defer | |
1082 | } | |
1083 | ||
1084 | proc _defer_to_string {body} { | |
1085 | variable _defer | |
1086 | variable _deferred_output | |
1087 | ||
1088 | set old_defer $_defer | |
1089 | set _defer temp | |
1090 | ||
1091 | set _deferred_output($_defer) "" | |
1092 | ||
1093 | uplevel $body | |
1094 | ||
1095 | set result $_deferred_output($_defer) | |
1096 | unset _deferred_output($_defer) | |
1097 | ||
1098 | set _defer $old_defer | |
1099 | return $result | |
1100 | } | |
1101 | ||
1102 | proc _write_deferred_output {} { | |
1103 | variable _output_file | |
1104 | variable _deferred_output | |
1105 | ||
1106 | foreach section [array names _deferred_output] { | |
1107 | # The data already has a newline. | |
1108 | puts -nonewline $_output_file $_deferred_output($section) | |
1109 | } | |
1110 | ||
1111 | # Save some memory. | |
1112 | unset _deferred_output | |
1113 | } | |
1114 | ||
1115 | proc _op {name value {comment ""}} { | |
1116 | set text " ${name} ${value}" | |
1117 | if {$comment != ""} { | |
1118 | # Try to make stuff line up nicely. | |
1119 | while {[string length $text] < 40} { | |
1120 | append text " " | |
1121 | } | |
1122 | append text "/* ${comment} */" | |
1123 | } | |
1124 | _emit $text | |
1125 | } | |
1126 | ||
a5ac8e7f TV |
1127 | proc _op_offset { size offset {comment ""} } { |
1128 | if { $size == 4 } { | |
1129 | _op .4byte $offset $comment | |
1130 | } elseif { $size == 8 } { | |
1131 | if {[is_64_target]} { | |
1132 | _op .8byte $offset $comment | |
1133 | } else { | |
1134 | # This allows us to emit 64-bit dwarf for | |
1135 | # 32-bit targets. | |
1136 | if { [target_endianness] == "little" } { | |
1137 | _op .4byte $offset "$comment (lsw)" | |
1138 | _op .4byte 0 "$comment (msw)" | |
1139 | } else { | |
1140 | _op .4byte 0 "$comment (msw)" | |
1141 | _op .4byte $offset "$comment (lsw)" | |
1142 | } | |
1143 | } | |
1144 | } else { | |
1145 | error "Don't know how to handle offset size $size" | |
1146 | } | |
1147 | } | |
1148 | ||
1d24041a TT |
1149 | proc _compute_label {name} { |
1150 | return ".L${name}" | |
1151 | } | |
1152 | ||
1153 | # Return a name suitable for use as a label. If BASE_NAME is | |
1154 | # specified, it is incorporated into the label name; this is to | |
1155 | # make debugging the generated assembler easier. If BASE_NAME is | |
1156 | # not specified a generic default is used. This proc does not | |
1157 | # define the label; see 'define_label'. 'new_label' attempts to | |
1158 | # ensure that label names are unique. | |
1159 | proc new_label {{base_name label}} { | |
1160 | variable _label_num | |
1161 | ||
1162 | return [_compute_label ${base_name}[incr _label_num]] | |
1163 | } | |
1164 | ||
1165 | # Define a label named NAME. Ordinarily, NAME comes from a call | |
1166 | # to 'new_label', but this is not required. | |
1167 | proc define_label {name} { | |
1168 | _emit "${name}:" | |
1169 | } | |
1170 | ||
1d24041a TT |
1171 | # A higher-level interface to label handling. |
1172 | # | |
1173 | # ARGS is a list of label descriptors. Each one is either a | |
1174 | # single element, or a list of two elements -- a name and some | |
1175 | # text. For each descriptor, 'new_label' is invoked. If the list | |
1176 | # form is used, the second element in the list is passed as an | |
1177 | # argument. The label name is used to define a variable in the | |
1178 | # enclosing scope; this can be used to refer to the label later. | |
1179 | # The label name is also used to define a new proc whose name is | |
1180 | # the label name plus a trailing ":". This proc takes a body as | |
1181 | # an argument and can be used to define the label at that point; | |
1182 | # then the body, if any, is evaluated in the caller's context. | |
1183 | # | |
1184 | # For example: | |
1185 | # | |
1186 | # declare_labels int_label | |
1187 | # something { ... $int_label } ;# refer to the label | |
1188 | # int_label: constant { ... } ;# define the label | |
1189 | proc declare_labels {args} { | |
1190 | foreach arg $args { | |
1191 | set name [lindex $arg 0] | |
1192 | set text [lindex $arg 1] | |
1193 | ||
e633b117 SM |
1194 | if { $text == "" } { |
1195 | set text $name | |
1d24041a TT |
1196 | } |
1197 | ||
e633b117 SM |
1198 | upvar $name label_var |
1199 | set label_var [new_label $text] | |
1200 | ||
1d24041a TT |
1201 | proc ${name}: {args} [format { |
1202 | define_label %s | |
1203 | uplevel $args | |
1204 | } $label_var] | |
1205 | } | |
1206 | } | |
1207 | ||
3f49d080 TT |
1208 | # Assign elements from LINE to the elements of an array named |
1209 | # "argvec" in the caller scope. The keys used are named in ARGS. | |
1210 | # If the wrong number of elements appear in LINE, error. | |
1211 | proc _get_args {line op args} { | |
1212 | if {[llength $line] != [llength $args] + 1} { | |
1213 | error "usage: $op [string toupper $args]" | |
1214 | } | |
1215 | ||
1216 | upvar argvec argvec | |
1217 | foreach var $args value [lreplace $line 0 0] { | |
1218 | set argvec($var) $value | |
1219 | } | |
1220 | } | |
1221 | ||
1d24041a TT |
1222 | # This is a miniature assembler for location expressions. It is |
1223 | # suitable for use in the attributes to a DIE. Its output is | |
1224 | # prefixed with "=" to make it automatically use DW_FORM_block. | |
6b0933da | 1225 | # |
1d24041a | 1226 | # BODY is split by lines, and each line is taken to be a list. |
6b0933da SM |
1227 | # |
1228 | # DWARF_VERSION is the DWARF version for the section where the location | |
1229 | # description is found. | |
1230 | # | |
1231 | # ADDR_SIZE is the length in bytes (4 or 8) of an address on the target | |
1232 | # machine (typically found in the header of the section where the location | |
1233 | # description is found). | |
1234 | # | |
1235 | # OFFSET_SIZE is the length in bytes (4 or 8) of an offset into a DWARF | |
1236 | # section. This typically depends on whether 32-bit or 64-bit DWARF is | |
1237 | # used, as indicated in the header of the section where the location | |
1238 | # description is found. | |
1239 | # | |
1d24041a TT |
1240 | # (FIXME should use 'info complete' here.) |
1241 | # Each list's first element is the opcode, either short or long | |
1242 | # forms are accepted. | |
1243 | # FIXME argument handling | |
1244 | # FIXME move docs | |
6b0933da | 1245 | proc _location { body dwarf_version addr_size offset_size } { |
1d24041a TT |
1246 | variable _constants |
1247 | ||
1248 | foreach line [split $body \n] { | |
4ff709eb TT |
1249 | # Ignore blank lines, and allow embedded comments. |
1250 | if {[lindex $line 0] == "" || [regexp -- {^[ \t]*#} $line]} { | |
1d24041a TT |
1251 | continue |
1252 | } | |
1253 | set opcode [_map_name [lindex $line 0] _OP] | |
1254 | _op .byte $_constants($opcode) $opcode | |
1255 | ||
3f49d080 | 1256 | array unset argvec * |
1d24041a TT |
1257 | switch -exact -- $opcode { |
1258 | DW_OP_addr { | |
3f49d080 TT |
1259 | _get_args $line $opcode size |
1260 | _op .${addr_size}byte $argvec(size) | |
1d24041a TT |
1261 | } |
1262 | ||
61dee722 AB |
1263 | DW_OP_GNU_addr_index { |
1264 | variable _debug_addr_index | |
1265 | variable _cu_addr_size | |
1266 | ||
1267 | _op .uleb128 ${_debug_addr_index} | |
1268 | incr _debug_addr_index | |
1269 | ||
1270 | _defer_output .debug_addr { | |
1271 | _op .${_cu_addr_size}byte [lindex $line 1] | |
1272 | } | |
1273 | } | |
1274 | ||
0fde2c53 | 1275 | DW_OP_regx { |
3f49d080 TT |
1276 | _get_args $line $opcode register |
1277 | _op .uleb128 $argvec(register) | |
0fde2c53 DE |
1278 | } |
1279 | ||
4ff709eb | 1280 | DW_OP_pick - |
1d24041a TT |
1281 | DW_OP_const1u - |
1282 | DW_OP_const1s { | |
3f49d080 TT |
1283 | _get_args $line $opcode const |
1284 | _op .byte $argvec(const) | |
1d24041a TT |
1285 | } |
1286 | ||
1287 | DW_OP_const2u - | |
1288 | DW_OP_const2s { | |
3f49d080 TT |
1289 | _get_args $line $opcode const |
1290 | _op .2byte $argvec(const) | |
1d24041a TT |
1291 | } |
1292 | ||
1293 | DW_OP_const4u - | |
1294 | DW_OP_const4s { | |
3f49d080 TT |
1295 | _get_args $line $opcode const |
1296 | _op .4byte $argvec(const) | |
1d24041a TT |
1297 | } |
1298 | ||
1299 | DW_OP_const8u - | |
1300 | DW_OP_const8s { | |
3f49d080 TT |
1301 | _get_args $line $opcode const |
1302 | _op .8byte $argvec(const) | |
1d24041a TT |
1303 | } |
1304 | ||
1305 | DW_OP_constu { | |
3f49d080 TT |
1306 | _get_args $line $opcode const |
1307 | _op .uleb128 $argvec(const) | |
1d24041a TT |
1308 | } |
1309 | DW_OP_consts { | |
3f49d080 TT |
1310 | _get_args $line $opcode const |
1311 | _op .sleb128 $argvec(const) | |
1d24041a TT |
1312 | } |
1313 | ||
16b5a7cb | 1314 | DW_OP_plus_uconst { |
3f49d080 TT |
1315 | _get_args $line $opcode const |
1316 | _op .uleb128 $argvec(const) | |
16b5a7cb AB |
1317 | } |
1318 | ||
5bd1ef56 | 1319 | DW_OP_piece { |
3f49d080 TT |
1320 | _get_args $line $opcode size |
1321 | _op .uleb128 $argvec(size) | |
5bd1ef56 TT |
1322 | } |
1323 | ||
16b5a7cb | 1324 | DW_OP_bit_piece { |
3f49d080 TT |
1325 | _get_args $line $opcode size offset |
1326 | _op .uleb128 $argvec(size) | |
1327 | _op .uleb128 $argvec(offset) | |
16b5a7cb AB |
1328 | } |
1329 | ||
4ff709eb TT |
1330 | DW_OP_skip - |
1331 | DW_OP_bra { | |
3f49d080 TT |
1332 | _get_args $line $opcode label |
1333 | _op .2byte $argvec(label) | |
4ff709eb TT |
1334 | } |
1335 | ||
f13a9a0c YQ |
1336 | DW_OP_implicit_value { |
1337 | set l1 [new_label "value_start"] | |
1338 | set l2 [new_label "value_end"] | |
1339 | _op .uleb128 "$l2 - $l1" | |
1340 | define_label $l1 | |
1341 | foreach value [lrange $line 1 end] { | |
1342 | switch -regexp -- $value { | |
1343 | {^0x[[:xdigit:]]{1,2}$} {_op .byte $value} | |
1344 | {^0x[[:xdigit:]]{4}$} {_op .2byte $value} | |
1345 | {^0x[[:xdigit:]]{8}$} {_op .4byte $value} | |
1346 | {^0x[[:xdigit:]]{16}$} {_op .8byte $value} | |
1347 | default { | |
1348 | error "bad value '$value' in DW_OP_implicit_value" | |
1349 | } | |
1350 | } | |
1351 | } | |
1352 | define_label $l2 | |
1353 | } | |
1354 | ||
7942e96e | 1355 | DW_OP_implicit_pointer - |
b6807d98 | 1356 | DW_OP_GNU_implicit_pointer { |
3f49d080 | 1357 | _get_args $line $opcode label offset |
b6807d98 TT |
1358 | |
1359 | # Here label is a section offset. | |
6b0933da | 1360 | if { $dwarf_version == 2 } { |
3f49d080 | 1361 | _op .${addr_size}byte $argvec(label) |
5ac95241 | 1362 | } else { |
a5ac8e7f | 1363 | _op_offset $offset_size $argvec(label) |
5ac95241 | 1364 | } |
3f49d080 | 1365 | _op .sleb128 $argvec(offset) |
b6807d98 TT |
1366 | } |
1367 | ||
ae3a7c47 | 1368 | DW_OP_GNU_variable_value { |
3f49d080 | 1369 | _get_args $line $opcode label |
ae3a7c47 KB |
1370 | |
1371 | # Here label is a section offset. | |
6b0933da | 1372 | if { $dwarf_version == 2 } { |
3f49d080 | 1373 | _op .${addr_size}byte $argvec(label) |
ae3a7c47 | 1374 | } else { |
a5ac8e7f | 1375 | _op_offset $offset_size $argvec(label) |
ae3a7c47 KB |
1376 | } |
1377 | } | |
1378 | ||
b39a8faf | 1379 | DW_OP_deref_size { |
3f49d080 TT |
1380 | _get_args $line $opcode size |
1381 | _op .byte $argvec(size) | |
b39a8faf YQ |
1382 | } |
1383 | ||
5f3ff4f8 | 1384 | DW_OP_bregx { |
3f49d080 TT |
1385 | _get_args $line $opcode register offset |
1386 | _op .uleb128 $argvec(register) | |
1387 | _op .sleb128 $argvec(offset) | |
5f3ff4f8 JK |
1388 | } |
1389 | ||
ac4d323e TBA |
1390 | DW_OP_fbreg { |
1391 | _get_args $line $opcode offset | |
1392 | _op .sleb128 $argvec(offset) | |
1393 | } | |
1394 | ||
183657ed ZZ |
1395 | DW_OP_fbreg { |
1396 | _op .sleb128 [lindex $line 1] | |
1397 | } | |
1398 | ||
1d24041a TT |
1399 | default { |
1400 | if {[llength $line] > 1} { | |
1401 | error "Unimplemented: operands in location for $opcode" | |
1402 | } | |
1403 | } | |
1404 | } | |
1405 | } | |
1406 | } | |
1407 | ||
61dee722 AB |
1408 | # Return a label that references the current position in the |
1409 | # .debug_addr table. When a user is creating split DWARF they | |
1410 | # will define two CUs, the first will be the split DWARF content, | |
1411 | # and the second will be the non-split stub CU. The split DWARF | |
1412 | # CU fills in the .debug_addr section, but the non-split CU | |
1413 | # includes a reference to the start of the section. The label | |
1414 | # returned by this proc provides that reference. | |
1415 | proc debug_addr_label {} { | |
1416 | variable _debug_addr_index | |
1417 | ||
1418 | set lbl [new_label "debug_addr_idx_${_debug_addr_index}_"] | |
1419 | _defer_output .debug_addr { | |
1420 | define_label $lbl | |
1421 | } | |
1422 | return $lbl | |
1423 | } | |
1424 | ||
1d24041a | 1425 | # Emit a DWARF CU. |
6c9e2db4 DE |
1426 | # OPTIONS is a list with an even number of elements containing |
1427 | # option-name and option-value pairs. | |
1428 | # Current options are: | |
1429 | # is_64 0|1 - boolean indicating if you want to emit 64-bit DWARF | |
1430 | # default = 0 (32-bit) | |
1431 | # version n - DWARF version number to emit | |
1432 | # default = 4 | |
054a0959 | 1433 | # addr_size n - the size of addresses in bytes: 4, 8, or default |
e630b974 | 1434 | # default = default |
6c9e2db4 DE |
1435 | # fission 0|1 - boolean indicating if generating Fission debug info |
1436 | # default = 0 | |
698c974f TV |
1437 | # label <label> |
1438 | # - string indicating label to be defined at the start | |
1439 | # of the CU header. | |
1440 | # default = "" | |
1d24041a TT |
1441 | # BODY is Tcl code that emits the DIEs which make up the body of |
1442 | # the CU. It is evaluated in the caller's context. | |
6c9e2db4 | 1443 | proc cu {options body} { |
eab9267c | 1444 | variable _constants |
1d24041a | 1445 | variable _cu_count |
6c9e2db4 | 1446 | variable _abbrev_section |
1d24041a TT |
1447 | variable _abbrev_num |
1448 | variable _cu_label | |
1449 | variable _cu_version | |
1450 | variable _cu_addr_size | |
1451 | variable _cu_offset_size | |
61dee722 | 1452 | variable _cu_is_fission |
1d24041a | 1453 | |
6c9e2db4 DE |
1454 | # Establish the defaults. |
1455 | set is_64 0 | |
1456 | set _cu_version 4 | |
e630b974 | 1457 | set _cu_addr_size default |
61dee722 | 1458 | set _cu_is_fission 0 |
6c9e2db4 DE |
1459 | set section ".debug_info" |
1460 | set _abbrev_section ".debug_abbrev" | |
698c974f | 1461 | set label "" |
6c9e2db4 DE |
1462 | |
1463 | foreach { name value } $options { | |
f13a9a0c | 1464 | set value [uplevel 1 "subst \"$value\""] |
6c9e2db4 DE |
1465 | switch -exact -- $name { |
1466 | is_64 { set is_64 $value } | |
1467 | version { set _cu_version $value } | |
1468 | addr_size { set _cu_addr_size $value } | |
61dee722 | 1469 | fission { set _cu_is_fission $value } |
698c974f | 1470 | label { set label $value } |
6c9e2db4 DE |
1471 | default { error "unknown option $name" } |
1472 | } | |
1473 | } | |
e630b974 TT |
1474 | if {$_cu_addr_size == "default"} { |
1475 | if {[is_64_target]} { | |
1476 | set _cu_addr_size 8 | |
1477 | } else { | |
1478 | set _cu_addr_size 4 | |
1479 | } | |
1480 | } | |
6c9e2db4 | 1481 | set _cu_offset_size [expr { $is_64 ? 8 : 4 }] |
61dee722 | 1482 | if { $_cu_is_fission } { |
6c9e2db4 DE |
1483 | set section ".debug_info.dwo" |
1484 | set _abbrev_section ".debug_abbrev.dwo" | |
1d24041a | 1485 | } |
1d24041a | 1486 | |
eab9267c MW |
1487 | if {$_cu_version < 4} { |
1488 | set _constants(SPECIAL_expr) $_constants(DW_FORM_block) | |
1489 | } else { | |
1490 | set _constants(SPECIAL_expr) $_constants(DW_FORM_exprloc) | |
1491 | } | |
1492 | ||
6c9e2db4 | 1493 | _section $section |
1d24041a TT |
1494 | |
1495 | set cu_num [incr _cu_count] | |
1496 | set my_abbrevs [_compute_label "abbrev${cu_num}_begin"] | |
1497 | set _abbrev_num 1 | |
1498 | ||
1499 | set _cu_label [_compute_label "cu${cu_num}_begin"] | |
1500 | set start_label [_compute_label "cu${cu_num}_start"] | |
1501 | set end_label [_compute_label "cu${cu_num}_end"] | |
28d2bfb9 | 1502 | |
698c974f TV |
1503 | if { $label != "" } { |
1504 | upvar $label my_label | |
1505 | set my_label $_cu_label | |
1506 | } | |
1507 | ||
1d24041a TT |
1508 | define_label $_cu_label |
1509 | if {$is_64} { | |
1510 | _op .4byte 0xffffffff | |
1511 | _op .8byte "$end_label - $start_label" | |
1512 | } else { | |
1513 | _op .4byte "$end_label - $start_label" | |
1514 | } | |
1515 | define_label $start_label | |
6c9e2db4 | 1516 | _op .2byte $_cu_version Version |
962effa7 SM |
1517 | |
1518 | # The CU header for DWARF 4 and 5 are slightly different. | |
1519 | if { $_cu_version == 5 } { | |
1520 | _op .byte 0x1 "DW_UT_compile" | |
1521 | _op .byte $_cu_addr_size "Pointer size" | |
a5ac8e7f | 1522 | _op_offset $_cu_offset_size $my_abbrevs Abbrevs |
962effa7 | 1523 | } else { |
a5ac8e7f | 1524 | _op_offset $_cu_offset_size $my_abbrevs Abbrevs |
962effa7 SM |
1525 | _op .byte $_cu_addr_size "Pointer size" |
1526 | } | |
1d24041a | 1527 | |
6c9e2db4 | 1528 | _defer_output $_abbrev_section { |
1d24041a TT |
1529 | define_label $my_abbrevs |
1530 | } | |
1531 | ||
1532 | uplevel $body | |
1533 | ||
6c9e2db4 | 1534 | _defer_output $_abbrev_section { |
1d24041a | 1535 | # Emit the terminator. |
c40907bf | 1536 | _op .byte 0x0 "Abbrev end - Terminator" |
1d24041a TT |
1537 | } |
1538 | ||
1539 | define_label $end_label | |
1540 | } | |
1541 | ||
4f22ed5c | 1542 | # Emit a DWARF TU. |
6c9e2db4 DE |
1543 | # OPTIONS is a list with an even number of elements containing |
1544 | # option-name and option-value pairs. | |
1545 | # Current options are: | |
1546 | # is_64 0|1 - boolean indicating if you want to emit 64-bit DWARF | |
1547 | # default = 0 (32-bit) | |
1548 | # version n - DWARF version number to emit | |
1549 | # default = 4 | |
054a0959 | 1550 | # addr_size n - the size of addresses in bytes: 4, 8, or default |
e630b974 | 1551 | # default = default |
6c9e2db4 DE |
1552 | # fission 0|1 - boolean indicating if generating Fission debug info |
1553 | # default = 0 | |
4f22ed5c | 1554 | # SIGNATURE is the 64-bit signature of the type. |
6c9e2db4 DE |
1555 | # TYPE_LABEL is the label of the type defined by this TU, |
1556 | # or "" if there is no type (i.e., type stubs in Fission). | |
4f22ed5c | 1557 | # BODY is Tcl code that emits the DIEs which make up the body of |
6c9e2db4 DE |
1558 | # the TU. It is evaluated in the caller's context. |
1559 | proc tu {options signature type_label body} { | |
4f22ed5c | 1560 | variable _cu_count |
6c9e2db4 | 1561 | variable _abbrev_section |
4f22ed5c DE |
1562 | variable _abbrev_num |
1563 | variable _cu_label | |
1564 | variable _cu_version | |
1565 | variable _cu_addr_size | |
1566 | variable _cu_offset_size | |
61dee722 | 1567 | variable _cu_is_fission |
4f22ed5c | 1568 | |
6c9e2db4 DE |
1569 | # Establish the defaults. |
1570 | set is_64 0 | |
1571 | set _cu_version 4 | |
e630b974 | 1572 | set _cu_addr_size default |
61dee722 | 1573 | set _cu_is_fission 0 |
6c9e2db4 DE |
1574 | set section ".debug_types" |
1575 | set _abbrev_section ".debug_abbrev" | |
4c146f5d | 1576 | set label "" |
6c9e2db4 DE |
1577 | |
1578 | foreach { name value } $options { | |
d878bb39 | 1579 | set value [uplevel 1 "subst \"$value\""] |
6c9e2db4 DE |
1580 | switch -exact -- $name { |
1581 | is_64 { set is_64 $value } | |
1582 | version { set _cu_version $value } | |
1583 | addr_size { set _cu_addr_size $value } | |
61dee722 | 1584 | fission { set _cu_is_fission $value } |
4c146f5d | 1585 | label { set label $value } |
6c9e2db4 DE |
1586 | default { error "unknown option $name" } |
1587 | } | |
1588 | } | |
e630b974 TT |
1589 | if {$_cu_addr_size == "default"} { |
1590 | if {[is_64_target]} { | |
1591 | set _cu_addr_size 8 | |
1592 | } else { | |
1593 | set _cu_addr_size 4 | |
1594 | } | |
1595 | } | |
6c9e2db4 | 1596 | set _cu_offset_size [expr { $is_64 ? 8 : 4 }] |
d878bb39 TV |
1597 | if { $_cu_version == 5 } { |
1598 | set section ".debug_info" | |
1599 | } | |
61dee722 | 1600 | if { $_cu_is_fission } { |
d878bb39 TV |
1601 | set section "$section.dwo" |
1602 | set _abbrev_section "$section.dwo" | |
4f22ed5c | 1603 | } |
4f22ed5c | 1604 | |
6c9e2db4 | 1605 | _section $section |
4f22ed5c DE |
1606 | |
1607 | set cu_num [incr _cu_count] | |
1608 | set my_abbrevs [_compute_label "abbrev${cu_num}_begin"] | |
1609 | set _abbrev_num 1 | |
1610 | ||
1611 | set _cu_label [_compute_label "cu${cu_num}_begin"] | |
1612 | set start_label [_compute_label "cu${cu_num}_start"] | |
1613 | set end_label [_compute_label "cu${cu_num}_end"] | |
1614 | ||
4c146f5d TV |
1615 | if { $label != "" } { |
1616 | upvar $label my_label | |
1617 | set my_label $_cu_label | |
1618 | } | |
1619 | ||
4f22ed5c DE |
1620 | define_label $_cu_label |
1621 | if {$is_64} { | |
1622 | _op .4byte 0xffffffff | |
1623 | _op .8byte "$end_label - $start_label" | |
1624 | } else { | |
1625 | _op .4byte "$end_label - $start_label" | |
1626 | } | |
1627 | define_label $start_label | |
6c9e2db4 | 1628 | _op .2byte $_cu_version Version |
d878bb39 TV |
1629 | |
1630 | # The CU header for DWARF 4 and 5 are slightly different. | |
1631 | if { $_cu_version == 5 } { | |
1632 | _op .byte 0x2 "DW_UT_type" | |
1633 | _op .byte $_cu_addr_size "Pointer size" | |
1634 | _op_offset $_cu_offset_size $my_abbrevs Abbrevs | |
1635 | } else { | |
1636 | _op_offset $_cu_offset_size $my_abbrevs Abbrevs | |
1637 | _op .byte $_cu_addr_size "Pointer size" | |
1638 | } | |
1639 | ||
4f22ed5c | 1640 | _op .8byte $signature Signature |
6c9e2db4 DE |
1641 | if { $type_label != "" } { |
1642 | uplevel declare_labels $type_label | |
1643 | upvar $type_label my_type_label | |
1644 | if {$is_64} { | |
1645 | _op .8byte "$my_type_label - $_cu_label" | |
1646 | } else { | |
1647 | _op .4byte "$my_type_label - $_cu_label" | |
1648 | } | |
4f22ed5c | 1649 | } else { |
6c9e2db4 DE |
1650 | if {$is_64} { |
1651 | _op .8byte 0 | |
1652 | } else { | |
1653 | _op .4byte 0 | |
1654 | } | |
4f22ed5c DE |
1655 | } |
1656 | ||
6c9e2db4 | 1657 | _defer_output $_abbrev_section { |
4f22ed5c DE |
1658 | define_label $my_abbrevs |
1659 | } | |
1660 | ||
1661 | uplevel $body | |
1662 | ||
6c9e2db4 | 1663 | _defer_output $_abbrev_section { |
4f22ed5c | 1664 | # Emit the terminator. |
c40907bf | 1665 | _op .byte 0x0 "Abbrev end - Terminator" |
4f22ed5c DE |
1666 | } |
1667 | ||
1668 | define_label $end_label | |
1669 | } | |
1670 | ||
28d2bfb9 AB |
1671 | # Emit a DWARF .debug_ranges unit. |
1672 | # OPTIONS is a list with an even number of elements containing | |
1673 | # option-name and option-value pairs. | |
1674 | # Current options are: | |
1675 | # is_64 0|1 - boolean indicating if you want to emit 64-bit DWARF | |
1676 | # default = 0 (32-bit) | |
1677 | # | |
1678 | # BODY is Tcl code that emits the content of the .debug_ranges | |
1679 | # unit, it is evaluated in the caller's context. | |
1680 | proc ranges {options body} { | |
1681 | variable _debug_ranges_64_bit | |
1682 | ||
1683 | foreach { name value } $options { | |
1684 | switch -exact -- $name { | |
1685 | is_64 { set _debug_ranges_64_bit [subst $value] } | |
1686 | default { error "unknown option $name" } | |
1687 | } | |
1688 | } | |
1689 | ||
1690 | set section ".debug_ranges" | |
1691 | _section $section | |
1692 | ||
a1945bd4 | 1693 | proc sequence { body } { |
28d2bfb9 AB |
1694 | variable _debug_ranges_64_bit |
1695 | ||
1696 | # Emit the sequence of addresses. | |
a1945bd4 SM |
1697 | |
1698 | proc base { addr } { | |
1699 | variable _debug_ranges_64_bit | |
1700 | ||
d4c45423 | 1701 | if {$_debug_ranges_64_bit} { |
a1945bd4 SM |
1702 | _op .8byte 0xffffffffffffffff "Base Marker" |
1703 | _op .8byte $addr "Base Address" | |
1704 | } else { | |
1705 | _op .4byte 0xffffffff "Base Marker" | |
1706 | _op .4byte $addr "Base Address" | |
28d2bfb9 AB |
1707 | } |
1708 | } | |
1709 | ||
a1945bd4 SM |
1710 | proc range { start end } { |
1711 | variable _debug_ranges_64_bit | |
1712 | ||
d4c45423 | 1713 | if {$_debug_ranges_64_bit} { |
a1945bd4 SM |
1714 | _op .8byte $start "Start Address" |
1715 | _op .8byte $end "End Address" | |
1716 | } else { | |
1717 | _op .4byte $start "Start Address" | |
1718 | _op .4byte $end "End Address" | |
1719 | } | |
1720 | } | |
1721 | ||
1722 | uplevel $body | |
1723 | ||
28d2bfb9 | 1724 | # End of the sequence. |
d4c45423 | 1725 | if {$_debug_ranges_64_bit} { |
28d2bfb9 AB |
1726 | _op .8byte 0x0 "End of Sequence Marker (Part 1)" |
1727 | _op .8byte 0x0 "End of Sequence Marker (Part 2)" | |
1728 | } else { | |
1729 | _op .4byte 0x0 "End of Sequence Marker (Part 1)" | |
1730 | _op .4byte 0x0 "End of Sequence Marker (Part 2)" | |
1731 | } | |
1732 | } | |
1733 | ||
1734 | uplevel $body | |
1735 | } | |
1736 | ||
962effa7 SM |
1737 | # Emit a DWARF .debug_rnglists section. |
1738 | # | |
1739 | # The target address size is based on the current target's address size. | |
1740 | # | |
46a5b75b SM |
1741 | # BODY must be Tcl code that emits the content of the section. It is |
1742 | # evaluated in the caller's context. | |
962effa7 | 1743 | # |
46a5b75b SM |
1744 | # The `is-64 true|false` options tells whether to use 64-bit DWARF instead |
1745 | # of 32-bit DWARF. The default is 32-bit. | |
962effa7 | 1746 | |
46a5b75b | 1747 | proc rnglists { options body } { |
962effa7 SM |
1748 | variable _debug_rnglists_addr_size |
1749 | variable _debug_rnglists_offset_size | |
1750 | variable _debug_rnglists_is_64_dwarf | |
1751 | ||
46a5b75b | 1752 | parse_options {{"is-64" "false"}} |
962effa7 SM |
1753 | |
1754 | if [is_64_target] { | |
1755 | set _debug_rnglists_addr_size 8 | |
1756 | } else { | |
1757 | set _debug_rnglists_addr_size 4 | |
1758 | } | |
1759 | ||
1760 | if { ${is-64} } { | |
1761 | set _debug_rnglists_offset_size 8 | |
1762 | set _debug_rnglists_is_64_dwarf true | |
1763 | } else { | |
1764 | set _debug_rnglists_offset_size 4 | |
1765 | set _debug_rnglists_is_64_dwarf false | |
1766 | } | |
1767 | ||
1768 | _section ".debug_rnglists" | |
1769 | ||
1770 | # Count of tables in the section. | |
1771 | variable _debug_rnglists_table_count 0 | |
1772 | ||
1773 | # Compute the label name for list at index LIST_IDX, for the current | |
1774 | # table. | |
1775 | ||
1776 | proc _compute_list_label { list_idx } { | |
1777 | variable _debug_rnglists_table_count | |
1778 | ||
1779 | return ".Lrnglists_table_${_debug_rnglists_table_count}_list_${list_idx}" | |
1780 | } | |
1781 | ||
c5dfcc21 SM |
1782 | with_override Dwarf::table Dwarf::_rnglists_table { |
1783 | uplevel $body | |
1784 | } | |
1785 | } | |
962effa7 | 1786 | |
c5dfcc21 SM |
1787 | # Generate one rnglists table (header + offset array + range lists). |
1788 | # | |
1789 | # This proc is meant to be used within proc rnglists' body. It is made | |
1790 | # available as `table` while inside proc rnglists' body. | |
1791 | # | |
46a5b75b SM |
1792 | # BODY must be Tcl code that emits the content of the table. It may call |
1793 | # the LIST_ procedure to generate rnglists. It is evaluated in the | |
1794 | # caller's context. | |
c5dfcc21 | 1795 | # |
46a5b75b | 1796 | # The `post-header-label` option can be used to define a label just after |
c5dfcc21 SM |
1797 | # the header of the table. This is the label that a DW_AT_rnglists_base |
1798 | # attribute will usually refer to. | |
1799 | # | |
46a5b75b | 1800 | # The `with-offset-array true|false` option can be used to control whether |
c5dfcc21 SM |
1801 | # the headers of the location list tables have an array of offset. The |
1802 | # default is true. | |
962effa7 | 1803 | |
46a5b75b | 1804 | proc _rnglists_table { options body } { |
c5dfcc21 SM |
1805 | variable _debug_rnglists_table_count |
1806 | variable _debug_rnglists_addr_size | |
1807 | variable _debug_rnglists_offset_size | |
1808 | variable _debug_rnglists_is_64_dwarf | |
962effa7 | 1809 | |
46a5b75b | 1810 | parse_options { |
c5dfcc21 SM |
1811 | {post-header-label ""} |
1812 | {with-offset-array true} | |
1813 | } | |
962effa7 | 1814 | |
c5dfcc21 SM |
1815 | # Count of lists in the table. |
1816 | variable _debug_rnglists_list_count 0 | |
962effa7 | 1817 | |
c5dfcc21 SM |
1818 | # Generate the lists ops first, because we need to know how many |
1819 | # lists there are to generate the header and offset table. | |
1820 | set lists_ops [_defer_to_string { | |
1821 | with_override Dwarf::list_ Dwarf::_rnglists_list { | |
962effa7 | 1822 | uplevel $body |
962effa7 | 1823 | } |
c5dfcc21 | 1824 | }] |
962effa7 | 1825 | |
c5dfcc21 SM |
1826 | set post_unit_len_label \ |
1827 | [_compute_label "rnglists_table_${_debug_rnglists_table_count}_post_unit_len"] | |
1828 | set post_header_label \ | |
1829 | [_compute_label "rnglists_table_${_debug_rnglists_table_count}_post_header"] | |
1830 | set table_end_label \ | |
1831 | [_compute_label "rnglists_table_${_debug_rnglists_table_count}_end"] | |
962effa7 | 1832 | |
c5dfcc21 SM |
1833 | # Emit the table header. |
1834 | if { $_debug_rnglists_is_64_dwarf } { | |
1835 | _op .4byte 0xffffffff "unit length 1/2" | |
1836 | _op .8byte "$table_end_label - $post_unit_len_label" "unit length 2/2" | |
1837 | } else { | |
1838 | _op .4byte "$table_end_label - $post_unit_len_label" "unit length" | |
1839 | } | |
9307efbe | 1840 | |
c5dfcc21 | 1841 | define_label $post_unit_len_label |
962effa7 | 1842 | |
c5dfcc21 SM |
1843 | _op .2byte 5 "dwarf version" |
1844 | _op .byte $_debug_rnglists_addr_size "address size" | |
1845 | _op .byte 0 "segment selector size" | |
962effa7 | 1846 | |
c5dfcc21 SM |
1847 | if { ${with-offset-array} } { |
1848 | _op .4byte "$_debug_rnglists_list_count" "offset entry count" | |
1849 | } else { | |
1850 | _op .4byte 0 "offset entry count" | |
1851 | } | |
962effa7 | 1852 | |
c5dfcc21 SM |
1853 | define_label $post_header_label |
1854 | ||
1855 | # Define the user post-header label, if provided. | |
1856 | if { ${post-header-label} != "" } { | |
1857 | define_label ${post-header-label} | |
1858 | } | |
1859 | ||
1860 | # Emit the offset array. | |
1861 | if { ${with-offset-array} } { | |
1862 | for {set list_idx 0} {$list_idx < $_debug_rnglists_list_count} {incr list_idx} { | |
1863 | set list_label [_compute_list_label $list_idx] | |
a5ac8e7f TV |
1864 | _op_offset $_debug_rnglists_offset_size \ |
1865 | "$list_label - $post_header_label" \ | |
1866 | "offset of list $list_idx" | |
962effa7 | 1867 | } |
c5dfcc21 SM |
1868 | } |
1869 | ||
1870 | # Emit the actual list data. | |
1871 | _emit "$lists_ops" | |
962effa7 | 1872 | |
c5dfcc21 | 1873 | define_label $table_end_label |
962effa7 | 1874 | |
c5dfcc21 SM |
1875 | incr _debug_rnglists_table_count |
1876 | } | |
962effa7 | 1877 | |
c5dfcc21 SM |
1878 | # Generate one rnglists range list. |
1879 | # | |
1880 | # This proc is meant to be used within proc _rnglists_table's body. It is | |
1881 | # made available as `list_` while inside proc _rnglists_table's body. | |
1882 | # | |
1883 | # BODY may call the various procs defined below to generate list entries. | |
1884 | # They correspond to the range list entry kinds described in section 2.17.3 | |
1885 | # of the DWARF 5 spec. | |
1886 | # | |
1887 | # To define a label pointing to the beginning of the list, use the | |
1888 | # conventional way of declaring and defining labels: | |
1889 | # | |
1890 | # declare_labels the_list | |
1891 | # | |
1892 | # the_list: list_ { ... } | |
1893 | ||
1894 | proc _rnglists_list { body } { | |
1895 | variable _debug_rnglists_list_count | |
1896 | ||
1897 | # Define a label for this list. It is used to build the offset | |
1898 | # array later. | |
1899 | set list_label [_compute_list_label $_debug_rnglists_list_count] | |
1900 | define_label $list_label | |
1901 | ||
1902 | with_override Dwarf::start_end Dwarf::_rnglists_start_end { | |
1903 | uplevel $body | |
962effa7 SM |
1904 | } |
1905 | ||
c5dfcc21 SM |
1906 | # Emit end of list. |
1907 | _op .byte 0x00 "DW_RLE_end_of_list" | |
1908 | ||
1909 | incr _debug_rnglists_list_count | |
1910 | } | |
1911 | ||
1912 | # Emit a rnglists DW_RLE_start_end entry. | |
1913 | # | |
1914 | # This proc is meant to be used within proc _rnglists_list's body. It is | |
1915 | # made available as `start_end` while inside proc _rnglists_list's body. | |
1916 | ||
1917 | proc _rnglists_start_end { start end } { | |
1918 | variable _debug_rnglists_addr_size | |
1919 | ||
1920 | _op .byte 0x06 "DW_RLE_start_end" | |
1921 | _op .${_debug_rnglists_addr_size}byte $start "start" | |
1922 | _op .${_debug_rnglists_addr_size}byte $end "end" | |
962effa7 | 1923 | } |
28d2bfb9 | 1924 | |
ecfda20d SM |
1925 | # Emit a DWARF .debug_loclists section. |
1926 | # | |
1927 | # The target address size is based on the current target's address size. | |
1928 | # | |
46a5b75b SM |
1929 | # BODY must be Tcl code that emits the content of the section. It is |
1930 | # evaluated in the caller's context. | |
ecfda20d | 1931 | # |
46a5b75b SM |
1932 | # The `is-64 true|false` options tells whether to use 64-bit DWARF instead |
1933 | # of 32-bit DWARF. The default is 32-bit. | |
ecfda20d | 1934 | |
46a5b75b | 1935 | proc loclists { options body } { |
ecfda20d SM |
1936 | variable _debug_loclists_addr_size |
1937 | variable _debug_loclists_offset_size | |
1938 | variable _debug_loclists_is_64_dwarf | |
1939 | ||
46a5b75b | 1940 | parse_options {{"is-64" "false"}} |
ecfda20d SM |
1941 | |
1942 | if [is_64_target] { | |
1943 | set _debug_loclists_addr_size 8 | |
1944 | } else { | |
1945 | set _debug_loclists_addr_size 4 | |
1946 | } | |
1947 | ||
1948 | if { ${is-64} } { | |
1949 | set _debug_loclists_offset_size 8 | |
1950 | set _debug_loclists_is_64_dwarf true | |
1951 | } else { | |
1952 | set _debug_loclists_offset_size 4 | |
1953 | set _debug_loclists_is_64_dwarf false | |
1954 | } | |
1955 | ||
1956 | _section ".debug_loclists" | |
1957 | ||
1958 | # Count of tables in the section. | |
1959 | variable _debug_loclists_table_count 0 | |
1960 | ||
1961 | # Compute the label name for list at index LIST_IDX, for the current | |
1962 | # table. | |
1963 | ||
1964 | proc _compute_list_label { list_idx } { | |
1965 | variable _debug_loclists_table_count | |
1966 | ||
1967 | return ".Lloclists_table_${_debug_loclists_table_count}_list_${list_idx}" | |
1968 | } | |
1969 | ||
c5dfcc21 SM |
1970 | with_override Dwarf::table Dwarf::_loclists_table { |
1971 | uplevel $body | |
1972 | } | |
1973 | } | |
1974 | ||
1975 | # Generate one loclists table (header + offset array + location lists). | |
1976 | # | |
1977 | # This proc is meant to be used within proc loclists' body. It is made | |
1978 | # available as `table` while inside proc rnglists' body. | |
1979 | # | |
46a5b75b SM |
1980 | # BODY must be Tcl code that emits the content of the table. It may call |
1981 | # the LIST_ procedure to generate rnglists. It is evaluated in the | |
1982 | # caller's context. | |
c5dfcc21 | 1983 | # |
46a5b75b SM |
1984 | # The `post-header-label` option can be used to define a label just after |
1985 | # the header of the table. This is the label that a DW_AT_loclists_base | |
c5dfcc21 SM |
1986 | # attribute will usually refer to. |
1987 | # | |
46a5b75b | 1988 | # The `with-offset-array true|false` option can be used to control |
c5dfcc21 SM |
1989 | # whether the headers of the location list tables have an array of |
1990 | # offset. The default is true. | |
1991 | ||
46a5b75b | 1992 | proc _loclists_table { options body } { |
c5dfcc21 SM |
1993 | variable _debug_loclists_table_count |
1994 | variable _debug_loclists_addr_size | |
1995 | variable _debug_loclists_offset_size | |
1996 | variable _debug_loclists_is_64_dwarf | |
1997 | ||
46a5b75b | 1998 | parse_options { |
c5dfcc21 SM |
1999 | {post-header-label ""} |
2000 | {with-offset-array true} | |
2001 | } | |
2002 | ||
c5dfcc21 SM |
2003 | # Count of lists in the table. |
2004 | variable _debug_loclists_list_count 0 | |
2005 | ||
2006 | # Generate the lists ops first, because we need to know how many | |
2007 | # lists there are to generate the header and offset table. | |
2008 | set lists_ops [_defer_to_string { | |
2009 | with_override Dwarf::list_ Dwarf::_loclists_list { | |
2010 | uplevel $body | |
9307efbe | 2011 | } |
c5dfcc21 SM |
2012 | }] |
2013 | ||
2014 | set post_unit_len_label \ | |
2015 | [_compute_label "loclists_table_${_debug_loclists_table_count}_post_unit_len"] | |
2016 | set post_header_label \ | |
2017 | [_compute_label "loclists_table_${_debug_loclists_table_count}_post_header"] | |
2018 | set table_end_label \ | |
2019 | [_compute_label "loclists_table_${_debug_loclists_table_count}_end"] | |
ecfda20d | 2020 | |
c5dfcc21 SM |
2021 | # Emit the table header. |
2022 | if { $_debug_loclists_is_64_dwarf } { | |
2023 | _op .4byte 0xffffffff "unit length 1/2" | |
2024 | _op .8byte "$table_end_label - $post_unit_len_label" "unit length 2/2" | |
2025 | } else { | |
2026 | _op .4byte "$table_end_label - $post_unit_len_label" "unit length" | |
2027 | } | |
2028 | ||
2029 | define_label $post_unit_len_label | |
2030 | ||
2031 | _op .2byte 5 "DWARF version" | |
2032 | _op .byte $_debug_loclists_addr_size "address size" | |
2033 | _op .byte 0 "segment selector size" | |
2034 | ||
2035 | if { ${with-offset-array} } { | |
2036 | _op .4byte "$_debug_loclists_list_count" "offset entry count" | |
2037 | } else { | |
2038 | _op .4byte 0 "offset entry count" | |
2039 | } | |
2040 | ||
2041 | define_label $post_header_label | |
2042 | ||
2043 | # Define the user post-header label, if provided. | |
2044 | if { ${post-header-label} != "" } { | |
2045 | define_label ${post-header-label} | |
2046 | } | |
2047 | ||
2048 | # Emit the offset array. | |
2049 | if { ${with-offset-array} } { | |
2050 | for {set list_idx 0} {$list_idx < $_debug_loclists_list_count} {incr list_idx} { | |
2051 | set list_label [_compute_list_label $list_idx] | |
a5ac8e7f TV |
2052 | _op_offset $_debug_loclists_offset_size \ |
2053 | "$list_label - $post_header_label" \ | |
2054 | "offset of list $list_idx" | |
ecfda20d | 2055 | } |
c5dfcc21 | 2056 | } |
ecfda20d | 2057 | |
c5dfcc21 SM |
2058 | # Emit the actual list data. |
2059 | _emit "$lists_ops" | |
80d1206d | 2060 | |
c5dfcc21 | 2061 | define_label $table_end_label |
80d1206d | 2062 | |
c5dfcc21 SM |
2063 | incr _debug_loclists_table_count |
2064 | } | |
80d1206d | 2065 | |
c5dfcc21 SM |
2066 | # Generate one loclists location list. |
2067 | # | |
2068 | # This proc is meant to be used within proc _loclists_table's body. It is | |
2069 | # made available as `list_` while inside proc _loclists_table's body. | |
2070 | # | |
2071 | # BODY may call the various procs defined below to generate list | |
2072 | # entries. They correspond to the location list entry kinds | |
2073 | # described in section 2.6.2 of the DWARF 5 spec. | |
2074 | # | |
2075 | # To define a label pointing to the beginning of the list, use | |
2076 | # the conventional way of declaring and defining labels: | |
2077 | # | |
2078 | # declare_labels the_list | |
2079 | # | |
2080 | # the_list: list_ { | |
2081 | # ... | |
2082 | # } | |
62df62b2 | 2083 | |
c5dfcc21 SM |
2084 | proc _loclists_list { body } { |
2085 | variable _debug_loclists_list_count | |
80d1206d | 2086 | |
c5dfcc21 SM |
2087 | # Count the location descriptions in this list. |
2088 | variable _debug_loclists_locdesc_count 0 | |
80d1206d | 2089 | |
c5dfcc21 SM |
2090 | # Define a label for this list. It is used to build the offset |
2091 | # array later. | |
2092 | set list_label [_compute_list_label $_debug_loclists_list_count] | |
2093 | define_label $list_label | |
80d1206d | 2094 | |
c5dfcc21 | 2095 | with_override Dwarf::start_length Dwarf::_loclists_start_length { |
7b9f73fa | 2096 | with_override Dwarf::base_address Dwarf::_loclists_base_address { |
c5dfcc21 SM |
2097 | with_override Dwarf::start_end Dwarf::_loclists_start_end { |
2098 | uplevel $body | |
7b9f73fa | 2099 | }}} |
ecfda20d | 2100 | |
c5dfcc21 SM |
2101 | # Emit end of list. |
2102 | _op .byte 0x00 "DW_LLE_end_of_list" | |
ecfda20d | 2103 | |
c5dfcc21 SM |
2104 | incr _debug_loclists_list_count |
2105 | } | |
ecfda20d | 2106 | |
c5dfcc21 SM |
2107 | # Emit a DW_LLE_start_length entry. |
2108 | # | |
2109 | # This proc is meant to be used within proc _loclists_list's body. It is | |
2110 | # made available as `start_length` while inside proc _loclists_list's body. | |
ecfda20d | 2111 | |
c5dfcc21 SM |
2112 | proc _loclists_start_length { start length locdesc } { |
2113 | variable _debug_loclists_is_64_dwarf | |
2114 | variable _debug_loclists_addr_size | |
2115 | variable _debug_loclists_offset_size | |
2116 | variable _debug_loclists_table_count | |
2117 | variable _debug_loclists_list_count | |
2118 | variable _debug_loclists_locdesc_count | |
ecfda20d | 2119 | |
c5dfcc21 | 2120 | set locdesc [uplevel [list subst $locdesc]] |
ecfda20d | 2121 | |
c5dfcc21 | 2122 | _op .byte 0x08 "DW_LLE_start_length" |
ecfda20d | 2123 | |
c5dfcc21 SM |
2124 | # Start and end of the address range. |
2125 | _op .${_debug_loclists_addr_size}byte $start "start" | |
2126 | _op .uleb128 $length "length" | |
ecfda20d | 2127 | |
c5dfcc21 SM |
2128 | # Length of location description. |
2129 | set locdesc_start_label ".Lloclists_table_${_debug_loclists_table_count}_list_${_debug_loclists_list_count}_locdesc_${_debug_loclists_locdesc_count}_start" | |
2130 | set locdesc_end_label ".Lloclists_table_${_debug_loclists_table_count}_list_${_debug_loclists_list_count}_locdesc_${_debug_loclists_locdesc_count}_end" | |
2131 | _op .uleb128 "$locdesc_end_label - $locdesc_start_label" "locdesc length" | |
9307efbe | 2132 | |
c5dfcc21 SM |
2133 | define_label $locdesc_start_label |
2134 | set dwarf_version 5 | |
2135 | _location $locdesc $dwarf_version $_debug_loclists_addr_size $_debug_loclists_offset_size | |
2136 | define_label $locdesc_end_label | |
ecfda20d | 2137 | |
c5dfcc21 SM |
2138 | incr _debug_loclists_locdesc_count |
2139 | } | |
ecfda20d | 2140 | |
c5dfcc21 SM |
2141 | # Emit a DW_LLE_start_end entry. |
2142 | # | |
2143 | # This proc is meant to be used within proc _loclists_list's body. It is | |
2144 | # made available as `start_end` while inside proc _loclists_list's body. | |
ecfda20d | 2145 | |
c5dfcc21 SM |
2146 | proc _loclists_start_end { start end locdesc } { |
2147 | variable _debug_loclists_is_64_dwarf | |
2148 | variable _debug_loclists_addr_size | |
2149 | variable _debug_loclists_offset_size | |
2150 | variable _debug_loclists_table_count | |
2151 | variable _debug_loclists_list_count | |
2152 | variable _debug_loclists_locdesc_count | |
ecfda20d | 2153 | |
c5dfcc21 | 2154 | set locdesc [uplevel [list subst $locdesc]] |
ecfda20d | 2155 | |
c5dfcc21 | 2156 | _op .byte 0x07 "DW_LLE_start_end" |
ecfda20d | 2157 | |
c5dfcc21 SM |
2158 | # Start and end of the address range. |
2159 | _op .${_debug_loclists_addr_size}byte $start "start" | |
2160 | _op .${_debug_loclists_addr_size}byte $end "end" | |
ecfda20d | 2161 | |
c5dfcc21 SM |
2162 | # Length of location description. |
2163 | set locdesc_start_label ".Lloclists_table_${_debug_loclists_table_count}_list_${_debug_loclists_list_count}_locdesc_${_debug_loclists_locdesc_count}_start" | |
2164 | set locdesc_end_label ".Lloclists_table_${_debug_loclists_table_count}_list_${_debug_loclists_list_count}_locdesc_${_debug_loclists_locdesc_count}_end" | |
2165 | _op .uleb128 "$locdesc_end_label - $locdesc_start_label" "locdesc length" | |
2166 | ||
2167 | define_label $locdesc_start_label | |
2168 | set dwarf_version 5 | |
2169 | _location $locdesc $dwarf_version $_debug_loclists_addr_size $_debug_loclists_offset_size | |
2170 | define_label $locdesc_end_label | |
2171 | ||
2172 | incr _debug_loclists_locdesc_count | |
ecfda20d SM |
2173 | } |
2174 | ||
7b9f73fa TT |
2175 | # Emit a DW_LLE_base_address entry. |
2176 | proc _loclists_base_address {addr} { | |
2177 | variable _debug_loclists_addr_size | |
2178 | variable _debug_loclists_locdesc_count | |
2179 | _op .byte 0x06 "DW_LLE_base_address" | |
2180 | _op .${_debug_loclists_addr_size}byte $addr "base_address" | |
2181 | incr _debug_loclists_locdesc_count | |
2182 | } | |
2183 | ||
7900b17e SM |
2184 | # Emit a DWARF .debug_macro section. |
2185 | # | |
2186 | # BODY must be Tcl code that emits the content of the section. It is | |
2187 | # evaluated in the caller's context. The body can use the `unit` proc | |
2188 | # (see `_macro_unit`) to generate macro units. | |
2189 | ||
2190 | proc macro { body } { | |
2191 | _section ".debug_macro" | |
2192 | ||
2193 | with_override Dwarf::unit Dwarf::_macro_unit { | |
2194 | uplevel $body | |
2195 | } | |
2196 | } | |
2197 | ||
2198 | # Generate one macro unit. | |
2199 | # | |
2200 | # This proc is meant to be used within proc macro's body. It is made | |
2201 | # available as `unit` while inside proc macro's body. | |
2202 | # | |
2203 | # BODY must be Tcl code that emits the content of the unit. It may call | |
2204 | # procedures defined below, prefixed with `_macro_unit_`, to generate the | |
2205 | # unit's content. It is evaluated in the caller's context. | |
2206 | # | |
2207 | # The `is-64 true|false` options tells whether to use 64-bit DWARF instead | |
2208 | # of 32-bit DWARF. The default is 32-bit. | |
2209 | # | |
2210 | # If specified, the `debug-line-offset-label` option is the name of a label | |
2211 | # to use for the unit header's `debug_line_offset` field value. If | |
2212 | # omitted, the unit header will not contain the `debug_line_offset` field. | |
2213 | ||
2214 | proc _macro_unit { options body } { | |
2215 | parse_options { | |
2216 | {"is-64" "false"} | |
2217 | {"debug-line-offset-label" ""} | |
2218 | } | |
2219 | ||
2220 | _op .2byte 5 "version" | |
2221 | ||
2222 | # Flags: | |
2223 | # | |
2224 | # offset_size_flag = set if is-64 is true | |
2225 | # debug_line_offset_flag = set if debug-line-offset-label is set | |
2226 | # opcode_operands_table_flag = 0 | |
2227 | set flags 0 | |
2228 | ||
2229 | if { ${is-64} } { | |
2230 | set flags [expr $flags | 0x1] | |
2231 | } | |
2232 | ||
2233 | if { ${debug-line-offset-label} != "" } { | |
2234 | set flags [expr $flags | 0x2] | |
2235 | } | |
2236 | ||
2237 | _op .byte $flags "flags" | |
2238 | ||
2239 | if { ${debug-line-offset-label} != "" } { | |
5be49e26 TV |
2240 | _op_offset [expr ${is-64} ? 8 : 4] ${debug-line-offset-label} \ |
2241 | "debug_line offset" | |
7900b17e SM |
2242 | } |
2243 | ||
2244 | with_override Dwarf::define Dwarf::_macro_unit_define { | |
2245 | with_override Dwarf::start_file Dwarf::_macro_unit_start_file { | |
2246 | with_override Dwarf::end_file Dwarf::_macro_unit_end_file { | |
2247 | uplevel $body | |
2248 | }}} | |
2249 | } | |
2250 | ||
2251 | # Emit a DW_MACRO_define entry. | |
2252 | ||
2253 | proc _macro_unit_define { lineno text } { | |
2254 | _op .byte 0x1 "DW_MACRO_define" | |
2255 | _op .uleb128 $lineno "Line number" | |
2256 | _op .asciz "\"$text\"" "Macro definition" | |
2257 | } | |
2258 | ||
2259 | # Emit a DW_MACRO_start_file entry. | |
2260 | ||
2261 | proc _macro_unit_start_file { lineno file_idx } { | |
2262 | _op .byte 0x3 "DW_MACRO_start_file" | |
2263 | _op .uleb128 $lineno | |
2264 | _op .uleb128 $file_idx | |
2265 | } | |
2266 | ||
2267 | # Emit a DW_MACRO_end_file entry. | |
2268 | ||
2269 | proc _macro_unit_end_file {} { | |
2270 | _op .byte 0x4 "DW_MACRO_end_file" | |
2271 | } | |
2272 | ||
6ef37366 PM |
2273 | # Emit a DWARF .debug_line unit. |
2274 | # OPTIONS is a list with an even number of elements containing | |
2275 | # option-name and option-value pairs. | |
2276 | # Current options are: | |
2277 | # is_64 0|1 - boolean indicating if you want to emit 64-bit DWARF | |
2278 | # default = 0 (32-bit) | |
2279 | # version n - DWARF version number to emit | |
2280 | # default = 4 | |
054a0959 | 2281 | # addr_size n - the size of addresses in bytes: 4, 8, or default |
6ef37366 | 2282 | # default = default |
44fda089 TV |
2283 | # seg_sel_size n |
2284 | # - the size of segment selector_size in bytes: | |
2285 | # default = 0 | |
6ef37366 PM |
2286 | # |
2287 | # LABEL is the label of the current unit (which is probably | |
2288 | # referenced by a DW_AT_stmt_list), or "" if there is no such | |
2289 | # label. | |
2290 | # | |
2291 | # BODY is Tcl code that emits the parts which make up the body of | |
2292 | # the line unit. It is evaluated in the caller's context. The | |
2293 | # following commands are available for the BODY section: | |
2294 | # | |
2295 | # include_dir "dirname" -- adds a new include directory | |
2296 | # | |
2297 | # file_name "file.c" idx -- adds a new file name. IDX is a | |
2298 | # 1-based index referencing an include directory or 0 for | |
2299 | # current directory. | |
2300 | ||
2301 | proc lines {options label body} { | |
2302 | variable _line_count | |
8d523785 TV |
2303 | variable _line_include_dirs |
2304 | variable _line_file_names | |
2305 | variable _line_header_finalized | |
28d2bfb9 | 2306 | variable _line_header_end_label |
44fda089 | 2307 | variable _line_unit_version |
bab31d14 TV |
2308 | variable _line_is_64 |
2309 | variable _line_string_form | |
6ef37366 PM |
2310 | |
2311 | # Establish the defaults. | |
bab31d14 | 2312 | set _line_is_64 0 |
44fda089 | 2313 | set _line_unit_version 4 |
6ef37366 | 2314 | set _unit_addr_size default |
8d523785 TV |
2315 | set _line_include_dirs {} |
2316 | set _line_file_names {} | |
2317 | set _line_header_finalized 0 | |
cecf8547 | 2318 | set _default_is_stmt 1 |
44fda089 | 2319 | set _seg_sel_size 0 |
bab31d14 TV |
2320 | #set _line_string_form string |
2321 | set _line_string_form line_strp | |
6ef37366 PM |
2322 | |
2323 | foreach { name value } $options { | |
2324 | switch -exact -- $name { | |
bab31d14 | 2325 | is_64 { set _line_is_64 $value } |
44fda089 | 2326 | version { set _line_unit_version $value } |
6ef37366 | 2327 | addr_size { set _unit_addr_size $value } |
44fda089 | 2328 | seg_sel_size { set _seg_sel_size $value } |
cecf8547 | 2329 | default_is_stmt { set _default_is_stmt $value } |
c2611492 | 2330 | string_form { set _line_string_form $value } |
6ef37366 PM |
2331 | default { error "unknown option $name" } |
2332 | } | |
2333 | } | |
2334 | if {$_unit_addr_size == "default"} { | |
2335 | if {[is_64_target]} { | |
2336 | set _unit_addr_size 8 | |
2337 | } else { | |
2338 | set _unit_addr_size 4 | |
2339 | } | |
2340 | } | |
2341 | ||
2342 | set unit_num [incr _line_count] | |
2343 | ||
2344 | set section ".debug_line" | |
2345 | _section $section | |
2346 | ||
2347 | if { "$label" != "" } { | |
2348 | # Define the user-provided label at this point. | |
2349 | $label: | |
2350 | } | |
2351 | ||
2352 | set unit_len_label [_compute_label "line${_line_count}_start"] | |
2353 | set unit_end_label [_compute_label "line${_line_count}_end"] | |
2354 | set header_len_label [_compute_label "line${_line_count}_header_start"] | |
28d2bfb9 | 2355 | set _line_header_end_label [_compute_label "line${_line_count}_header_end"] |
6ef37366 | 2356 | |
bab31d14 | 2357 | if {$_line_is_64} { |
6ef37366 PM |
2358 | _op .4byte 0xffffffff |
2359 | _op .8byte "$unit_end_label - $unit_len_label" "unit_length" | |
2360 | } else { | |
2361 | _op .4byte "$unit_end_label - $unit_len_label" "unit_length" | |
2362 | } | |
2363 | ||
2364 | define_label $unit_len_label | |
2365 | ||
44fda089 TV |
2366 | _op .2byte $_line_unit_version version |
2367 | ||
2368 | if { $_line_unit_version >= 5 } { | |
2369 | _op .byte $_unit_addr_size "address_size" | |
2370 | # Hardcode to 0 for now. | |
2371 | _op .byte $_seg_sel_size "seg_sel_size" | |
2372 | } | |
6ef37366 | 2373 | |
bab31d14 | 2374 | if {$_line_is_64} { |
28d2bfb9 | 2375 | _op .8byte "$_line_header_end_label - $header_len_label" "header_length" |
6ef37366 | 2376 | } else { |
28d2bfb9 | 2377 | _op .4byte "$_line_header_end_label - $header_len_label" "header_length" |
6ef37366 PM |
2378 | } |
2379 | ||
2380 | define_label $header_len_label | |
2381 | ||
2382 | _op .byte 1 "minimum_instruction_length" | |
44fda089 | 2383 | if { $_line_unit_version >= 4 } { |
6cb22d4a TV |
2384 | # Assume non-VLIW for now. |
2385 | _op .byte 1 "maximum_operations_per_instruction" | |
2386 | } | |
cecf8547 | 2387 | _op .byte $_default_is_stmt "default_is_stmt" |
6ef37366 PM |
2388 | _op .byte 1 "line_base" |
2389 | _op .byte 1 "line_range" | |
528b729b | 2390 | _op .byte 12 "opcode_base" |
28d2bfb9 AB |
2391 | |
2392 | # The standard_opcode_lengths table. The number of arguments | |
528b729b GL |
2393 | # for each of the standard opcodes. Generating 11 entries here |
2394 | # matches the use of 12 in the opcode_base above. These 10 | |
cc96ae7f | 2395 | # entries match the 9 standard opcodes for DWARF2 plus |
528b729b | 2396 | # DW_LNS_prologue_end and DW_LNS_epilogue_begin from DWARF3. |
28d2bfb9 AB |
2397 | _op .byte 0 "standard opcode 1" |
2398 | _op .byte 1 "standard opcode 2" | |
2399 | _op .byte 1 "standard opcode 3" | |
2400 | _op .byte 1 "standard opcode 4" | |
2401 | _op .byte 1 "standard opcode 5" | |
2402 | _op .byte 0 "standard opcode 6" | |
2403 | _op .byte 0 "standard opcode 7" | |
2404 | _op .byte 0 "standard opcode 8" | |
2405 | _op .byte 1 "standard opcode 9" | |
cc96ae7f | 2406 | _op .byte 0 "standard opcode 10" |
528b729b | 2407 | _op .byte 0 "standard opcode 11" |
6ef37366 | 2408 | |
9a0de6ab SM |
2409 | # Add a directory entry to the line table header's directory table. |
2410 | # | |
2411 | # Return the index by which this entry can be referred to. | |
6ef37366 | 2412 | proc include_dir {dirname} { |
8d523785 TV |
2413 | variable _line_include_dirs |
2414 | lappend _line_include_dirs $dirname | |
9a0de6ab SM |
2415 | |
2416 | if { $Dwarf::_line_unit_version >= 5 } { | |
2417 | return [expr [llength $_line_include_dirs] - 1] | |
2418 | } else { | |
2419 | return [llength $_line_include_dirs] | |
2420 | } | |
6ef37366 PM |
2421 | } |
2422 | ||
9a0de6ab SM |
2423 | # Add a file name entry to the line table header's file names table. |
2424 | # | |
2425 | # Return the index by which this entry can be referred to. | |
6ef37366 | 2426 | proc file_name {filename diridx} { |
8d523785 TV |
2427 | variable _line_file_names |
2428 | lappend _line_file_names $filename $diridx | |
9a0de6ab SM |
2429 | |
2430 | if { $Dwarf::_line_unit_version >= 5 } { | |
2431 | return [expr [llength $_line_file_names] - 1] | |
2432 | } else { | |
2433 | return [llength $_line_file_names] | |
2434 | } | |
8d523785 TV |
2435 | } |
2436 | ||
2437 | proc _line_finalize_header {} { | |
2438 | variable _line_header_finalized | |
2439 | if { $_line_header_finalized } { | |
2440 | return | |
6ef37366 | 2441 | } |
8d523785 TV |
2442 | set _line_header_finalized 1 |
2443 | ||
2444 | variable _line_include_dirs | |
2445 | variable _line_file_names | |
6ef37366 | 2446 | |
44fda089 | 2447 | variable _line_unit_version |
bab31d14 TV |
2448 | variable _line_is_64 |
2449 | variable _line_string_form | |
44fda089 TV |
2450 | if { $_line_unit_version >= 5 } { |
2451 | _op .byte 1 "directory_entry_format_count" | |
2452 | _op .uleb128 1 \ | |
2453 | "directory_entry_format (content type code: DW_LNCT_path)" | |
bab31d14 TV |
2454 | switch $_line_string_form { |
2455 | string { | |
2456 | _op .uleb128 0x08 \ | |
2457 | "directory_entry_format (form: DW_FORM_string)" | |
2458 | } | |
2459 | line_strp { | |
2460 | _op .uleb128 0x1f \ | |
2461 | "directory_entry_format (form: DW_FORM_line_strp)" | |
2462 | } | |
2463 | } | |
44fda089 TV |
2464 | |
2465 | set nr_dirs [llength $_line_include_dirs] | |
44fda089 TV |
2466 | _op .byte $nr_dirs "directory_count" |
2467 | ||
44fda089 | 2468 | foreach dirname $_line_include_dirs { |
bab31d14 TV |
2469 | switch $_line_string_form { |
2470 | string { | |
2471 | _op .ascii [_quote $dirname] | |
2472 | } | |
2473 | line_strp { | |
2474 | declare_labels string_ptr | |
2475 | _defer_output .debug_line_str { | |
2476 | string_ptr: | |
2477 | _op .ascii [_quote $dirname] | |
2478 | } | |
97b3f4e8 | 2479 | _op_offset [expr $_line_is_64 ? 8 : 4] $string_ptr |
bab31d14 TV |
2480 | } |
2481 | } | |
44fda089 TV |
2482 | } |
2483 | ||
2484 | _op .byte 2 "file_name_entry_format_count" | |
2485 | _op .uleb128 1 \ | |
2486 | "file_name_entry_format (content type code: DW_LNCT_path)" | |
bab31d14 TV |
2487 | switch $_line_string_form { |
2488 | string { | |
2489 | _op .uleb128 0x08 \ | |
2490 | "directory_entry_format (form: DW_FORM_string)" | |
2491 | } | |
2492 | line_strp { | |
2493 | _op .uleb128 0x1f \ | |
2494 | "directory_entry_format (form: DW_FORM_line_strp)" | |
2495 | } | |
2496 | } | |
44fda089 TV |
2497 | _op .uleb128 2 \ |
2498 | "file_name_entry_format (content type code: DW_LNCT_directory_index)" | |
2499 | _op .uleb128 0x0f \ | |
2500 | "file_name_entry_format (form: DW_FORM_udata)" | |
2501 | ||
2502 | set nr_files [expr [llength $_line_file_names] / 2] | |
44fda089 TV |
2503 | _op .byte $nr_files "file_names_count" |
2504 | ||
44fda089 | 2505 | foreach { filename diridx } $_line_file_names { |
bab31d14 TV |
2506 | switch $_line_string_form { |
2507 | string { | |
2508 | _op .ascii [_quote $filename] | |
2509 | } | |
2510 | line_strp { | |
2511 | declare_labels string_ptr | |
2512 | _defer_output .debug_line_str { | |
2513 | string_ptr: | |
2514 | _op .ascii [_quote $filename] | |
2515 | } | |
97b3f4e8 | 2516 | _op_offset [expr $_line_is_64 ? 8 : 4] $string_ptr |
bab31d14 TV |
2517 | } |
2518 | } | |
44fda089 TV |
2519 | _op .uleb128 $diridx |
2520 | } | |
2521 | } else { | |
8d523785 TV |
2522 | foreach dirname $_line_include_dirs { |
2523 | _op .ascii [_quote $dirname] | |
2524 | } | |
2525 | ||
2526 | _op .byte 0 "Terminator (include_directories)" | |
2527 | ||
2528 | foreach { filename diridx } $_line_file_names { | |
2529 | _op .ascii [_quote $filename] | |
2530 | _op .sleb128 $diridx | |
2531 | _op .sleb128 0 "mtime" | |
2532 | _op .sleb128 0 "length" | |
2533 | } | |
2534 | ||
2535 | _op .byte 0 "Terminator (file_names)" | |
2536 | } | |
2537 | ||
2538 | set _line_include_dirs {} | |
2539 | set _line_file_names {} | |
2540 | ||
2541 | variable _line_header_end_label | |
2542 | define_label $_line_header_end_label | |
6ef37366 PM |
2543 | } |
2544 | ||
d4c4a229 | 2545 | proc program { body } { |
28d2bfb9 | 2546 | variable _line_header_end_label |
853772cc TV |
2547 | variable _line |
2548 | ||
8d523785 | 2549 | |
853772cc | 2550 | set _line 1 |
28d2bfb9 | 2551 | |
8d523785 | 2552 | _line_finalize_header |
28d2bfb9 AB |
2553 | |
2554 | proc DW_LNE_set_address {addr} { | |
2555 | _op .byte 0 | |
2556 | set start [new_label "set_address_start"] | |
2557 | set end [new_label "set_address_end"] | |
2558 | _op .uleb128 "${end} - ${start}" | |
2559 | define_label ${start} | |
2560 | _op .byte 2 | |
2561 | if {[is_64_target]} { | |
2562 | _op .8byte ${addr} | |
2563 | } else { | |
2564 | _op .4byte ${addr} | |
2565 | } | |
2566 | define_label ${end} | |
2567 | } | |
2568 | ||
2569 | proc DW_LNE_end_sequence {} { | |
853772cc | 2570 | variable _line |
28d2bfb9 AB |
2571 | _op .byte 0 |
2572 | _op .uleb128 1 | |
2573 | _op .byte 1 | |
853772cc | 2574 | set _line 1 |
28d2bfb9 AB |
2575 | } |
2576 | ||
8f34b746 TV |
2577 | proc DW_LNE_user { len opcode } { |
2578 | set DW_LNE_lo_usr 0x80 | |
2579 | set DW_LNE_hi_usr 0xff | |
2580 | if { $DW_LNE_lo_usr <= $opcode | |
2581 | && $opcode <= $DW_LNE_hi_usr } { | |
2582 | _op .byte 0 | |
2583 | _op .uleb128 $len | |
2584 | _op .byte $opcode | |
2585 | for {set i 1} {$i < $len} {incr i} { | |
2586 | _op .byte 0 | |
2587 | } | |
2588 | } else { | |
2589 | error "unknown vendor specific extended opcode: $opcode" | |
2590 | } | |
2591 | } | |
2592 | ||
28d2bfb9 AB |
2593 | proc DW_LNS_copy {} { |
2594 | _op .byte 1 | |
2595 | } | |
2596 | ||
cecf8547 AB |
2597 | proc DW_LNS_negate_stmt {} { |
2598 | _op .byte 6 | |
2599 | } | |
2600 | ||
cc96ae7f LS |
2601 | proc DW_LNS_set_prologue_end {} { |
2602 | _op .byte 0x0a | |
2603 | } | |
2604 | ||
528b729b GL |
2605 | proc DW_LNS_set_epilogue_begin {} { |
2606 | _op .byte 0x0b | |
2607 | } | |
2608 | ||
28d2bfb9 AB |
2609 | proc DW_LNS_advance_pc {offset} { |
2610 | _op .byte 2 | |
2611 | _op .uleb128 ${offset} | |
2612 | } | |
2613 | ||
2614 | proc DW_LNS_advance_line {offset} { | |
853772cc | 2615 | variable _line |
28d2bfb9 AB |
2616 | _op .byte 3 |
2617 | _op .sleb128 ${offset} | |
853772cc TV |
2618 | set _line [expr $_line + $offset] |
2619 | } | |
2620 | ||
2621 | # A pseudo line number program instruction, that can be used instead | |
2622 | # of DW_LNS_advance_line. Rather than writing: | |
2623 | # {DW_LNS_advance_line [expr $line1 - 1]} | |
2624 | # {DW_LNS_advance_line [expr $line2 - $line1]} | |
2625 | # {DW_LNS_advance_line [expr $line3 - $line2]} | |
2626 | # we can just write: | |
2627 | # {line $line1} | |
2628 | # {line $line2} | |
2629 | # {line $line3} | |
2630 | proc line {line} { | |
2631 | variable _line | |
2632 | set offset [expr $line - $_line] | |
2633 | DW_LNS_advance_line $offset | |
28d2bfb9 AB |
2634 | } |
2635 | ||
34e9a9fa AB |
2636 | proc DW_LNS_set_file {num} { |
2637 | _op .byte 4 | |
2638 | _op .sleb128 ${num} | |
2639 | } | |
2640 | ||
d4c4a229 | 2641 | uplevel $body |
28d2bfb9 AB |
2642 | } |
2643 | ||
6ef37366 PM |
2644 | uplevel $body |
2645 | ||
2646 | rename include_dir "" | |
2647 | rename file_name "" | |
2648 | ||
8d523785 | 2649 | _line_finalize_header |
6ef37366 | 2650 | |
6ef37366 PM |
2651 | define_label $unit_end_label |
2652 | } | |
2653 | ||
9f637565 TV |
2654 | # Emit a DWARF .debug_aranges entry. |
2655 | ||
590d3faa TV |
2656 | proc arange { options arange_start arange_length } { |
2657 | parse_options { | |
2658 | { comment "" } | |
2659 | { seg_sel "" } | |
2660 | } | |
2661 | ||
9f637565 TV |
2662 | if { $comment != "" } { |
2663 | # Wrap | |
2664 | set comment " ($comment)" | |
2665 | } | |
2666 | ||
2667 | if { $seg_sel != "" } { | |
2668 | variable _seg_size | |
2669 | if { $_seg_size == 8 } { | |
2670 | set seg_op .8byte | |
2671 | } elseif { $_seg_size == 4 } { | |
2672 | set seg_op .4byte | |
2673 | } else { | |
2674 | error \ | |
2675 | "Don't know how to handle segment selector size $_seg_size" | |
2676 | } | |
2677 | _op $seg_op $seg_sel "Address range segment selector$comment" | |
2678 | } | |
2679 | ||
2680 | variable _addr_size | |
2681 | if { $_addr_size == 8 } { | |
2682 | set addr_op .8byte | |
2683 | } elseif { $_addr_size == 4 } { | |
2684 | set addr_op .4byte | |
2685 | } | |
2686 | ||
2687 | _op $addr_op $arange_start "Address range start$comment" | |
2688 | _op $addr_op $arange_length "Address range length$comment" | |
2689 | } | |
2690 | ||
2691 | # Emit a DWARF .debug_aranges unit. | |
2692 | # | |
2693 | # OPTIONS is a list with an even number of elements containing | |
2694 | # option-name and option-value pairs. | |
2695 | # Current options are: | |
2696 | # is_64 0|1 - boolean indicating if you want to emit 64-bit DWARF | |
2697 | # default = 0 (32-bit) | |
2698 | # cu_is_64 0|1 - boolean indicating if LABEL refers to a 64-bit DWARF CU | |
2699 | # default = 0 (32-bit) | |
2700 | # section_version n | |
2701 | # - section version number to emit | |
2702 | # default = 2 | |
2703 | # seg_size n - the size of the adress selector in bytes: 0, 4, or 8 | |
2704 | # default = 0 | |
2705 | # | |
2706 | # LABEL is the label of the corresponding CU. | |
2707 | # | |
2708 | # BODY is Tcl code that emits the parts which make up the body of | |
2709 | # the aranges unit. It is evaluated in the caller's context. The | |
2710 | # following commands are available for the BODY section: | |
2711 | # | |
2712 | # arange [-c <comment>] [<segment selector>] <start> <length> | |
2713 | # -- adds an address range. | |
2714 | ||
2715 | proc aranges { options label body } { | |
2716 | variable _addr_size | |
2717 | variable _seg_size | |
2718 | ||
9f637565 | 2719 | # Handle options. |
590d3faa TV |
2720 | parse_options { |
2721 | { is_64 0 } | |
2722 | { cu_is_64 0 } | |
2723 | { section_version 2 } | |
2724 | { seg_size 0 } | |
9f637565 | 2725 | } |
590d3faa | 2726 | set _seg_size $seg_size |
9f637565 TV |
2727 | |
2728 | if { [is_64_target] } { | |
2729 | set _addr_size 8 | |
2730 | } else { | |
2731 | set _addr_size 4 | |
2732 | } | |
2733 | ||
2734 | # Switch to .debug_aranges section. | |
2735 | _section .debug_aranges | |
2736 | ||
2737 | # Keep track of offset from start of section entry to determine | |
2738 | # padding amount. | |
2739 | set offset 0 | |
2740 | ||
2741 | # Initial length. | |
2742 | declare_labels aranges_start aranges_end | |
2743 | set length "$aranges_end - $aranges_start" | |
2744 | set comment "Length" | |
2745 | if { $is_64 } { | |
2746 | _op .4byte 0xffffffff | |
2747 | _op .8byte $length $comment | |
2748 | incr offset 12 | |
2749 | } else { | |
2750 | _op .4byte $length $comment | |
2751 | incr offset 4 | |
2752 | } | |
2753 | ||
2754 | # Start label. | |
2755 | aranges_start: | |
2756 | ||
2757 | # Section version. | |
2758 | _op .2byte $section_version "Section version" | |
2759 | incr offset 2 | |
2760 | ||
2761 | # Offset into .debug_info. | |
2762 | upvar $label my_label | |
2763 | if { $cu_is_64 } { | |
2764 | _op .8byte $my_label "Offset into .debug_info" | |
2765 | incr offset 8 | |
2766 | } else { | |
2767 | _op .4byte $my_label "Offset into .debug_info" | |
2768 | incr offset 4 | |
2769 | } | |
2770 | ||
2771 | # Address size. | |
2772 | _op .byte $_addr_size "Address size" | |
2773 | incr offset | |
2774 | ||
2775 | # Segment selector size. | |
2776 | _op .byte $_seg_size "Segment selector size" | |
2777 | incr offset | |
2778 | ||
2779 | # Padding. | |
2780 | set tuple_size [expr 2 * $_addr_size + $_seg_size] | |
2781 | while { 1 } { | |
2782 | if { [expr $offset % $tuple_size] == 0 } { | |
2783 | break | |
2784 | } | |
2785 | _op .byte 0 "Pad to $tuple_size byte boundary" | |
2786 | incr offset | |
2787 | } | |
2788 | ||
2789 | # Range tuples. | |
2790 | uplevel $body | |
2791 | ||
2792 | # Terminator tuple. | |
2793 | set comment "Terminator" | |
2794 | if { $_seg_size == 0 } { | |
590d3faa | 2795 | arange {comment $comment} 0 0 |
9f637565 | 2796 | } else { |
590d3faa | 2797 | arange {comment $comment seg_sel 0} 0 0 |
9f637565 TV |
2798 | } |
2799 | ||
2800 | # End label. | |
2801 | aranges_end: | |
2802 | } | |
2803 | ||
047ab792 TV |
2804 | # Emit a .debug_loc entry. |
2805 | ||
2806 | proc _loc_entry { start end location_description } { | |
2807 | # Determine how to emit addresses. | |
2808 | variable _addr_size | |
2809 | if { $_addr_size == 8 } { | |
2810 | set addr_op .8byte | |
2811 | } elseif { $_addr_size == 4 } { | |
2812 | set addr_op .4byte | |
2813 | } | |
2814 | ||
2815 | # Emit start and end address. | |
2816 | _op $addr_op $start "Start address" | |
2817 | _op $addr_op $end "End address" | |
2818 | ||
2819 | declare_labels location_description_start | |
2820 | declare_labels location_description_end | |
2821 | ||
2822 | # Emit length of location description. | |
2823 | set len "$location_description_end - $location_description_start" | |
2824 | _op .2byte $len "Location description length" | |
2825 | ||
2826 | # Tag start of location description. | |
2827 | define_label $location_description_start | |
2828 | ||
2829 | # Emit location description. | |
2830 | variable _cu_version | |
2831 | variable _cu_offset_size | |
2832 | _location $location_description $_cu_version $_addr_size \ | |
2833 | $_cu_offset_size | |
2834 | ||
2835 | # Tag end of location description. | |
2836 | define_label $location_description_end | |
2837 | } | |
2838 | ||
2839 | # Emit a DWARF .debug_loc contribution. | |
2840 | # | |
2841 | # OPTIONS is a list with an even number of elements containing | |
2842 | # option-name and option-value pairs. | |
2843 | # Current options are: | |
2844 | # cu_is_64 0|1 - boolean indicating if references from location | |
2845 | # descriptions refer to a 64-bit DWARF CU. | |
2846 | # default = 0 (32-bit) | |
2847 | # cu_version n - section version of DWARF CU referenced from location | |
2848 | # descriptions. | |
2849 | # default = 4 | |
2850 | # | |
2851 | # BODY is Tcl code that emits the parts which make up the body of | |
2852 | # the debug_loc contribution. It is evaluated in the caller's context. | |
2853 | # The following command is available for the BODY section: | |
2854 | # | |
2855 | # entry <start> <end> <location description> | |
2856 | # -- emit a .debug_loc entry | |
2857 | ||
2858 | proc loc { options body } { | |
2859 | # Handle options. | |
2860 | parse_options { | |
2861 | { cu_version 4 } | |
2862 | { cu_is_64 0 } | |
2863 | } | |
2864 | ||
2865 | # Export for use in BODY. | |
2866 | variable _addr_size | |
2867 | if { [is_64_target] } { | |
2868 | set _addr_size 8 | |
2869 | } else { | |
2870 | set _addr_size 4 | |
2871 | } | |
2872 | variable _cu_version | |
2873 | set _cu_version $cu_version | |
2874 | variable _cu_offset_size | |
2875 | if { $cu_is_64 == 1 } { | |
2876 | set _cu_offset_size 8 | |
2877 | } else { | |
2878 | set _cu_offset_size 4 | |
2879 | } | |
2880 | ||
2881 | # Switch to .debug_loc section. | |
2882 | _section .debug_loc | |
2883 | ||
2884 | # Introduce command 'entry'. | |
2885 | with_override Dwarf::entry Dwarf::_loc_entry { | |
2886 | # Emit entries. | |
2887 | uplevel $body | |
2888 | } | |
2889 | ||
2890 | # Determine how to emit addresses. | |
2891 | if { $_addr_size == 8 } { | |
2892 | set addr_op .8byte | |
2893 | } elseif { $_addr_size == 4 } { | |
2894 | set addr_op .4byte | |
2895 | } | |
2896 | ||
2897 | # Emit <End of list>. | |
2898 | set comment "<End of list>" | |
2899 | _op $addr_op 0 "$comment (Part 1/2)" | |
2900 | _op $addr_op 0 "$comment (Part 2/2)" | |
2901 | } | |
2902 | ||
1d24041a TT |
2903 | proc _empty_array {name} { |
2904 | upvar $name the_array | |
2905 | ||
2906 | catch {unset the_array} | |
2907 | set the_array(_) {} | |
2908 | unset the_array(_) | |
2909 | } | |
2910 | ||
dc294be5 TT |
2911 | # Emit a .gnu_debugaltlink section with the given file name and |
2912 | # build-id. The buildid should be represented as a hexadecimal | |
2913 | # string, like "ffeeddcc". | |
2914 | proc gnu_debugaltlink {filename buildid} { | |
2915 | _defer_output .gnu_debugaltlink { | |
2916 | _op .ascii [_quote $filename] | |
2917 | foreach {a b} [split $buildid {}] { | |
2918 | _op .byte 0x$a$b | |
2919 | } | |
2920 | } | |
2921 | } | |
2922 | ||
2923 | proc _note {type name hexdata} { | |
2924 | set namelen [expr [string length $name] + 1] | |
2925 | ||
2926 | # Name size. | |
2927 | _op .4byte $namelen | |
2928 | # Data size. | |
2929 | _op .4byte [expr [string length $hexdata] / 2] | |
2930 | # Type. | |
2931 | _op .4byte $type | |
2932 | # The name. | |
2933 | _op .ascii [_quote $name] | |
2934 | # Alignment. | |
2935 | set align 2 | |
340c2830 | 2936 | set total [expr {($namelen + (1 << $align) - 1) & -(1 << $align)}] |
dc294be5 TT |
2937 | for {set i $namelen} {$i < $total} {incr i} { |
2938 | _op .byte 0 | |
2939 | } | |
2940 | # The data. | |
2941 | foreach {a b} [split $hexdata {}] { | |
2942 | _op .byte 0x$a$b | |
2943 | } | |
2944 | } | |
2945 | ||
2946 | # Emit a note section holding the given build-id. | |
2947 | proc build_id {buildid} { | |
2948 | _defer_output {.note.gnu.build-id a note} { | |
2949 | # From elf/common.h. | |
2950 | set NT_GNU_BUILD_ID 3 | |
2951 | ||
2952 | _note $NT_GNU_BUILD_ID GNU $buildid | |
2953 | } | |
2954 | } | |
2955 | ||
5ef670d8 TV |
2956 | # Emit a dummy CU. |
2957 | proc dummy_cu {} { | |
2958 | # Generate a CU with default options and empty body. | |
6a6429e1 TV |
2959 | cu {label dummy_cu} { |
2960 | } | |
2961 | ||
2962 | # Generate an .debug_aranges entry for the dummy CU. | |
2963 | aranges {} dummy_cu { | |
5ef670d8 TV |
2964 | } |
2965 | } | |
2966 | ||
f4cbdf0b TV |
2967 | # Emit a DWARF .debug_names section. |
2968 | # | |
2969 | # OPTIONS is a list with an even number of elements containing | |
2970 | # option-name and option-value pairs. | |
2971 | # Current options are: | |
2972 | # is_64 0|1 - boolean indicating if the section contains 64-bit DWARF. | |
2973 | # default = 0 (32-bit) | |
2974 | # version n - section version. | |
2975 | # default = 5. | |
2976 | # | |
2977 | # BODY is Tcl code that emits the parts which make up the body of | |
2978 | # the .debug_names section. It is evaluated in the caller's context. | |
2979 | # The following commands are available for the BODY section: | |
2980 | # | |
2981 | # cu <cu-label> | |
2982 | # -- add a CU. | |
2983 | # | |
2984 | # name <name> <tag> <cu> <hash> | |
2985 | # -- add a name. | |
2986 | ||
2987 | proc debug_names { options body } { | |
a4fac33d TV |
2988 | global decimal |
2989 | ||
f4cbdf0b TV |
2990 | parse_options { |
2991 | { is_64 0 } | |
2992 | { version 5 } | |
2993 | } | |
2994 | ||
2995 | variable _debug_names_offset_size | |
2996 | if { $is_64 == 1 } { | |
2997 | set _debug_names_offset_size 8 | |
2998 | } else { | |
2999 | set _debug_names_offset_size 4 | |
3000 | } | |
3001 | ||
3002 | # Section start. | |
3003 | set section ".debug_names" | |
3004 | _section $section | |
3005 | ||
3006 | # Header - initial length. | |
3007 | declare_labels debug_names_start debug_names_end | |
3008 | set length "$debug_names_end - $debug_names_start" | |
3009 | set comment "Initial_length" | |
3010 | if { $is_64 } { | |
3011 | _op .4byte 0xffffffff | |
3012 | _op .8byte $length $comment | |
3013 | } else { | |
3014 | _op .4byte $length $comment | |
3015 | } | |
3016 | ||
3017 | # Header - start label. | |
3018 | debug_names_start: | |
3019 | ||
3020 | # Header - version + padding. | |
3021 | _op .2byte $version "Version" | |
3022 | _op .2byte 0 "Padding" | |
3023 | ||
3024 | # Parse the body. | |
3025 | variable _debug_names_cus | |
3026 | set _debug_names_cus [] | |
3027 | proc _debug_names_cu { cu } { | |
3028 | variable _debug_names_cus | |
3029 | lappend _debug_names_cus $cu | |
3030 | } | |
4c146f5d TV |
3031 | variable _debug_names_tus |
3032 | set _debug_names_tus [] | |
3033 | proc _debug_names_tu { tu } { | |
3034 | variable _debug_names_tus | |
3035 | lappend _debug_names_tus $tu | |
3036 | } | |
f4cbdf0b TV |
3037 | variable _debug_names |
3038 | set _debug_names [] | |
3039 | proc _debug_names_name { name tag cu hash } { | |
3040 | variable _debug_names | |
3041 | declare_labels entry_pool_offset | |
3042 | lappend _debug_names [list $name $tag $cu $hash $entry_pool_offset] | |
3043 | } | |
3044 | with_override Dwarf::cu Dwarf::_debug_names_cu { | |
4c146f5d | 3045 | with_override Dwarf::tu Dwarf::_debug_names_tu { |
f4cbdf0b TV |
3046 | with_override Dwarf::name Dwarf::_debug_names_name { |
3047 | uplevel $body | |
4c146f5d | 3048 | }}} |
f4cbdf0b TV |
3049 | |
3050 | # Header - CU / TU / foreign TU count. | |
3051 | _op .4byte [llength $_debug_names_cus] "Comp_unit_count" | |
4c146f5d | 3052 | _op .4byte [llength $_debug_names_tus] "Local_type_unit_count" |
f4cbdf0b TV |
3053 | _op .4byte 0 "Foreign_type_unit_count" |
3054 | ||
3055 | # Header - bucket count. | |
3056 | _op .4byte 1 "Bucket_count" | |
3057 | ||
3058 | # Header - name count. | |
3059 | _op .4byte [llength $_debug_names] "Name_count" | |
3060 | ||
3061 | # Header - abbreviation table size. | |
3062 | declare_labels debug_names_abbrev_table_start \ | |
3063 | debug_names_abbrev_table_end | |
3064 | set abbrev_table_size \ | |
3065 | "$debug_names_abbrev_table_end - $debug_names_abbrev_table_start" | |
3066 | _op .4byte $abbrev_table_size "Abbrev_table_size" | |
3067 | ||
3068 | # Header - augmentation string. | |
b371f07c TT |
3069 | _op .4byte 8 "Augmentation_string_size" |
3070 | _op .ascii [_quote GDB2] "Augmentation_string" | |
3071 | _op .byte 0 | |
3072 | _op .byte 0 | |
3073 | _op .byte 0 | |
f4cbdf0b TV |
3074 | |
3075 | # List of CUs. | |
3076 | set comment "CU offset" | |
3077 | foreach cu $_debug_names_cus { | |
3078 | upvar $cu tmp | |
3079 | if { $is_64 } { | |
3080 | _op .8byte $tmp $comment | |
3081 | } else { | |
3082 | _op .4byte $tmp $comment | |
3083 | } | |
3084 | } | |
3085 | ||
3086 | # List of Local TUs. | |
4c146f5d TV |
3087 | set comment "TU offset" |
3088 | foreach tu $_debug_names_tus { | |
3089 | upvar $tu tmp | |
3090 | if { $is_64 } { | |
3091 | _op .8byte $tmp $comment | |
3092 | } else { | |
3093 | _op .4byte $tmp $comment | |
3094 | } | |
3095 | } | |
f4cbdf0b TV |
3096 | |
3097 | # List of Foreign TUs. | |
3098 | # | |
3099 | ||
3100 | # Hash Lookup Table - array of buckets. | |
3101 | _op .4byte 1 "bucket: hash array index 1" | |
3102 | ||
3103 | # Hash Lookup Table - array of hashes. | |
3104 | foreach idx $_debug_names { | |
3105 | set name [lindex $idx 0] | |
3106 | set hash [lindex $idx 3] | |
3107 | _op .4byte $hash "hash: $name" | |
3108 | } | |
3109 | ||
3110 | # Name Table - array of string offsets. | |
3111 | foreach idx $_debug_names { | |
3112 | set name [lindex $idx 0] | |
3113 | ||
3114 | variable _strings | |
3115 | if {![info exists _strings($name)]} { | |
3116 | set _strings($name) [new_label strp] | |
3117 | _defer_output .debug_str { | |
3118 | define_label $_strings($name) | |
3119 | _op .ascii [_quote $name] | |
3120 | } | |
3121 | } | |
3122 | ||
3123 | _op_offset $_debug_names_offset_size $_strings($name) "name: $name" | |
3124 | } | |
3125 | ||
3126 | # Name Table - array of entry offsets. | |
3127 | set base_label "" | |
3128 | foreach idx $_debug_names { | |
3129 | set name [lindex $idx 0] | |
3130 | set label [lindex $idx 4] | |
3131 | if { [string equal $base_label ""]} { | |
3132 | set base_label $label | |
3133 | } | |
3134 | _op_offset $_debug_names_offset_size "$label - $base_label" \ | |
3135 | "entry pool offset: $name" | |
3136 | } | |
3137 | ||
3138 | # Abbreviations Table. | |
3139 | debug_names_abbrev_table_start: | |
3140 | set abbrev 1 | |
3141 | variable _constants | |
3142 | foreach idx $_debug_names { | |
3143 | set name [lindex $idx 0] | |
3144 | set tag [lindex $idx 1] | |
4c146f5d TV |
3145 | set cu [lindex $idx 2] |
3146 | ||
a4fac33d TV |
3147 | if { [regexp "^CU-($decimal)$" $cu dummy cu_index] } { |
3148 | set attr_name compile_unit | |
3149 | set attr_val 1 | |
3150 | } elseif { [regexp "^TU-($decimal)$" $cu dummy cu_index] } { | |
4c146f5d TV |
3151 | set attr_name type_unit |
3152 | set attr_val 2 | |
3153 | } else { | |
a4fac33d TV |
3154 | set cu_index [lsearch -exact $_debug_names_cus $cu] |
3155 | if { $cu_index == -1 } { | |
3156 | set attr_name type_unit | |
3157 | set attr_val 2 | |
3158 | } else { | |
3159 | set attr_name compile_unit | |
3160 | set attr_val 1 | |
3161 | } | |
4c146f5d TV |
3162 | } |
3163 | ||
f4cbdf0b TV |
3164 | _op .byte $abbrev "abbrev $abbrev" |
3165 | _op .uleb128 $_constants(DW_TAG_$tag) "DW_TAG_$tag" | |
4c146f5d | 3166 | _op .byte $attr_val "DW_IDX_$attr_name (attribute)" |
f4cbdf0b TV |
3167 | _op .byte 0x0f "DW_FORM_udata (form)" |
3168 | _op .byte 0 "abbrev terminator (attribute)" | |
3169 | _op .byte 0 "abbrev terminator (form)" | |
3170 | incr abbrev | |
3171 | } | |
3172 | _op .byte 0 "Abbreviations Table terminator" | |
3173 | debug_names_abbrev_table_end: | |
3174 | ||
3175 | # Entry Pool | |
3176 | set abbrev 1 | |
3177 | foreach idx $_debug_names { | |
3178 | set name [lindex $idx 0] | |
3179 | set cu [lindex $idx 2] | |
3180 | set label [lindex $idx 4] | |
3181 | ||
a4fac33d TV |
3182 | if { [regexp "^CU-($decimal)$" $cu dummy cu_index] } { |
3183 | set comment "$name: CU index" | |
3184 | } elseif { [regexp "^TU-($decimal)$" $cu dummy cu_index] } { | |
4c146f5d TV |
3185 | set comment "$name: TU index" |
3186 | } else { | |
a4fac33d TV |
3187 | set cu_index [lsearch -exact $_debug_names_cus $cu] |
3188 | if { $cu_index == -1 } { | |
3189 | set cu_index [lsearch -exact $_debug_names_tus $cu] | |
3190 | set comment "$name: TU index" | |
3191 | } else { | |
3192 | set comment "$name: CU index" | |
3193 | } | |
f4cbdf0b | 3194 | } |
f4cbdf0b TV |
3195 | define_label $label |
3196 | _op .byte $abbrev "$name: abbrev" | |
4c146f5d | 3197 | _op .uleb128 $cu_index $comment |
f4cbdf0b TV |
3198 | _op .byte 0 "$name: terminator" |
3199 | incr abbrev | |
3200 | } | |
3201 | ||
3202 | # Section end. | |
3203 | debug_names_end: | |
3204 | } | |
3205 | ||
1d24041a | 3206 | # The top-level interface to the DWARF assembler. |
f4cbdf0b TV |
3207 | # OPTIONS is a list with an even number of elements containing |
3208 | # option-name and option-value pairs. | |
3209 | # Current options are: | |
3210 | # filename <string> | |
3211 | # - the name of the file where the generated assembly | |
3212 | # code is written. | |
3213 | # default = "". | |
511f4ff4 TV |
3214 | # file_id <tcl channel identifier> |
3215 | # - open file where the generated assemble core is written. | |
3216 | # default = "". | |
f4cbdf0b TV |
3217 | # add_dummy_cus <0|1> |
3218 | # - Whether to add dummy CUs before and after the CUs | |
3219 | # added in the BODY. | |
3220 | # default = 1. | |
3221 | # As a special case, if OPTIONS is a list of length 1, it's | |
3222 | # interpreted as specifing the filename. | |
1d24041a TT |
3223 | # BODY is Tcl code to emit the assembly. It is evaluated via |
3224 | # "eval" -- not uplevel as you might expect, because it is | |
3225 | # important to run the body in the Dwarf namespace. | |
3226 | # | |
3227 | # A typical invocation is something like: | |
3228 | # Dwarf::assemble $file { | |
3229 | # cu 0 2 8 { | |
3230 | # compile_unit { | |
3231 | # ... | |
3232 | # } | |
3233 | # } | |
3234 | # cu 0 2 8 { | |
3235 | # ... | |
3236 | # } | |
3237 | # } | |
f4cbdf0b | 3238 | proc assemble {options body} { |
1d24041a TT |
3239 | variable _initialized |
3240 | variable _output_file | |
3241 | variable _deferred_output | |
3242 | variable _defer | |
3243 | variable _label_num | |
3244 | variable _strings | |
d65f0a9c | 3245 | variable _cu_count |
6ef37366 | 3246 | variable _line_count |
28d2bfb9 AB |
3247 | variable _line_header_end_label |
3248 | variable _debug_ranges_64_bit | |
61dee722 | 3249 | variable _debug_addr_index |
1d24041a | 3250 | |
f4cbdf0b TV |
3251 | if { [llength $options] == 1 } { |
3252 | set options [list filename [lindex $options 0]] | |
3253 | } | |
3254 | ||
3255 | parse_options { | |
3256 | { filename "" } | |
511f4ff4 | 3257 | { file_id "" } |
f4cbdf0b TV |
3258 | { add_dummy_cus 1 } |
3259 | } | |
3260 | ||
1d24041a TT |
3261 | if {!$_initialized} { |
3262 | _read_constants | |
3263 | set _initialized 1 | |
3264 | } | |
3265 | ||
511f4ff4 TV |
3266 | if { $file_id != "" } { |
3267 | set _output_file $file_id | |
3268 | } else { | |
3269 | set _output_file [open $filename w] | |
3270 | } | |
3271 | ||
5ef670d8 | 3272 | set _cu_count -1 |
1d24041a TT |
3273 | _empty_array _deferred_output |
3274 | set _defer "" | |
3275 | set _label_num 0 | |
3276 | _empty_array _strings | |
3277 | ||
6ef37366 | 3278 | set _line_count 0 |
28d2bfb9 | 3279 | set _debug_ranges_64_bit [is_64_target] |
6ef37366 | 3280 | |
61dee722 AB |
3281 | set _debug_addr_index 0 |
3282 | ||
5ef670d8 TV |
3283 | # Dummy CU at the start to ensure that the first CU in $body is not |
3284 | # the first in .debug_info. | |
f4cbdf0b TV |
3285 | if { $add_dummy_cus } { |
3286 | dummy_cu | |
3287 | } | |
5ef670d8 | 3288 | |
fc6a9385 TV |
3289 | with_shared_gdb { |
3290 | # Not "uplevel" here, because we want to evaluate in this | |
3291 | # namespace. This is somewhat bad because it means we can't | |
3292 | # readily refer to outer variables. | |
3293 | eval $body | |
3294 | } | |
1d24041a | 3295 | |
5ef670d8 TV |
3296 | # Dummy CU at the end to ensure that the last CU in $body is not |
3297 | # the last in .debug_info. | |
f4cbdf0b TV |
3298 | if { $add_dummy_cus } { |
3299 | dummy_cu | |
3300 | } | |
5ef670d8 | 3301 | |
1d24041a TT |
3302 | _write_deferred_output |
3303 | ||
0f2cd53c TV |
3304 | _section .note.GNU-stack "" progbits |
3305 | ||
511f4ff4 TV |
3306 | if { $file_id == "" } { |
3307 | catch {close $_output_file} | |
3308 | } | |
1d24041a TT |
3309 | set _output_file {} |
3310 | } | |
3311 | } |