gdb.tcl

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

#  This file is part of the XENOMAI project.
#
#  Copyright (C) 1997-2000 Realiant Systems.  All rights reserved.
#  Copyright (C) 2001,2002 Philippe Gerum <[e-mail]>.
# 
#  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 2 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.
# 
#  Author(s): rpm
#  Contributor(s):
#
#  Adapted to XENOMAI by Philippe Gerum.

# This Tcl script supports various aspects of the dialog with a GDB
# session. This script should be totally rewritten (so as some parts
# of the gdb helper) to make full use of GDB's annotation
# feature. Anyway, this is a quite good example of what can be done
# when annotation is not available from a debug engine... Currently,
# only the --fullname extension is used.

set gdb:args "--quiet --nx --nw --fullname --readnow"
set gdb:traps {"^Program received signal .*" \
	       "^warning: \[A-Za-z\]* \[Ww\]atchpoint \[0-9\]+: Could not insert watchpoint" \
	       "^\032\032.*" \
	       "Breakpoint \[0-9\]+, ((0x)|\[_A-Za-z\]+).*" \
	       "0x\[0-9a-fA-F\]+ in .*" \
	       "^Program exited normally" \
	       "^Program exited abnormally" \
	       "^Program exited with code .*" \
	       "^Program terminated .*" }

set gdb:signaled false
set gdb:siginfo ""
set gdb:killed false
set gdb:btcache {}
set gdb:stream {}
set gdb:pipe {}
set gdb:lasterror {}
set gdb:bhook {}
set gdb:wpsupport unknown
set gdb:mvmcr0 {}
set gdb:mvmcr1 {}
set gdb:mvmcr2 {}
set gdb:mvmcr3 {}
set gdb:mvmeh 0
set gdb:lastexpr {}
set gdb:obsoleted false
# C++ linkvar: boolean gdb:dead

# global tcl_traceExec
# set tcl_traceExec 1

proc gdb:oread {pipe} {

    while {[gets $pipe s] != -1} {
	puts stdout $s
    }
}

proc gdb:init {context gdbpath filename simargs srcDirs pipeout} {

    global gdb:killed gdb:stream gdb:bhook gdb:pipe
    global gdb:args gdb:btcache gdb:signaled

    set gdb:killed false
    set gdb:signaled false
    set gdb:btcache {}
    set gdb:stream {}
    # Assume the first stop is caused by the preamble breakpoint.
    set gdb:bhook gdb:preamble

    if {[catch {
	# must have GDB's stdout/stderr grouped in a single stream...
	set stream [open "|$gdbpath ${gdb:args} --tty $pipeout $filename |& cat" r+]
    }] == 1} {
  	# GDB not found or unstartable
	return {}
    }

    if {$stream == {}} {
  	# Problem starting GDB
  	return {}
    }

    # Initialize the i/o sub-layer (C++ part)
    set gdb:stream $stream
    gdb:initio $stream

    set gdb:pipe [open $pipeout r+]
    fconfigure ${gdb:pipe} -blocking false -translation binary -buffering none
    fileevent ${gdb:pipe} readable "gdb:oread ${gdb:pipe}"

    # Event handler must be set before calling gdb:waitprompt
    fconfigure $stream -blocking false -translation binary -buffering none
    fileevent $stream readable gdb:iread
    # Ensure we'll have the right prompt
    gdb:send "set prompt %gdb%"

    if {[gdb:waitprompt] == -1} {
	# debug session has been aborted
	return {}
    }

    # Set miscellaneous attributes
    gdb:command "set editing off"
    gdb:command "set height 0"
    gdb:command "set width 0"
    gdb:command "set confirm off"

    # Ensure the shared libs are attached before an attempt is
    # made to set the internal breakpoints. We do this by executing
    # the crt prolog (bp main + run). Better ideas are welcome... 
    set rl [gdb:command "break main" l {"^Breakpoint \[0-9\]+.*"}]
    set nre [lindex $rl 0]
    if {$nre != 0} {
	set matched [lindex [lindex $rl 2] 0]
	gdb:close $context
	tk_messageBox \
	    -message "GDB error: $matched" \
	    -type ok -icon error -title " "
	return {}
    }
    regexp "^Breakpoint (\[0-9\]+)" [lindex $rl 1] mvar bpnum
    gdb:command "run"
    gdb:command "delete $bpnum"

    # Install internal breakpoints on break trap and exception handler

    foreach bp {mvm_bp mvm_eh} {
	set rl [gdb:command "break *$bp" l {"^Breakpoint \[0-9\]+.*"}]
	set nre [lindex $rl 0]
	if {$nre != 0} {
	    # cannot set internal breakpoint in debuggee's code
	    set matched [lindex [lindex $rl 2] 0]
	    gdb:close $context
	    tk_messageBox \
		-message "GDB error: $matched" \
		-type ok -icon error -title " "
	    return {}
	}
    }

    # Setup source directories list (if given)
    if {$srcDirs != {}} {
	gdb:command "directory $srcDirs"
    }

    return $stream
}

proc gdb:close {context} {

    global gdb:dead gdb:killed gdb:stream gdb:pipe

    catch { close ${gdb:pipe} }
    gdb:doneio
    catch { fileevent ${gdb:stream} readable {} }
    set gdb:killed true

    if {${gdb:dead} == 0} {
	# Help Tcl a bit by wiping GDB out before actually
	# closing the pipe.
	catch { exec -- kill -HUP [lindex [pid ${gdb:stream}] 0] }
	set gdb:dead 1
	catch { close ${gdb:stream} }
    }
}

proc gdb:waitprompt {} {
    return [lindex [gdb:expect {"^%gdb%"}] 0]
}

# FIXME: the current implementation views the dispatch loop
# processing messages from GDB as a synchronous activity. This
# is quite a dumb choice. The next implementation, using the
# annotation level, should integrate the dispatch loop to the
# input "expect" routine, so as to view it as an asynchronous
# task. This way, we should be able to say that we *always* listen
# to what GDB says, and not only when we are expecting something
# from it. Error processing should be considerably eased and made
# more robust after this improvement.

proc gdb:dispatch {context {notify true}} {

    global gdb:traps gdb:signaled gdb:siginfo
    global gdb:killed gdb:bhook gdb:obsoleted

    set rl [gdb:expect ${gdb:traps}]
    set nre [lindex $rl 0]
    set matched [lindex $rl 1]

    if {$nre == -1} {
	# do not raise fatal error if we did kill the inferior GDB
	# inside gdb:close().
	if {${gdb:killed} == "false"} {
	    gdb:fatal $context "debugger died unexpectedly!?"
	}
	return
    }

    if {$nre != 0} {
	# Eat the next prompt sent by GDB as it regained control
	# over the debuggee... except if we are next to process
	# a signal receipt. Yes, this is a slimy hack! This prevents
	# the prompt to be matched *before* the faulty address
	# is caught as a recognized regexp by gdb:dispatch().
	# Otherwise, the fault breakpoint would be discarded in the
	# process of matching it.
	gdb:waitprompt
    }

    switch -- $nre {

	0 {
	    # program received a signal - a break is expected next to this
	    regexp "Program received signal (.*)" $matched mvar gdb:siginfo
	    set gdb:signaled true
	    # Always notify on signal receipt - dispatch could recurse
	    # indefinitely if running an internal debug control operation,
	    # but the debugger will display the fault address;
	    # anyway, the simulation should never catch a signal during
	    # a thread bump, otherwise, this situation really needs to be
	    # inspected!
	    # go fetching the faulty code location
	    gdb:dispatch $context
	}

	1 {
	    # watchpoint error -- we *must* trap this error condition at
	    # this level too (i.e. so as switchout does). Watchpoint support for
	    # the GDB module is really a mess!
	    if {[regexp "\[Ww\]atchpoint (\[0-9\]+):" $matched mvar wpnum] == 1} {
		# notify the front-end this watchpoint is about to be disabled
		global gdb:lasterror
		set gdb:lasterror $matched
		Debugger:notifyWatchError $context $wpnum
		# automatically disable faulty watchpoint and resume
		gdb:disablewp $wpnum
		gdb:send cont
		# go back listening to GDB
		gdb:dispatch $context
	    }
	}

	2 {
	    # Breakpoint hit in a portion of source compiled with
	    # debugging information- --fullname option makes gdb emit
	    # this kind of informative line when a bp is reached:
	    # ^Z^Z<source-file>:<source-line>:<char-num>:<mid/beg>:<pc>
	    # "beg/mid" standing for a flag indicating whether the returned
	    # pc points to the beginning of the line or not (i.e. "mid"
	    # for middle).

	    # If returning from an internal dispatch: do not notify
	    # user layer about it - otherwise, we would recurse
	    # indefinitely...

	    if {$notify == "true"} {
		set l [split $matched :]
		set sourcefile [string range [lindex $l 0] 2 end]
		set lineno [lindex $l 1]

		if {${gdb:signaled} == "true"} {
		    Debugger:notifyException $context \
			[list $sourcefile $lineno] ${gdb:siginfo}
		} {
		    global gdb:mvmeh
		    set bpaddr [lindex $l 4]

		    # Check that the trapped address is located in a range
		    # of 8 bytes starting from the mvm_eh() prologue do
		    # determine whether we've juste caught an exception
		    # or not. Ahemmm... not proud of this code, sorry :-/

		    if {[expr $bpaddr >= ${gdb:mvmeh} && $bpaddr <= ${gdb:mvmeh} + 8]} {
			# An unexpected exception
			# has just be caught -- make the signal being
			# raised again telling GDB to handle it as a
			# fault this time. RE #0 should be selected
			# next on input.
			gdb:send cont
			gdb:dispatch $context
		    } {
			${gdb:bhook} $context [list $sourcefile $lineno]
		    }
		}
	    }
	}

	3 - 4 {
	    # Breakpoint/stop hit in a portion of source compiled
	    # with no debugging information available.

	    if {$notify == "true"} {
		if {[regexp ".*0x\[0-9a-fA-F\]+ in (\[^ \]+).*" \
			 $matched mvar function] == 0} {
		    regexp ".*, (\[_a-zA-Z\]+) \\(\\)" \
			$matched mvar function
		}

		if {${gdb:signaled} == "true"} {
		    if {[string match *SIGTRAP* ${gdb:siginfo}] == 0} {
			Debugger:notifyException $context \
			    [list $function] ${gdb:siginfo}
		    } {
			# Circumvent GDB problem raised by catching a SIGTRAP
			# exception which should not happen, but do occur on some
			# platforms.
			set gdb:signaled false
			gdb:send cont
			gdb:dispatch $context
		    }
		} {
		    if {$function == "mvm_eh"} {
			# An unexpected exception
			# has just be caught -- make the signal being
			# raised again telling GDB to handle it as a
			# fault this time. RE #0 should be selected
			# next on input.
			gdb:send cont
			gdb:dispatch $context
		    } {
			${gdb:bhook} $context [list $function]
		    }
		}
	    }
	}

	5 {
	    # Program exited normally
	    gdb:close $context
	    Debugger:exit $context
	}

	6 {
	    # Program exited abnormally
	    gdb:close $context
	    Debugger:exit $context $matched
	}

	7 {
	    # Program exited with code "nn"
	    gdb:close $context
	    Debugger:exit $context $matched
	}

	8 {
	    # Program terminated (SIGKILL)
	    set gdb:signaled true
	    gdb:close $context
	    Debugger:exit $context $matched
	}
    }
}

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

    global gdb:mvmcr0 gdb:mvmcr1

    # Direct stack context to the designated focus
    set scope [lindex $focuscmd 0]
    set flag [TkRequest $context GetCtlCode $scope]
    set id [lindex $focuscmd 1]

    gdb:command "set *((int *)${gdb:mvmcr0}) |= $flag"
    gdb:command "set *((int *)${gdb:mvmcr1}) = $id"
    gdb:command "call mvm_switch()"

    if {$fnum != {}} {
	# Adjust the stack level to the specified one; also
	# return the code location reached after the adjustment.
	set hotspot [gdb:movestack $context up $fnum]
	return $hotspot
    }

    return {}
}

proc gdb:switchout {context} {

    # GDB may experience problems resetting watchpoints in the
    # user-code when returning from the internal breakpoint
    # (i.e. thread context bump).  Trap this error here, and notify
    # the ISE that the faulty watchpoint has been automatically
    # disabled.

    while {1} {
	set rl [gdb:command cont - \
		{ "^warning: \[A-Za-z\]* \[Ww\]atchpoint \[0-9\]+: Could not insert watchpoint" }]
	set nre [lindex $rl 0]
	if {$nre == 0} {
	    global gdb:lasterror
	    set matched [lindex $rl 1]
	    regexp "\[Ww\]atchpoint (\[0-9\]+):" $matched mvar wpnum
	    set gdb:lasterror $matched
	    # disable the faulty watchpoint
	    gdb:disablewp $wpnum
	    # notify the front-end this watchpoint is about to be disabled
	    Debugger:notifyWatchError $context $wpnum