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