"
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
inclusion of the above copyright notice. This software may not
be provided or otherwise made available to, or used by, any
other person. No title to or ownership of the software is
hereby transferred.
"
StandardSystemView subclass:#DebugView
instanceVariableNames:'busy haveControl exitAction canContinue
contextView codeView
receiverInspector contextInspector
contextArray selectedContext
catchBlock grabber traceView tracing
bigStep skipLineNr steppedContextAddress canAbort
abortButton terminateButton continueButton
stepButton sendButton returnButton restartButton
exclusive inspecting nChainShown
inspectedProcess updateProcess
monitorToggle'
classVariableNames:'CachedDebugger CachedExclusive MoreDebuggingDetail'
poolDictionaries:''
category:'Interface-Debugger'
!
DebugView comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
$Header: /cvs/stx/stx/libtool/DebugView.st,v 1.20 1994-11-28 21:11:09 claus Exp $
'!
!DebugView class methodsFor:'documentation'!
copyright
"
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
inclusion of the above copyright notice. This software may not
be provided or otherwise made available to, or used by, any
other person. No title to or ownership of the software is
hereby transferred.
"
!
version
"
$Header: /cvs/stx/stx/libtool/DebugView.st,v 1.20 1994-11-28 21:11:09 claus Exp $
"
!
documentation
"
this class implements a graphical debugger interface.
The debugger usually sits on top of the faulting process,
taking over its event processing. Thus only the 'stopped' process is affected;
other processes continue to respond to events.
The one exception is when an error occurs within the dispatcher process
or in one of the eventhandler processes - in this case, the debugger
will sit on an exclusive display connection.
The whole debugging will be changed, once the required process primitives
are available, which allow control of another processes execution
(i.e. single-step, restart & return). The setup will be changed then,
to have the debugger control the debuggee (i.e. two processes)
See additional information in 'doc/misc/debugger.doc'.
Notice: the DebugView class caches the last used debugger in a class
variable. It may happen, that a malfunctioning debugger (for example,
a halfway destoyed one) is kept there. You will notice this, if a
debugger comes up without showing any contents. In this case, close
(or destroy) the broken debugView, and execute
Debugger newDebugger
which removes the cached debugger and forces creation of a new one the
next time. This is a temporary workaround - the debugger will be fixed to
avoid this problem.
"
! !
!DebugView class methodsFor:'instance creation'!
new
"return a new DebugView - return a cached debugger if it already
exists"
|debugger active|
"need a blocking debugger if no processes or
or if its a timing/interrupt process
(because otherwise we would not get any events here ..."
active := Processor activeProcess.
(ProcessorScheduler isPureEventDriven
or:[(active priority >= Processor userInterruptPriority)
or:[active id == 0
or:[active nameOrId endsWith:'dispatcher']]]) ifTrue:[
CachedExclusive isNil ifTrue:[
debugger := self newExclusive
] ifFalse:[
debugger := CachedExclusive.
CachedExclusive := nil.
].
] ifFalse:[
CachedDebugger isNil ifTrue:[
debugger := super new.
debugger label:'Debugger'.
debugger icon:(Form fromFile:'Debugger.xbm' resolution:100).
] ifFalse:[
debugger := CachedDebugger.
CachedDebugger := nil.
]
].
^ debugger
!
newExclusive
"return a debugger for exclusive display access"
|debugger|
debugger := super on:ModalDisplay.
debugger label:'Debugger'.
debugger icon:(Form fromFile:'Debugger.xbm' resolution:100).
debugger exclusive:true.
^ debugger
!
newDebugger
"force creation of a new debugger"
CachedDebugger := nil.
CachedExclusive := nil
"DebugView newDebugger"
!
enterWithMessage:aString
"the standard way of entering the debugger - sent from Objects
error- and halt messages"
thisContext isRecursive ifTrue:[
^ MiniDebugger enterWithMessage:aString
].
^ self enter:(thisContext sender) withMessage:aString
"Debugger enterWithMessage:'hi there'"
!
enter
"another way of entering the debugger"
^ self enter:(thisContext sender) withMessage:'Debugger'
"Debugger enter"
!
enter:aContext
"enter the debugger on aContext"
^ self enter:aContext withMessage:'Debugger'
!
enter:aContext withMessage:aString
"enter a debugger; if this is a recursive invocation, enter
a MiniDebugger instead.
This is the standard way of entering the debugger;
sent from error- and halt messages."
thisContext isRecursive ifTrue:[
^ MiniDebugger enterWithMessage:'recursive error'.
].
^ self enterUnconditional:aContext withMessage:aString
!
enterUnconditional:aContext withMessage:aString
"enter a debugger - do not check for recursive invocation"
|aDebugger|
StepInterruptPending := nil.
aDebugger := self new.
aDebugger label:aString , ' (' , Processor activeProcess nameOrId , ')'.
aDebugger enter:aContext.
^ nil
"nil halt"
!
openOn:aProcess
"start a debugger on aProcess
(actually not more than a good-looking inspector)"
|aDebugger label nm|
aDebugger := super new.
aDebugger icon:(Form fromFile:'Debugger.xbm' resolution:100).
aProcess notNil ifTrue:[
nm := aProcess name.
nm notNil ifTrue:[
nm := (aProcess nameOrId contractTo:17) , '-' , aProcess id printString
] ifFalse:[
nm := aProcess id printString
].
label := 'Debugger [' , nm , ']'.
] ifFalse:[
label := 'no process'
].
aDebugger label:label.
aDebugger iconLabel:'Debugger'.
aDebugger openOn:aProcess.
^ nil
! !
!DebugView methodsFor:'initialization'!
initialize
|v panel hpanel bpanel dummy|
super initialize.
font := font on:device.
busy := false.
exclusive := false.
inspecting := false.
exitAction := nil.
bigStep := false.
canContinue := false.
canAbort := false.
bpanel := HorizontalPanelView
origin:(0.0 @ 0.0)
extent:(1.0 @ (font height * 2))
in:self.
bpanel layout:#left.
terminateButton := Button
label:(resources at:'terminate')
action:[terminateButton turnOffWithoutRedraw. self doTerminate]
in:bpanel.
dummy := View extent:(20 @ 5) in:bpanel.
dummy borderWidth:0; level:0.
abortButton := Button
label:(resources at:'abort')
action:[abortButton turnOffWithoutRedraw. self doAbort]
in:bpanel.
returnButton := Button
label:(resources at:'return')
action:[returnButton turnOff. self doReturn]
in:bpanel.
restartButton := Button
label:(resources at:'restart')
action:[restartButton turnOff. self doRestart]
in:bpanel.
dummy := View extent:(20 @ 5) in:bpanel.
dummy borderWidth:0; level:0.
continueButton := Button
label:(resources at:'continue')
action:[continueButton turnOffWithoutRedraw. self doContinue]
in:bpanel.
dummy := View extent:(20 @ 5) in:bpanel.
dummy borderWidth:0; level:0.
stepButton := Button
label:(resources at:'step')
action:[stepButton turnOff. self doStep]
in:bpanel.
sendButton := Button
label:(resources at:'send')
action:[sendButton turnOff. self doSend]
in:bpanel.
panel := VariableVerticalPanel
origin:(0.0 @ bpanel height)
corner:(1.0 @ 1.0)
in:self.
v := ScrollableView for:SelectionInListView in:panel.
v origin:(0.0 @ 0.0) corner:(1.0 @ 0.25).
contextView := v scrolledView.
contextView action:[:lineNr | self showSelection:lineNr].
v := ScrollableView for:CodeView in:panel.
v origin:(0.0 @ 0.25) corner:(1.0 @ 0.75).
codeView := v scrolledView.
hpanel := VariableHorizontalPanel in:panel.
hpanel origin:(0.0 @ 0.75) corner:(1.0 @ 1.0).
receiverInspector := InspectorView
origin:(0.0 @ 0.0) corner:(0.5 @ 1.0)
in:hpanel.
contextInspector := ContextInspectorView
origin:(0.5 @ 0.0) corner:(1.0 @ 1.0)
in:hpanel
!
initializeMiddleButtonMenu
|labels m|
labels := resources array:#(
'show more'
'-'
"
'continue'
'terminate'
'abort'
'-'
'step'
'send'
'-'
'return'
'restart'
'-'
"
'remove breakpoint'
'remove all trace & breakpoints'
'-'
'implementors ...'
'senders ...'
'-'
'inspect context'
'-'
'quickTerminate'
'-'
'exit smalltalk'
).
m := (PopUpMenu
labels:labels
selectors:#(
doShowMore
nil
"
doContinue
doTerminate
doAbort
nil
doStep
doSend
nil
doReturn
doRestart
nil
"
doRemoveBreakpoint
doRemoveAllBreakpoints
nil
doImplementors
doSenders
nil
doInspectContext
nil
doQuickTerminate
nil
doExit
)
receiver:self
for:contextView).
contextView middleButtonMenu:m.
inspecting ifTrue:[
m notNil ifTrue:[
m disable:#doTraceStep.
m disable:#doRemoveBreakpoint.
].
]
!
reinitialize
super reinitialize.
"
this is reached, when we come up after a restart.
ST/X does not support this, since the contexts are
all dead, and processes have been recreated.
"
super destroy
!
addToCurrentProject
"ignored here"
^ self
!
createOnTop
^ false "true"
!
realize
super realize.
exclusive ifTrue:[
windowGroup := nil
].
inspectedProcess notNil ifTrue:[
"
set prio somewhat higher (by 2, to allow walkBack-update process
to run between mine and the debugged processes prio)
"
Processor activeProcess
priority:(inspectedProcess priority + 2 min:16).
]
! !
!DebugView methodsFor:'interrupt handling'!
stepInterrupt
|where here s isWrap method lastWrappedConAddr wrappedMethod|
Processor activeProcess ~~ inspectedProcess ifTrue:[
'stray step interrupt' errorPrintNL.
^ self
].
"
kludge: check if we are in a wrapper methods hidden setup-sequence
"
here := thisContext. "stepInterrupt"
here := here sender. "the interrupted context"
"/ 'here in ' print.
"/ ((ObjectMemory addressOf:here) printStringRadix:16)print. '' printNL.
where := here.
isWrap := false.
wrappedMethod := nil.
5 timesRepeat:[
"/ where selector printNL.
where notNil ifTrue:[
method := where method.
(method notNil and:[method isWrapped]) ifTrue:[
"
in a wrapper method
"
wrappedMethod ~~ method ifTrue:[
wrappedMethod := method.
lastWrappedConAddr := ObjectMemory addressOf:where.
where sender receiver == method originalMethod ifFalse:[
isWrap := true.
]
] ifFalse:[
(ObjectMemory addressOf:where) == steppedContextAddress ifTrue:[
"/ 'change stepCon from: ' print.
"/ (steppedContextAddress printStringRadix:16)print.
"/ ' to: ' print.
"/ (lastWrappedConAddr printStringRadix:16)printNL.
steppedContextAddress := lastWrappedConAddr
]
]
].
where := where sender
]
].
isWrap ifTrue:[
"/ 'ignore wrap' printNL.
"
ignore, while in wrappers hidden setup
"
where := nil. here := nil.
ObjectMemory flushInlineCaches.
StepInterruptPending := true.
InterruptPending := true.
InStepInterrupt := nil.
^ nil
].
"
is this for a send or a step ?
"
bigStep ifTrue:[
"
a step - ignore all contexts below the interresting one
"
where := here. "the interrupted context"
(ObjectMemory addressOf:where) == steppedContextAddress ifFalse:[
where := where sender.
"/ 'look for ' print.
"/ (steppedContextAddress printStringRadix:16)print. '' printNL.
(ObjectMemory addressOf:where) == steppedContextAddress ifFalse:[
"
check if we are in a context below steppedContext
(i.e. if steppedContext can be reached from
interrupted context. Not using context-ref but its
address to avoid creation of many useless contexts.)
"
[where notNil] whileTrue:[
"/ ((ObjectMemory addressOf:where) printStringRadix:16)print. ' ' print.
"/ where selector printNL.
(ObjectMemory addressOf:where) == steppedContextAddress ifTrue:[
"/ 'found it - below' printNL.
"
found the interresting context somwehere up in the
chain. We seem to be still below the interresting one ...
"
tracing == true ifTrue:[
here printString printNewline
].
where := nil. here := nil.
"
yes, a context below
- continue and schedule another stepInterrupt.
Must flush caches since optimized methods not always
look for pending interrupts
"
ObjectMemory flushInlineCaches.
StepInterruptPending := true.
InterruptPending := true.
InStepInterrupt := nil.
^ nil
].
where := where sender
].
s := 'left stepped method'
] ifTrue:[
"/ 'found it right in sender' printNL.
s := 'after step'
].
] ifTrue:[
"/ 'found it right away' printNL.
s := 'after step'
].
tracing := false.
bigStep := false.
] ifFalse:[
"
a send
"
steppedContextAddress := nil.
s := 'after send'
].
name := Processor activeProcess nameOrId.
self label:(s , ' (process: ' , name , ')').
"release refs to context"
where := nil. here := nil.
self enter:thisContext sender
! !
!DebugView methodsFor:'basic'!
enter
"enter the debugger - on the sending context"
|where|
busy := true.
where := thisContext. "enter"
where := where sender. "the calling context"
where notNil ifTrue:[
(where receiver == DebugView) ifTrue:[
where := where sender
]
"where is now interrupted methods context"
].
^ self enter:where
!
enter:aContext
"enter the debugger - get and display the context, then start an
exclusive event loop on top of eveything else"
|con selection m|
busy := true.
inspecting := false.
inspectedProcess := Processor activeProcess.
bigStep := false.
nChainShown := 50.
"if debugger is entered while a box has grabbed the
pointer, we must ungrab - otherwise X wont talk to
us here
"
(grabber := device activePointerGrab) notNil ifTrue:[
device ungrabPointer
].
terminateButton enable.
drawableId notNil ifTrue:[
"not the first time - realize at old position"
terminateButton turnOffWithoutRedraw.
continueButton turnOffWithoutRedraw.
abortButton turnOffWithoutRedraw.
stepButton turnOffWithoutRedraw.
sendButton turnOffWithoutRedraw.
"/ self rerealize
] ifFalse:[
exclusive ifFalse:[
windowGroup isNil ifTrue:[
windowGroup := WindowGroup new.
windowGroup addTopView:self.
].
].
"/ self realize.
self iconLabel:'Debugger'.
].
"/ "
"/ bring us to the top
"/ "
"/ self raise.
"/ Display synchronizeOutput.
"
get the walkback list
"
self setContext:aContext.
"
and find one to show
"
exitAction == #step ifTrue:[
selection := 1.
steppedContextAddress notNil ifTrue:[
"
if we came here by a big-step, show the method where we are
"
steppedContextAddress notNil ifTrue:[
(ObjectMemory addressOf:aContext) == steppedContextAddress ifTrue:[
selection := 1
] ifFalse:[
(ObjectMemory addressOf:aContext sender) == steppedContextAddress ifTrue:[
selection := 2
]
]
]
]
] ifFalse:[
steppedContextAddress isNil ifTrue:[
"
preselect a more interresting context, (where halt/raise was ...)
"
selection := self interrestingContextFrom:aContext.
] ifFalse:[
"
if we came here by a big-step, show the method where we are
"
steppedContextAddress notNil ifTrue:[
(ObjectMemory addressOf:aContext) == steppedContextAddress ifTrue:[
selection := 1
] ifFalse:[
(ObjectMemory addressOf:aContext sender) == steppedContextAddress ifTrue:[
selection := 2
]
]
]
]
].
selection notNil ifTrue:[
self showSelection:selection.
contextView selection:selection
].
m := contextView middleButtonMenu.
m notNil ifTrue:[
canAbort := inspecting or:[Object abortSignal isHandled].
canAbort ifTrue:[
abortButton enable.
m enable:#doAbort.
] ifFalse:[
abortButton disable.
m disable:#doAbort.
].
exclusive ifTrue:[
terminateButton disable.
m disable:#doTerminate.
] ifFalse:[
terminateButton enable.
m enable:#doTerminate.
]
].
drawableId notNil ifTrue:[
self rerealize
] ifFalse:[
self realize.
].
"
bring us to the top
"
self raise.
Display synchronizeOutput.
"
enter private event handling loop
"
canContinue := true.
exitAction := nil.
self controlLoop.
"
release all context stuff.
This is required, since the debugger is reused,
to avoid keeping references to the debuggees objects
forever.
"
contextArray := nil.
codeView contents:nil.
codeView acceptAction:nil.
contextView contents:nil.
receiverInspector release.
contextInspector release.
(exitAction == #step) ifFalse:[
self unrealize.
device synchronizeOutput.
(exitAction == #abort) ifTrue:[
selectedContext := nil.
busy := false.
exclusive ifTrue:[CachedExclusive := self] ifFalse:[CachedDebugger := self].
"
have to catch errors occuring in unwind-blocks
"
Object errorSignal handle:[:ex |
'ignored error while unwinding: ' errorPrint.
ex errorString errorPrintNL.
ex proceed
] do:[
Object abortSignal raise.
].
'abort failed' errorPrintNL
].
(exitAction == #return) ifTrue:[
selectedContext notNil ifTrue:[
con := selectedContext.
selectedContext := nil.
busy := false.
exclusive ifTrue:[CachedExclusive := self] ifFalse:[CachedDebugger := self].
"
have to catch errors occuring in unwind-blocks
"
Object errorSignal handle:[:ex |
'ignored error while unwinding: ' errorPrint.
ex errorString errorPrintNL.
ex proceed
] do:[
con unwind.
].
'cannot return selected context' errorPrintNL
]
] ifFalse:[
(exitAction == #restart) ifTrue:[
selectedContext notNil ifTrue:[
con := selectedContext.
selectedContext := nil.
busy := false.
exclusive ifTrue:[CachedExclusive := self] ifFalse:[CachedDebugger := self].
"
have to catch errors occuring in unwind-blocks
"
Object errorSignal handle:[:ex |
'ignored error while unwinding: ' errorPrint.
ex errorString errorPrintNL.
ex proceed
] do:[
con restart.
].
'cannot restart selected context' errorPrintNL
]
] ifFalse:[
((exitAction == #terminate) or:[exitAction == #quickTerminate]) ifTrue:[
selectedContext := nil.
busy := false.
exclusive ifTrue:[CachedExclusive := self] ifFalse:[CachedDebugger := self].
exitAction == #quickTerminate ifTrue:[
Processor activeProcess terminateNoSignal
] ifFalse:[
"
have to catch errors occuring in unwind-blocks
"
Object errorSignal handle:[:ex |
'ignored error while unwinding: ' errorPrint.
ex errorString errorPrintNL.
ex proceed
] do:[
Processor activeProcess terminate.
].
].
'cannot terminate process' errorPrintNL
]
]
]
].
selectedContext := nil.
grabber notNil ifTrue:[
device grabPointerInView:grabber.
grabber := nil.
].
(exitAction == #step) ifTrue:[
"scedule another stepInterrupt
- must flush caches since optimized methods not always
look for pending interrupts"
ObjectMemory flushInlineCaches.
ObjectMemory stepInterruptHandler:self.
StepInterruptPending := true.
InterruptPending := true.
InStepInterrupt := nil
] ifFalse:[
busy := false.
exclusive ifTrue:[CachedExclusive := self] ifFalse:[CachedDebugger := self]
]
!
openOn:aProcess
"enter the debugger on a process -
in this case, we are just inspecting the context chain of the process,
not running on top of the debugged process, but as a separate
one. (think of it as an inspector showing more detail, and offering
some more control operations)"
|bpanel updateButton stopButton dummy|
busy := true.
bigStep := false.
inspecting := true.
inspectedProcess := aProcess.
nChainShown := 50.
bpanel := abortButton superView.
stopButton := Button new.
stopButton label:(resources at:'stop');
action:[self doStop].
bpanel addSubView:stopButton after:continueButton.
dummy := View extent:(20 @ 5) in:bpanel.
dummy borderWidth:0; level:0.
"/ stepButton destroy.
"/ sendButton destroy.
updateButton := Button
label:(resources at:'update')
action:[self updateContext]
in:bpanel.
monitorToggle := Toggle in:bpanel.
monitorToggle label:(resources at:'monitor').
monitorToggle pressAction:[self autoUpdateOn].
monitorToggle releaseAction:[self autoUpdateOff].
"can only look into process - context chain is not active"
canContinue := true.
terminateButton enable.
abortButton enable.
sendButton disable.
stepButton disable.
"/ continueButton disable.
"/ returnButton disable.
"/ restartButton disable.
aProcess isNil ifTrue:[
terminateButton disable.
abortButton disable.
continueButton disable.
returnButton disable.
restartButton disable.
] ifFalse:[
aProcess suspendedContext isNil ifTrue:[
terminateButton disable.
].
self setContext:aProcess suspendedContext.
catchBlock := [
catchBlock := nil.
contextArray := nil.
selectedContext := nil.
(exitAction == #terminate) ifTrue:[
aProcess terminate.
].
(exitAction == #quickTerminate) ifTrue:[
aProcess terminateNoSignal.
].
super destroy
].
].
self open
! !
!DebugView methodsFor:'private control loop'!
controlLoop
"this is a kludge:
start a dispatchloop which exits when
either continue, return or step is pressed
"
haveControl := true.
[haveControl] whileTrue:[
self controlLoopCatchingErrors
].
catchBlock := nil.
!
controlLoopCatchingErrors
"setup a self removing catch-block"
catchBlock := [catchBlock := nil. ^ nil].
exclusive ifTrue:[
"if we do not have multiple processes or its a system process
we start another dispatch loop, which exits when
either continue, return or step is pressed
or (via the catchBlock) if an error occurs.
Since our display is an extra exclusive one (ModalDisplay)
all processing for normal views stops here ...
"
device dispatchModalWhile:[haveControl]
] ifFalse:[
"we do have multiple processes -
simply enter the DebugViews-Windowgroup event loop.
effectively suspending event processing for the currently
active group.
"
SignalSet anySignal handle:[:ex |
|answer|
answer := self confirm:('error in debugger: ' , ex errorString , '\\debug again ?') withCRs.
answer ifTrue:[
Debugger enterUnconditional:(ex suspendedContext) withMessage:'error in debugger: ' , ex errorString.
] ifFalse:[
'ignored error in debugger: ' errorPrint.
ex errorString errorPrintNL.
].
ex return.
] do:[
windowGroup eventLoopWhile:[true]
].
].
catchBlock := nil.
! !
!DebugView methodsFor:'private'!
busy
^ busy
!
showError:message
codeView contents:(resources string:message).
codeView flash
!
showTerminated
self showError:'** the process has terminated **'
!
processAction:aBlock
"do something, then update the context list"
inspectedProcess isDead ifTrue:[
self showTerminated.
^ self
].
inspectedProcess interruptWith:aBlock.
"
give the process a chance to run, then update
"
(Delay forSeconds:0.2) wait.
self setContext:(inspectedProcess suspendedContext).
!
interruptProcessWith:aBlock
"let inspected process do something, then update the context list"
self processAction:[inspectedProcess interruptWith:aBlock.]
!
exclusive:aBoolean
exclusive := aBoolean
!
interrestingContextFrom:aContext
"return an interresting contexts offset, or nil.
This is the context initially shown in the walkback.
We move up the calling chain, skipping all intermediate Signal
and Exception contexts, to present the context in which the error
actually occured.
Just for your convenience :-)"
|c found offset sel prev|
"somewhere, at the bottom, there must be a raise ..."
c := aContext.
1 to:5 do:[:i |
c isNil ifTrue:[^ 1 "^ nil"].
sel := c selector.
(sel == #raise) ifTrue:[
offset := i.
found := c
].
c := c sender.
].
(c := found) isNil ifTrue:[^ 1].
"
got it; move up, skipping all intermediate Signal and
Exception contexts
"
prev := nil.
[
((c receiver isKindOf:Signal)
or:[(c receiver isKindOf:Exception)])
] whileTrue:[
prev := c.
(c := c sender) isNil ifTrue:[^ offset].
offset := offset + 1.
].
"
now, we are one above the raise
"
"
if the sender of the raise is one of objects error methods ...
"
( #( halt halt:
error error:
doesNotUnderstand:
subclassResponsibility
primitiveFailed) includes:c selector)
ifTrue:[
c selector == #doesNotUnderstand: ifTrue:[
"
one more up, to get to the originating context
"
(c := c sender) isNil ifTrue:[^ offset].
offset := offset + 1.
].
(c := c sender) isNil ifTrue:[^ offset].
offset := offset + 1.
] ifFalse:[
"
ok, got the raise - if its a BreakPoint, look for the sender
"
prev receiver == MessageTracer breakpointSignal ifTrue:[
offset := offset + 1
].
].
^ offset
!
setContext:aContext
"show calling chain from aContext in the walk-back listview"
|con text method caller caller2 m|
(contextArray notNil and:[aContext == (contextArray at:1)]) ifTrue:[
"no change"
^ false
].
m := contextView middleButtonMenu.
m notNil ifTrue:[
m disable:#doShowMore.
].
aContext isNil ifTrue:[
text := Array with:'** no context **'.
contextArray := nil.
] ifFalse:[
text := OrderedCollection new:nChainShown.
contextArray := OrderedCollection new:nChainShown.
con := aContext.
"
get them all
"
[con notNil and:[contextArray size <= nChainShown]] whileTrue:[
contextArray add:con.
(MoreDebuggingDetail == true) ifTrue:[
text add:(((ObjectMemory addressOf:con) printStringRadix:16) , ' ' , con printString).
] ifFalse:[
text add:con printString.
].
method := con method.
(method notNil and:[method isWrapped]) ifTrue:[
"
kludge: if its a wrapped method, then hide the wrap-call
"
caller := con sender.
(caller notNil and:[caller receiver == method originalMethod]) ifTrue:[
caller2 := caller sender.
(caller2 notNil and:[caller2 method == method]) ifTrue:[
con := caller2
]
].
caller := caller2 := nil
].
con := con sender
].
"
did we reach the end ?
"
(con isNil or:[con sender isNil]) ifTrue:[
"
the very last one is the startup context
(in main) - it has nil as receiver and nil as selector
"
contextArray last selector isNil ifTrue:[
contextArray removeLast.
text removeLast
]
] ifFalse:[
m notNil ifTrue:[
m enable:#doShowMore.
text add:(resources string:'*** more walkback follows - click here to see them ***')
].
].
].
contextView setList: "list:" text.
receiverInspector release.
contextInspector release.
m notNil ifTrue:[
m disable:#doRemoveBreakpoint.
m disable:#doImplementors.
m disable:#doSenders.
].
^ true
!
updateContext
|oldContext idx|
inspectedProcess state == #dead ifTrue:[
self showTerminated.
^ self
].
oldContext := selectedContext.
(self setContext:(inspectedProcess suspendedContext)) ifTrue:[
oldContext notNil ifTrue:[
contextArray notNil ifTrue:[
idx := contextArray identityIndexOf:oldContext.
idx ~~ 0 ifTrue:[
self showSelection:idx
] ifFalse:[
codeView contents:('** context returned **')
]
]
]
]
! !
!DebugView methodsFor:'user interaction'!
showSelection:lineNr
"user clicked on a header line - show selected code in textView"
|con homeContext sel method code canAccept
implementorClass lineNrInMethod rec m line|
contextArray notNil ifTrue:[
lineNr <= contextArray size ifTrue:[
con := contextArray at:lineNr.
].
"
clicking on the '** ...'-line shows more ...
"
con isNil ifTrue:[
line := contextView list at:lineNr.
(line startsWith:'**') ifTrue:[
self doShowMore.
contextView selection:lineNr.
con := contextArray at:lineNr
]
].
lineNrInMethod := con lineNumber.
con isBlockContext ifTrue:[
homeContext := con methodHome
] ifFalse:[
homeContext := con
].
contextInspector inspect:con.
homeContext isNil ifTrue:[
"
mhmh - an optimized block
should get the block here, and get the method from
that one ...
"
self showError:'** sorry; cannot show code of optimized blocks (yet) **'
] ifFalse:[
sel := homeContext selector.
sel notNil ifTrue:[
canAccept := true.
"/ implementorClass := homeContext searchClass whichClassImplements:sel.
implementorClass := homeContext methodClass.
implementorClass isNil ifTrue:[
"
special: look if this context was create by
valueWithReceiver kind of method invocation;
if so, grab the method from the sender and show it
"
"/ con sender selector printNL.
(con sender notNil
and:[(con sender selector == #valueWithReceiver:arguments:selector:search:)
and:[con sender receiver isKindOf:Method]]) ifTrue:[
method := con sender receiver.
code := method source.
canAccept := false.
] ifFalse:[
self showError:'** no method - no source **'
]
] ifFalse:[
method := implementorClass compiledMethodAt:sel.
code := method source.
code isNil ifTrue:[
method sourceFilename notNil ifTrue:[
codeView contents:(resources
string:'** no sourcefile: %1 **'
with:method sourceFilename).
codeView flash
] ifFalse:[
self showError:'** no source **'
]
]
].
code isNil ifTrue:[
canAccept := false.
] ifFalse:[
codeView contents:code.
(lineNrInMethod notNil and:[lineNrInMethod ~~ 0]) ifTrue:[
lineNrInMethod > codeView list size ifTrue:[
lineNrInMethod := codeView list size + 1
].
codeView selectLine:lineNrInMethod.
codeView makeSelectionVisible
].
].
canAccept ifTrue:[
codeView acceptAction:[:code | self codeAccept:code asString]
] ifFalse:[
codeView acceptAction:nil.
].
"fetch rec here - so we wont need context in doItAction"
rec := homeContext receiver.
]
].
receiverInspector inspect:rec.
codeView doItAction:[:theCode |
rec class compiler
evaluate:theCode
in:nil
receiver:rec
notifying:codeView
logged:true
ifFail:nil
].
selectedContext := homeContext
].
"clear out locals to prevent keeping around unneeded contexts (due to the
block held in codeView).
(not really needed, since stuff gets collected away sooner or later ..."
con := nil.
homeContext := nil.
m := contextView middleButtonMenu.
m notNil ifTrue:[
m enable:#doImplementors.
m enable:#doSenders.
m enable:#doInspectContext.
(method notNil and:[method isWrapped]) ifTrue:[
m enable:#doRemoveBreakpoint.
] ifFalse:[
m disable:#doRemoveBreakpoint.
]
]
!
codeAccept:someCode
"user wants some code to be recompiled - must unwind stack since everything above
and including selected method cannot be continued."
"
actually, this is not true, since the active methods will still be
executed correctly - however, the code shown in the debugger is no
longer in sync (showing the new code) with the executed code.
Therefore, we hide those contexts to avoid confusion ....
If you dont like this behavior, remove the 'inspecting ifFalse:' check below"
"walk up context chain and find highest context which is either the selected context,
or - if its a block-context - whose home is the selected context"
|con top sel implementorClass method newMethod|
codeView cursor:Cursor execute.
"
find the method-home context for this one
"
con := selectedContext.
top := con.
[con notNil] whileTrue:[
(con methodHome == selectedContext) ifTrue:[
top := con
].
con := con sender
].
"
use class&selector to find the method for the compilation
and compile.
"
sel := selectedContext selector.
"/ implementorClass := selectedContext searchClass whichClassImplements:sel.
implementorClass := selectedContext methodClass.
method := implementorClass compiledMethodAt:sel.
newMethod := implementorClass compiler compile:someCode
forClass:implementorClass
inCategory:(method category)
notifying:codeView.
inspecting ifFalse:[
"
if it worked, remove everything up to and including top
from context chain
"
(newMethod notNil and:[newMethod ~~ #Error]) ifTrue:[
self setContext:(top sender).
"
continue/step is no longer possible
"
canContinue := false.
self showSelection:1.
exitAction := #return
].
].
codeView cursor:Cursor normal
!
destroy
"closing the debugger implies an abort or continue"
contextView middleButtonMenu hide.
"
we manually release all private data, since the Debugger
is cached for reuse - thus the memory would not be collectable
otherwise.
"
receiverInspector release.
contextInspector release.
inspectedProcess := nil.
exitAction := nil.
contextArray := nil.
selectedContext := nil.
"/ catchBlock := nil.
grabber := nil.
self autoUpdateOff.
inspecting ifTrue:[
super destroy.
] ifFalse:[
exclusive ifTrue:[
CachedExclusive := nil.
] ifFalse:[
CachedDebugger := nil
]
].
inspecting ifFalse:[
canAbort ifTrue:[
self doAbort.
] ifFalse:[
self doContinue
]
].
!
doExit
"exit from menu: immediate exit from smalltalk"
Smalltalk exit
!
doRemoveBreakpoint
"remove breakpoint on the selected contexts method - if any"
|implementorClass method|
selectedContext isNil ifTrue:[
^ self showError:'** select a context first **'
].
"/ implementorClass := selectedContext searchClass
"/ whichClassImplements:selectedContext selector.
implementorClass := selectedContext methodClass.
implementorClass notNil ifTrue:[
method := implementorClass compiledMethodAt:selectedContext selector.
(method notNil and:[method isWrapped]) ifTrue:[
MessageTracer unwrapMethod:method
]
].
contextView middleButtonMenu disable:#doRemoveBreakpoint.
!
doRemoveAllBreakpoints
"remove all trace & breakpoints - if any"
MessageTracer unwrapAllMethods
!
doSenders
"open a browser on the senders"
selectedContext isNil ifTrue:[
^ self showError:'** select a context first **'
].
SystemBrowser browseAllCallsOn:selectedContext selector.
!
doImplementors
"open a browser on the implementors"
selectedContext isNil ifTrue:[
^ self showError:'** select a context first **'
].
SystemBrowser browseImplementorsOf:selectedContext selector.
!
doShowMore
"double number of contexts shown"
|oldSelection con|
contextArray notNil ifTrue:[
oldSelection := contextView selection.
nChainShown := nChainShown * 2.
con := contextArray at:1.
contextArray at:1 put:nil.
self setContext:con.
contextView selection:oldSelection.
]
!
doSend
"send from menu"
inspecting ifTrue:[^ self].
canContinue ifTrue:[
steppedContextAddress := nil.
haveControl := false.
exitAction := #step.
ProcessorScheduler isPureEventDriven ifFalse:[
"exit private event-loop"
catchBlock notNil ifTrue:[catchBlock value].
'DEBUGGER: oops, send failed' errorPrintNL.
"/ self warn:'send failed'.
sendButton turnOff.
"/ sendButton disable.
].
]
!
doStep:lineNr
"step from menu"
inspecting ifTrue:[^ self].
canContinue ifTrue:[
selectedContext notNil ifTrue:[
steppedContextAddress := ObjectMemory addressOf:selectedContext
] ifFalse:[
steppedContextAddress := ObjectMemory addressOf:(contextArray at:2)
].
bigStep := true.
skipLineNr := lineNr.
haveControl := false.
exitAction := #step.
ProcessorScheduler isPureEventDriven ifFalse:[
"exit private event-loop"
catchBlock notNil ifTrue:[catchBlock value].
'DEBUGGER: oops, step failed' errorPrintNL.
"/ self warn:'step failed'.
stepButton turnOff.
"/ stepButton disable.
].
]
!
doStep
"step from menu"
self doStep:nil
!
doSkip
"step from menu"
self doStep:codeView cursorLine.
!
doTraceStep
"tracestep - not implemented yet"
canContinue ifTrue:[
tracing := true.
self doStep
]
!
doAbort
"abort - send Object>>abortSignal, which is usually cought
at save places (for example: in the event loop) and returns back
from whatever the process is doing, but does not terminate it."
inspecting ifTrue:[
inspectedProcess isDead ifTrue:[
self showTerminated.
^ self
].
(Object abortSignal isHandledIn:inspectedProcess suspendedContext) ifFalse:[
self showError:'** the process does not handle the abort signal **'
] ifTrue:[
self interruptProcessWith:[Object abortSignal raise].
].
^ self
].
steppedContextAddress := nil.
haveControl := false.
exitAction := #abort.
ProcessorScheduler isPureEventDriven ifFalse:[
"exit private event-loop"
catchBlock notNil ifTrue:[
abortButton turnOff.
catchBlock value.
'DEBUGGER: oops, abort failed' errorPrintNL.
"/ self warn:'unwind failed'.
"/ abortButton disable.
]
].
^ self.
"obsolete ..."
"/ Processor activeProcess id == 0 ifTrue:[
"/ "dont allow termination of main-thread"
"/ exitAction := #abort
"/ ] ifFalse:[
"/ exitAction := #terminate
"/ ]
!
doTerminate
"terminate - the process has a chance for cleanup"
inspecting ifTrue:[
self processAction:[inspectedProcess terminate].
^ self
].
steppedContextAddress := nil.
haveControl := false.
exitAction := #terminate.
ProcessorScheduler isPureEventDriven ifFalse:[
"exit private event-loop"
catchBlock notNil ifTrue:[catchBlock value].
inspecting ifFalse:[
'DEBUGGER: oops, terminate failed' errorPrintNL.
self warn:'terminate failed'.
].
terminateButton turnOff.
"/ terminateButton disable.
].
!
doQuickTerminate
"quick terminate - the process will get no chance for cleanup actions"
inspecting ifTrue:[
self processAction:[inspectedProcess terminateNoSignal].
^ self
].
steppedContextAddress := nil.
haveControl := false.
exitAction := #quickTerminate.
ProcessorScheduler isPureEventDriven ifFalse:[
"exit private event-loop"
catchBlock notNil ifTrue:[catchBlock value].
inspecting ifFalse:[
'DEBUGGER: oops, terminate failed' errorPrintNL.
self warn:'terminate failed'.
].
terminateButton turnOff.
"/ terminateButton disable.
].
!
doReturn
"return - the selected context will do a ^nil"
inspecting ifTrue:[
selectedContext isNil ifTrue:[
^ self showError:'** select a context first **'
].
self interruptProcessWith:[selectedContext return].
^ self
].
steppedContextAddress := nil.
haveControl := false.
exitAction := #return.
ProcessorScheduler isPureEventDriven ifFalse:[
"exit private event-loop"
catchBlock notNil ifTrue:[catchBlock value].
'DEBUGGER: oops, return failed' errorPrintNL.
"/ self warn:'return failed'.
returnButton turnOff.
"/ returnButton disable.
].
!
doRestart
"restart - the selected context will be restarted"
inspecting ifTrue:[
selectedContext isNil ifTrue:[
^ self showError:'** select a context first **'
].
self interruptProcessWith:[selectedContext restart].
^ self
].
steppedContextAddress := nil.
haveControl := false.
exitAction := #restart.
ProcessorScheduler isPureEventDriven ifFalse:[
"exit private event-loop"
catchBlock notNil ifTrue:[catchBlock value].
'DEBUGGER: oops, restart failed' errorPrintNL.
"/ self warn:'restart failed'.
restartButton turnOff.
"/ restartButton disable
].
!
doTrace
"tracing - not really implemented ..."
|v b|
self warn:'this function is not yet implemented'.
false ifTrue:[
traceView isNil ifTrue:[
v := StandardSystemView on:Display.
v label:'Debugger-Trace'.
v icon:icon.
b := Button label:'untrace' in:v.
b origin:(0 @ 0) extent:(1.0 @ (b height)).
b action:[
StepInterruptPending := false.
tracing := false.
v unrealize.
traceView := nil
].
traceView := ScrollableView for:TextCollector in:v.
traceView origin:(0 @ (b height))
extent:[v width @ (v height - b height)]
].
v realize.
].
tracing := true.
!
doNoTrace
traceView notNil ifTrue:[
traceView topView destroy.
traceView := nil.
].
tracing := false
!
doStop
"stop the process (if its running, otherwise this is a no-op)"
inspecting ifTrue:[
self processAction:[inspectedProcess suspend].
^ self
].
!
doContinue
"continue from menu"
inspecting ifTrue:[
self processAction:[inspectedProcess resume].
^ self
].
canContinue ifTrue:[
steppedContextAddress := nil.
tracing := false.
haveControl := false.
exitAction := #continue.
ProcessorScheduler isPureEventDriven ifFalse:[
"exit private event-loop"
catchBlock notNil ifTrue:[catchBlock value].
'DEBUGGER: oops, continue failed' errorPrintNL.
"/ self warn:'continue failed'.
continueButton turnOff.
"/ continueButton disable
].
] ifFalse:[
inspecting ifFalse:[
'resuming top context' errorPrintNL.
self showSelection:1.
self doReturn
]
]
!
doInspectContext
"launch an inspector on the currently selected context"
contextView selection notNil ifTrue:[
(contextView selectionValue startsWith:'**') ifFalse:[
(contextArray at:(contextView selection)) inspect.
]
]
!
autoUpdateOff
"stop the update process"
updateProcess notNil ifTrue:[
monitorToggle lampColor:(Color yellow).
updateProcess terminate.
updateProcess := nil
]
!
autoUpdateOn
"fork a subprocess which updates the contextList in regular intervals"
updateProcess isNil ifTrue:[
updateProcess :=
[
[true] whileTrue:[
monitorToggle showLamp ifTrue:[
monitorToggle lampColor:(Color yellow).
] ifFalse:[
monitorToggle activeForegroundColor:Color black.
].
(Delay forSeconds:0.25) wait.
self updateContext.
monitorToggle showLamp ifTrue:[
monitorToggle lampColor:(Color red).
] ifFalse:[
monitorToggle activeForegroundColor:Color red.
].
(Delay forSeconds:0.25) wait.
self updateContext.
]
] forkAt:(Processor activePriority - 1)
]
! !