gdb.tcl

rtai-3.1-test3的源代码(Real-Time Application Interface )

	    # automatically disable faulty watchpoint and resume
	} {
	    break
	}
    }
}

proc gdb:getctl {context {focuscmd {}} {fnum {}}} {

    global gdb:signaled gdb:stream

    if {${gdb:signaled} == "true"} {
	# A signaled process is always considered to be
	# in a controlled -and uncontinuable- state.
	if {$focuscmd != {}} {
	    set hotspot [gdb:switchin $context $focuscmd $fnum]
	    return $hotspot
	} {
	    return true
	}
    }

    # Wait for the debuggee to hit a breakpoint; true is returned
    # if all is ok, false if the dispatcher returned due to a
    # simulation kill.
    gdb:dispatch $context false

    if {[catch { fconfigure ${gdb:stream} -eofchar } v] == 0} {
	if {$focuscmd != {}} {
	    # when a focus is requested, return the reached code
	    # location to the caller.
	    set hotspot [gdb:switchin $context $focuscmd $fnum]
	    return $hotspot
	}
	return true
    }
    return false
}

proc gdb:relctl {context focuscmd} {

    global gdb:signaled

    if {$focuscmd != {}} {
	# Exit from bump handler first
	gdb:switchout $context
    }
    if {${gdb:signaled} == "false"} {
	gdb:send cont
    }
}

proc gdb:release {context} {

    global gdb:btcache gdb:signaled gdb:stream

    if {${gdb:signaled} == "true"} {
	# A signaled process is always considered to be
	# in an uncontinuable state.
	return
    }

    set gdb:btcache {}

    # dispatch GDB output until the debuggee stops then
    # process the next breakpoint notification...
    gdb:dispatch $context

    if {[catch { fconfigure ${gdb:stream} -eofchar } v] == 0 &&
	${gdb:signaled} == "false"} {
	# Assume that all operations needing a "hard" break
	# state are now over; give control back to the embedded
	# monitor which still remains in a stopped state. This
	# way, monitor commands can be issued and answered back
	# immediately.
	# Pretend that any signal/fault stopping the child leads
	# to an unrecoverable error state, preventing the debuggee
	# to continue.
	gdb:send cont
    }
}

proc gdb:run {context args} {

    set s run
    # This silly code assumes args are passed as a
    # list of vector args; the outer loop expands
    # the list, the second the vector.
    foreach l $args {
	foreach w $l {
	    append s " "
	    append s $w
	}
    }

    gdb:send $s
}

proc gdb:preamble {context location} {

    # Fetch the addresses of the simulation control registers. Setting
    # a register's value using its memory address is faster than
    # refering to its symbolic name, especially if the debuggee's
    # namelist is huge.

    for {set n 0} {$n < 4} {incr n} {
	global gdb:mvmcr${n}
	set rl [gdb:command "print /x &mvmcr${n}" l]
	set gdb:mvmcr${n} [lindex [lindex [lindex $rl 2] 0] 2]
    }

    # Fetch the address of our internal exception handler.
    global gdb:mvmeh
    set rl [gdb:command "print /x &mvm_eh" l]
    set gdb:mvmeh [lindex [lindex [lindex $rl 2] 0] 2]

    # Further breakpoints should be directly notified to the ISE
    global gdb:bhook
    set gdb:bhook Debugger:notifyBreak
    # Notify the ISE
    Debugger:notifyPreamble $context
    # Resume the simulation
    gdb:send cont
    gdb:dispatch $context
}

proc gdb:stop {context} {

    gdb:close $context
}

# A hard breakpoint is a native GDB breakpoint. When reached, the
# simulator is not fully in control. For instance, change of focus by
# the operator will have the undesirable side-effect of restarting the
# simulation. It is used in combination with an internal control
# command to obtain a soft breakpoint.

proc gdb:sethardbp {where} {

    set rl [gdb:command "break $where" l {"^Breakpoint [0-9]+.*"}]
    set nre [lindex $rl 0]
    set matched [lindex [lindex $rl 2] 0]

    if {$nre == 0} {
	regexp "^Breakpoint (\[0-9\]+)" $matched mvar bpnum
    } {
	global gdb:lasterror
	set gdb:lasterror $matched
	set bpnum {}
    }

    return $bpnum
}

# A soft breakpoint tells GDB to execute a debug control operation
# when the breakpoint location is hit; this operation will plan for
# the internal breakpoint to be hit as soon as the scope condition is
# met (if any) and the simulator enters a safe place to stop
# at. Because the "silent" option is passed, no code location will be
# output by GDB when this breakpoint is hit thus this interface will
# just not know about the hard breakpoint.

proc gdb:setsoftbp {context focuscmd file lineno} {

    global gdb:mvmcr0 gdb:mvmcr1

    set where [join [list [file tail $file] : $lineno] ""]
    set bpnum [gdb:sethardbp $where]

    if {$bpnum == {}} {
	return {}
    }

    gdb:send "commands"
    gdb:send "silent"
    set scope [lindex $focuscmd 0]
    set flag [TkRequest $context GetCtlCode DEBUGTRAP_BREAK $scope]
    set id [lindex $focuscmd 1]

    gdb:send "set *((int *)${gdb:mvmcr0}) |= $flag"
    gdb:send "set *((int *)${gdb:mvmcr1}) = $id"
    gdb:send "continue"
    gdb:send "end"

    gdb:waitprompt

    return $bpnum
}

proc gdb:setbpcondition {bpnum cond} {

    global gdb:lastexpr
    set gdb:lastexpr $cond
    set rl [gdb:command "condition $bpnum $cond" l]
    set emsg [lindex [lindex $rl 2] 0]
    if {$emsg != {} && $cond != {}} {
	# ignore GDB ack on condition removal, otherwise GDB
	# should remain silent after trying to set a condition
	global gdb:lasterror
	set gdb:lasterror $emsg
	set bpnum {}
    }
    return $bpnum
}

proc gdb:removebp {bpnum} {
    gdb:command "delete $bpnum"
}

proc gdb:disablebp {bpnum} {
    gdb:command "disable $bpnum"
    return true
}

proc gdb:enablebp {bpnum} {
    gdb:command "enable $bpnum"
}

# Query breakpoint location given its internal id.
# number.

proc gdb:getbpinfo {bpnum} {

    set rl [gdb:command "info breakpoints $bpnum" l \
		{ "^\[0-9\]+.*0x\[0-9a-fA-F\]+ in \[^ \]+(\\(.*\\))? at \[^ \]+$" \
		"^\[0-9\]+.*0x\[0-9a-fA-F\]+ +<.*>$" } ]
    set nre [lindex $rl 0]
    set matched [lindex $rl 1]
    set location [list 0 0x0]

    # find out breakpoint information. (note: we could have used gdb's
    # "list *<expr>" syntax to get to the same result).

    switch -- $nre {
	0 {
	    # (symbolic information available)
	    # the way we retrieve the source file name is a bit tricky, but
	    # let GDB resolve the source directory bummer for us. The steps
	    # are as follows:
	    # 1st- retrieve the file position expr returned by the last
	    # breakpoint information query. This information is given
	    # in the form <file>:<lineno>.
	    # 2nd- ask GDB to consider this file as the current source;
	    # "list $filepos,$filepos" makes GDB do the switch and
	    # list a single -unused- line from this file.
	    # 3rd- query information about the current source (i.e.
	    # the file where the breakpoint has been set). A line of the
	    # output log starting with "Located in" gives the actual full
	    # pathname of the current file.

	    if {[regexp "^\[0-9\]+.*(0x\[0-9a-fA-F\]+) in (\[^ (\]+)(\\(.*\\))? at (\[^ \]+)$" \
		     $matched mvar addr function cplusplus filepos] == 1} {
		gdb:command "list $filepos,$filepos"
		set rl [gdb:command "info source" l]
		set log [lindex $rl 2]
 		set fileloc [lindex $log [lsearch -regexp $log "^Located in.*"]]
		regexp "^Located in (\[^ \]+)$" $fileloc mvar file
		regexp ".*:(\[0-9\]+)$" $filepos mvar lineno
		set location [list $addr $function $file $lineno]
	    }
	}

	1 {
	    # (no symbolic information available)
	    if {[regexp "^\[0-9\]+.*(0x\[0-9a-fA-F\]+) +<(\[^ (]+)(\\(.*\\))?(\\+.*)>$" \
		     $matched mvar addr function cplusplus offset] == 1} {
		set location [list $addr $function]
	    }
	}
    }

    return $location
}

proc gdb:setwatchpoint {context cond} {

    global gdb:wpsupport gdb:mvmcr0
    global gdb:lastexpr

    if {${gdb:wpsupport} == "unknown"} {
	set rl [gdb:command "awatch *((int *)${gdb:mvmcr0})" l \
	{ "Target does not have this type of hardware watchpoint support." \
	  ".* watchpoint \[0-9\]+.*:"}]
	set nre [lindex $rl 0]
	if {$nre == 0} {
	    set gdb:wpsupport no
	} {
	    if {$nre == 1} {
		set matched [lindex $rl 1]
		regexp ".* watchpoint (\[0-9\]+):" $matched mvar wpnum
		gdb:command "delete $wpnum"
		set gdb:wpsupport yes
	    }
	}
    }

    if {${gdb:wpsupport} != "yes"} {
	if {[tk_messageBox \
		 -message "GDB: there is no hardware support for watchpoints\
on this platform. Using them will dramatically slow the simulation \
(and the ISE) down. Are you sure you still want to do that?" \
		 -type yesno -icon warning -title Warning] == "no"} {
	    global gdb:lasterror
	    set gdb:lasterror "No hardware support for watchpoints."
	    return {}
	}
    set gdb:wpsupport yes
    }

    set gdb:lastexpr $cond
    set rl [gdb:command "watch $cond" l \
		{ "^\[A-Za-z \]*\[Ww\]atchpoint \[0-9\]+.*:" \
		      "^No symbol table.*" \
		      "^No symbol .*" }]
    set nre [lindex $rl 0]
    set matched [lindex $rl 1]

    if {$nre == 0} {
	regexp "^\[A-Za-z \]*\[Ww\]atchpoint (\[0-9\]+):" $matched mvar wpnum
    } {
	global gdb:lasterror
	set gdb:lasterror [lindex [lindex $rl 2] 0]
	return {}
    }

    # Note: GDB randomly crashes when attempting to execute commands
    # involving function calls in the user code after a watchpoint is reached.
    # So don't even try to use the "call" feature from a breakpoint command
    # list. Instead, we directly write into the debug control register of the
    # simulator to schedule a break state at the next code preemption.

    gdb:send "commands"
    gdb:send "silent"
    set flag [TkRequest $context GetCtlCode WATCHPOINT_BREAK]
    gdb:send "set *((int *)${gdb:mvmcr0}) |= $flag"
    gdb:send "continue"
    gdb:send "end"
    gdb:waitprompt

    return $wpnum
}

proc gdb:removewp {wpnum} {
    gdb:command "delete $wpnum"
}

proc gdb:disablewp {wpnum} {
    gdb:command "disable $wpnum"
    return true
}

proc gdb:enablewp {wpnum} {
    gdb:command "enable $wpnum"
}

proc gdb:fatal {context errmsg} {
    gdb:close $context
    Debugger:exit $context $errmsg
}

proc gdb:movestack {context whence {levels 1}} {

    # Move up/down in the current stack and return the new code
    # location. GDB output PC locations differently whether it has
    # found debug information or not for the code spot.

    set nre {}
    set log {}
    set matched {}

    set rl [gdb:command "$whence $levels" l \
		 { "^\032\032.*" \
 		       "^#\[0-9\]+ +0x\[0-9a-fA-F\]+ in \[^ \]+ \\(\\)$" }]
    set nre [lindex $rl 0]
    set matched [lindex $rl 1]
    set log [lindex $rl 2]

    if {$nre == -1} {
	gdb:fatal $context "debugger died unexpectedly!?"
	return {}
    }

    set hotspot {}
    set pos [lsearch -regexp $log "^#\[0-9\]+.*"]

    switch -- $nre {
	    0 {
		# ^Z^Z RE matched: find function name in log
		if {[regexp "^#\[0-9\]+ +0x\[0-9a-fA-F\]+ in (\[^ \]+) .*" \
			 [lindex $log $pos] mvar function] == 0} {
		    regexp "^#\[0-9\]+ +(\[^ \]+) \\(.*" \
			[lindex $log $pos] mvar function
		}
		set l [split $matched :]
		set sourcefile [string range [lindex $l 0] 2 end]
		set lineno [lindex $l 1]
		set hotspot [list $function $sourcefile $lineno]
	    }

	    default {
		# debug-disabled code  RE matched: extract function name
		# this may also occur if the source file cannot be reached
		# by GDB (e.g. wrong source directory list).
 		if {[regexp "^#\[0-9\]+ +0x\[0-9a-fA-F\]+ in (\[^ \]+).*" \
 			 [lindex $log $pos] mvar function] == 0} {
 		    regexp "^.*, (\[_a-zA-Z\]+) \\(\\)" \