# Copyright 2010-2013 Free Software Foundation, Inc.

# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.

# Return true if the target supports DWARF-2 and uses gas.
# For now pick a sampling of likely targets.
proc dwarf2_support {} {
    if {[istarget *-*-linux*]
	|| [istarget *-*-gnu*]
	|| [istarget *-*-elf*]
	|| [istarget *-*-openbsd*]
	|| [istarget arm*-*-eabi*]
	|| [istarget arm*-*-symbianelf*]
	|| [istarget powerpc-*-eabi*]} {
	return 1
    }

    return 0
}

# A DWARF assembler.
#
# All the variables in this namespace are private to the
# implementation.  Also, any procedure whose name starts with "_" is
# private as well.  Do not use these.
#
# Exported functions are documented at their definition.
#
# In addition to the hand-written functions documented below, this
# module automatically generates a function for each DWARF tag.  For
# most tags, two forms are made: a full name, and one with the
# "DW_TAG_" prefix stripped.  For example, you can use either
# 'DW_TAG_compile_unit' or 'compile_unit' interchangeably.
#
# There are two exceptions to this rule: DW_TAG_variable and
# DW_TAG_namespace.  For these, the full name must always be used,
# as the short name conflicts with Tcl builtins.  (Should future
# versions of Tcl or DWARF add more conflicts, this list will grow.
# If you want to be safe you should always use the full names.)
#
# Each tag procedure is defined like:
#
# proc DW_TAG_mumble {{attrs {}} {children {}}} { ... }
#
# ATTRS is an optional list of attributes.
# It is run through 'subst' in the caller's context before processing.
#
# Each attribute in the list has one of two forms:
#   1. { NAME VALUE }
#   2. { NAME VALUE FORM }
#
# In each case, NAME is the attribute's name.
# This can either be the full name, like 'DW_AT_name', or a shortened
# name, like 'name'.  These are fully equivalent.
#
# If FORM is given, it should name a DW_FORM_ constant.
# This can either be the short form, like 'DW_FORM_addr', or a
# shortened version, like 'addr'.  If the form is given, VALUE
# is its value; see below.  In some cases, additional processing
# is done; for example, DW_FORM_strp manages the .debug_str
# section automatically.
#
# If FORM is 'SPECIAL_expr', then VALUE is treated as a location
# expression.  The effective form is then DW_FORM_block, and VALUE
# is passed to the (internal) '_location' proc to be translated.
# This proc implements a miniature DW_OP_ assembler.
#
# If FORM is not given, it is guessed:
# * If VALUE starts with the "@" character, the rest of VALUE is
#   looked up as a DWARF constant, and DW_FORM_sdata is used.  For
#   example, '@DW_LANG_c89' could be used.
# * If VALUE starts with the ":" character, then it is a label
#   reference.  The rest of VALUE is taken to be the name of a label,
#   and DW_FORM_ref4 is used.  See 'new_label' and 'define_label'.
# * Otherwise, VALUE is taken to be a string and DW_FORM_string is
#   used.
# More form-guessing functionality may be added.
#
# CHILDREN is just Tcl code that can be used to define child DIEs.  It
# is evaluated in the caller's context.
#
# Currently this code is missing nice support for CFA handling, and
# probably other things as well.

namespace eval Dwarf {
    # True if the module has been initialized.
    variable _initialized 0

    # Constants from dwarf2.h.
    variable _constants
    # DW_AT short names.
    variable _AT
    # DW_FORM short names.
    variable _FORM
    # DW_OP short names.
    variable _OP

    # The current output file.
    variable _output_file

    # Current CU count.
    variable _cu_count

    # The current CU's base label.
    variable _cu_label

    # The current CU's version.
    variable _cu_version

    # The current CU's address size.
    variable _cu_addr_size
    # The current CU's offset size.
    variable _cu_offset_size

    # Label generation number.
    variable _label_num

    # The deferred output array.  The index is the section name; the
    # contents hold the data for that section.
    variable _deferred_output

    # If empty, we should write directly to the output file.
    # Otherwise, this is the name of a section to write to.
    variable _defer

    # The next available abbrev number in the current CU's abbrev
    # table.
    variable _abbrev_num

    # The string table for this assembly.  The key is the string; the
    # value is the label for that string.
    variable _strings

    proc _process_one_constant {name value} {
	variable _constants
	variable _AT
	variable _FORM
	variable _OP

	set _constants($name) $value

	if {![regexp "^DW_(\[A-Z\]+)_(\[A-Za-z0-9_\]+)$" $name \
		  ignore prefix name2]} {
	    error "non-matching name: $name"
	}

	if {$name2 == "lo_user" || $name2 == "hi_user"} {
	    return
	}

	# We only try to shorten some very common things.
	# FIXME: CFA?
	switch -exact -- $prefix {
	    TAG {
		# Create two procedures for the tag.  These call
		# _handle_DW_TAG with the full tag name baked in; this
		# does all the actual work.
		proc $name {{attrs {}} {children {}}} \
		    "_handle_DW_TAG $name \$attrs \$children"

		# Filter out ones that are known to clash.
		if {$name2 == "variable" || $name2 == "namespace"} {
		    set name2 "tag_$name2"
		}

		if {[info commands $name2] != {}} {
		    error "duplicate proc name: from $name"
		}

		proc $name2 {{attrs {}} {children {}}} \
		    "_handle_DW_TAG $name \$attrs \$children"
	    }

	    AT {
		set _AT($name2) $name
	    }

	    FORM {
		set _FORM($name2) $name
	    }

	    OP {
		set _OP($name2) $name
	    }

	    default {
		return
	    }
	}
    }

    proc _read_constants {} {
	global srcdir hex decimal
	variable _constants

	# DWARF name-matching regexp.
	set dwrx "DW_\[a-zA-Z0-9_\]+"
	# Whitespace regexp.
	set ws "\[ \t\]+"

	set fd [open [file join $srcdir .. .. include dwarf2.h]]
	while {![eof $fd]} {
	    set line [gets $fd]
	    if {[regexp -- "^${ws}($dwrx)${ws}=${ws}($hex|$decimal),?$" \
		     $line ignore name value ignore2]} {
		_process_one_constant $name $value
	    }
	}
	close $fd

	set fd [open [file join $srcdir .. .. include dwarf2.def]]
	while {![eof $fd]} {
	    set line [gets $fd]
	    if {[regexp -- \
		     "^DW_\[A-Z_\]+${ws}\\(($dwrx),${ws}($hex|$decimal)\\)$" \
		     $line ignore name value ignore2]} {
		_process_one_constant $name $value
	    }
	}
	close $fd

	set _constants(SPECIAL_expr) $_constants(DW_FORM_block)
    }

    proc _quote {string} {
	# FIXME
	return "\"${string}\\0\""
    }

    proc _handle_DW_FORM {form value} {
	switch -exact -- $form {
	    DW_FORM_string  {
		_op .ascii [_quote $value]
	    }

	    DW_FORM_flag_present {
		# We don't need to emit anything.
	    }

	    DW_FORM_data4 -
	    DW_FORM_ref4 {
		_op .4byte $value
	    }

	    DW_FORM_ref_addr {
		variable _cu_offset_size
		variable _cu_version
		variable _cu_addr_size

		if {$_cu_version == 2} {
		    set size $_cu_addr_size
		} else {
		    set size $_cu_offset_size
		}

		_op .${size}byte $value
	    }

	    DW_FORM_ref1 -
	    DW_FORM_flag -
	    DW_FORM_data1 {
		_op .byte $value
	    }

	    DW_FORM_sdata {
		_op .sleb128 $value
	    }

	    DW_FORM_ref_udata -
	    DW_FORM_udata {
		_op .uleb128 $value
	    }

	    DW_FORM_addr {
		variable _cu_addr_size

		_op .${_cu_addr_size}byte $value
	    }

	    DW_FORM_data2 -
	    DW_FORM_ref2 {
		_op .2byte $value
	    }

	    DW_FORM_data8 -
	    DW_FORM_ref8 -
	    DW_FORM_ref_sig8 {
		_op .8byte $value
	    }

	    DW_FORM_strp {
		variable _strings
		variable _cu_offset_size

		if {![info exists _strings($value)]} {
		    set _strings($value) [new_label strp]
		    _defer_output .debug_string {
			define_label $_strings($value)
			_op .ascii [_quote $value]
		    }
		}

		_op .${_cu_offset_size}byte $_strings($value) "strp: $value"
	    }

	    SPECIAL_expr {
		set l1 [new_label "expr_start"]
		set l2 [new_label "expr_end"]
		_op .uleb128 "$l2 - $l1" "expression"
		define_label $l1
		_location $value
		define_label $l2
	    }

	    DW_FORM_block2 -
	    DW_FORM_block4 -

	    DW_FORM_block -
	    DW_FORM_block1 -

	    DW_FORM_ref2 -
	    DW_FORM_indirect -
	    DW_FORM_sec_offset -
	    DW_FORM_exprloc -

	    DW_FORM_GNU_addr_index -
	    DW_FORM_GNU_str_index -
	    DW_FORM_GNU_ref_alt -
	    DW_FORM_GNU_strp_alt -

	    default {
		error "unhandled form $form"
	    }
	}
    }

    proc _guess_form {value varname} {
	upvar $varname new_value

	switch -exact -- [string range $value 0 0] {
	    @ {
		# Constant reference.
		variable _constants

		set new_value $_constants([string range $value 1 end])
		# Just the simplest.
		return DW_FORM_sdata
	    }

	    : {
		# Label reference.
		variable _cu_label

		set new_value "[string range $value 1 end] - $_cu_label"

		return DW_FORM_ref4
	    }

	    default {
		return DW_FORM_string
	    }
	}
    }

    # Map NAME to its canonical form.
    proc _map_name {name ary} {
	variable $ary

	if {[info exists ${ary}($name)]} {
	    set name [set ${ary}($name)]
	}

	return $name
    }

    proc _handle_DW_TAG {tag_name {attrs {}} {children {}}} {
	variable _abbrev_num
	variable _constants

	set has_children [expr {[string length $children] > 0}]
	set my_abbrev [incr _abbrev_num]

	# We somewhat wastefully emit a new abbrev entry for each tag.
	# There's no reason for this other than laziness.
	_defer_output .debug_abbrev {
	    _op .uleb128 $my_abbrev "Abbrev start"
	    _op .uleb128 $_constants($tag_name) $tag_name
	    _op .byte $has_children "has_children"
	}

	_op .uleb128 $my_abbrev "Abbrev ($tag_name)"

	foreach attr $attrs {
	    set attr_name [_map_name [lindex $attr 0] _AT]
	    set attr_value [uplevel 2 [list subst [lindex $attr 1]]]
	    if {[llength $attr] > 2} {
		set attr_form [lindex $attr 2]
	    } else {
		set attr_form [_guess_form $attr_value attr_value]
	    }
	    set attr_form [_map_name $attr_form _FORM]

	    _handle_DW_FORM $attr_form $attr_value

	    _defer_output .debug_abbrev {
		_op .uleb128 $_constants($attr_name) $attr_name
		_op .uleb128 $_constants($attr_form) $attr_form
	    }
	}

	_defer_output .debug_abbrev {
	    # Terminator.
	    _op .byte 0x0 Terminator
	    _op .byte 0x0 Terminator
	}

	if {$has_children} {
	    uplevel 2 $children

	    # Terminate children.
	    _op .byte 0x0 "Terminate children"
	}
    }

    proc _emit {string} {
	variable _output_file
	variable _defer
	variable _deferred_output

	if {$_defer == ""} {
	    puts $_output_file $string
	} else {
	    append _deferred_output($_defer) ${string}\n
	}
    }

    proc _section {name} {
	_emit "        .section $name"
    }

    proc _defer_output {section body} {
	variable _defer
	variable _deferred_output

	set old_defer $_defer
	set _defer $section

	if {![info exists _deferred_output($_defer)]} {
	    set _deferred_output($_defer) ""
	    _section $section
	}

	uplevel $body

	set _defer $old_defer
    }

    proc _defer_to_string {body} {
	variable _defer
	variable _deferred_output

	set old_defer $_defer
	set _defer temp

	set _deferred_output($_defer) ""

	uplevel $body

	set result $_deferred_output($_defer)
	unset _deferred_output($_defer)

	set _defer $old_defer
	return $result
    }

    proc _write_deferred_output {} {
	variable _output_file
	variable _deferred_output

	foreach section [array names _deferred_output] {
	    # The data already has a newline.
	    puts -nonewline $_output_file $_deferred_output($section)
	}

	# Save some memory.
	unset _deferred_output
    }

    proc _op {name value {comment ""}} {
	set text "        ${name}        ${value}"
	if {$comment != ""} {
	    # Try to make stuff line up nicely.
	    while {[string length $text] < 40} {
		append text " "
	    }
	    append text "/* ${comment} */"
	}
	_emit $text
    }

    proc _compute_label {name} {
	return ".L${name}"
    }

    # Return a name suitable for use as a label.  If BASE_NAME is
    # specified, it is incorporated into the label name; this is to
    # make debugging the generated assembler easier.  If BASE_NAME is
    # not specified a generic default is used.  This proc does not
    # define the label; see 'define_label'.  'new_label' attempts to
    # ensure that label names are unique.
    proc new_label {{base_name label}} {
	variable _label_num

	return [_compute_label ${base_name}[incr _label_num]]
    }

    # Define a label named NAME.  Ordinarily, NAME comes from a call
    # to 'new_label', but this is not required.
    proc define_label {name} {
	_emit "${name}:"
    }

    # Declare a global label.  This is typically used to refer to
    # labels defined in other files, for example a function defined in
    # a .c file.
    proc extern {args} {
	foreach name $args {
	    _op .global $name
	}
    }

    # A higher-level interface to label handling.
    #
    # ARGS is a list of label descriptors.  Each one is either a
    # single element, or a list of two elements -- a name and some
    # text.  For each descriptor, 'new_label' is invoked.  If the list
    # form is used, the second element in the list is passed as an
    # argument.  The label name is used to define a variable in the
    # enclosing scope; this can be used to refer to the label later.
    # The label name is also used to define a new proc whose name is
    # the label name plus a trailing ":".  This proc takes a body as
    # an argument and can be used to define the label at that point;
    # then the body, if any, is evaluated in the caller's context.
    #
    # For example:
    #
    # declare_labels int_label
    # something { ... $int_label }   ;# refer to the label
    # int_label: constant { ... }    ;# define the label
    proc declare_labels {args} {
	foreach arg $args {
	    set name [lindex $arg 0]
	    set text [lindex $arg 1]

	    upvar $name label_var
	    if {$text == ""} {
		set label_var [new_label]
	    } else {
		set label_var [new_label $text]
	    }

	    proc ${name}: {args} [format {
		define_label %s
		uplevel $args
	    } $label_var]
	}
    }

    # This is a miniature assembler for location expressions.  It is
    # suitable for use in the attributes to a DIE.  Its output is
    # prefixed with "=" to make it automatically use DW_FORM_block.
    # BODY is split by lines, and each line is taken to be a list.
    # (FIXME should use 'info complete' here.)
    # Each list's first element is the opcode, either short or long
    # forms are accepted.
    # FIXME argument handling
    # FIXME move docs
    proc _location {body} {
	variable _constants

	foreach line [split $body \n] {
	    if {[lindex $line 0] == ""} {
		continue
	    }
	    set opcode [_map_name [lindex $line 0] _OP]
	    _op .byte $_constants($opcode) $opcode

	    switch -exact -- $opcode {
		DW_OP_addr {
		    variable _cu_addr_size

		    _op .${_cu_addr_size}byte [lindex $line 1]
		}

		DW_OP_const1u -
		DW_OP_const1s {
		    _op .byte [lindex $line 1]
		}

		DW_OP_const2u -
		DW_OP_const2s {
		    _op .2byte [lindex $line 1]
		}

		DW_OP_const4u -
		DW_OP_const4s {
		    _op .4byte [lindex $line 1]
		}

		DW_OP_const8u -
		DW_OP_const8s {
		    _op .8byte [lindex $line 1]
		}

		DW_OP_constu {
		    _op .uleb128 [lindex $line 1]
		}
		DW_OP_consts {
		    _op .sleb128 [lindex $line 1]
		}

		default {
		    if {[llength $line] > 1} {
			error "Unimplemented: operands in location for $opcode"
		    }
		}
	    }
	}
    }

    # Emit a DWARF CU.
    # IS_64 is a boolean which is true if you want to emit 64-bit
    # DWARF, and false for 32-bit DWARF.
    # VERSION is the DWARF version number to emit.
    # ADDR_SIZE is the size of addresses in bytes.
    # BODY is Tcl code that emits the DIEs which make up the body of
    # the CU.  It is evaluated in the caller's context.
    proc cu {is_64 version addr_size body} {
	variable _cu_count
	variable _abbrev_num
	variable _cu_label
	variable _cu_version
	variable _cu_addr_size
	variable _cu_offset_size

	set _cu_version $version
	if {$is_64} {
	    set _cu_offset_size 8
	} else {
	    set _cu_offset_size 4
	}
	set _cu_addr_size $addr_size

	_section .debug_info

	set cu_num [incr _cu_count]
	set my_abbrevs [_compute_label "abbrev${cu_num}_begin"]
	set _abbrev_num 1

	set _cu_label [_compute_label "cu${cu_num}_begin"]
	set start_label [_compute_label "cu${cu_num}_start"]
	set end_label [_compute_label "cu${cu_num}_end"]
	
	define_label $_cu_label
	if {$is_64} {
	    _op .4byte 0xffffffff
	    _op .8byte "$end_label - $start_label"
	} else {
	    _op .4byte "$end_label - $start_label"
	}
	define_label $start_label
	_op .2byte $version Version
	_op .4byte $my_abbrevs Abbrevs
	_op .byte $addr_size "Pointer size"

	_defer_output .debug_abbrev {
	    define_label $my_abbrevs
	}

	uplevel $body

	_defer_output .debug_abbrev {
	    # Emit the terminator.
	    _op .byte 0x0 Terminator
	    _op .byte 0x0 Terminator
	}

	define_label $end_label
    }

    proc _empty_array {name} {
	upvar $name the_array

	catch {unset the_array}
	set the_array(_) {}
	unset the_array(_)
    }

    # The top-level interface to the DWARF assembler.
    # FILENAME is the name of the file where the generated assembly
    # code is written.
    # BODY is Tcl code to emit the assembly.  It is evaluated via
    # "eval" -- not uplevel as you might expect, because it is
    # important to run the body in the Dwarf namespace.
    #
    # A typical invocation is something like:
    #    Dwarf::assemble $file {
    #        cu 0 2 8 {
    #            compile_unit {
    #            ...
    #            }
    #        }
    #        cu 0 2 8 {
    #        ...
    #        }
    #    }
    proc assemble {filename body} {
	variable _initialized
	variable _output_file
	variable _deferred_output
	variable _defer
	variable _label_num
	variable _strings
	variable _cu_count

	if {!$_initialized} {
	    _read_constants
	    set _initialized 1
	}

	set _output_file [open $filename w]
	set _cu_count 0
	_empty_array _deferred_output
	set _defer ""
	set _label_num 0
	_empty_array _strings

	# Not "uplevel" here, because we want to evaluate in this
	# namespace.  This is somewhat bad because it means we can't
	# readily refer to outer variables.
	eval $body

	_write_deferred_output

	catch {close $_output_file}
	set _output_file {}
    }
}