"
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 steppedContextAddress canAbort
abortButton terminateButton continueButton
stepButton sendButton resumeButton restartButton
exclusive'
classVariableNames:'CachedDebugger'
poolDictionaries:''
category:'Interface-Debugger'
!
DebugView comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
this class implements a graphical debugger interface.
The debugger usually sits on top of the faulting process,
stopping it from further event processing.
The 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.
$Header: /cvs/stx/stx/libtool/DebugView.st,v 1.9 1994-01-13 00:14:55 claus Exp $
written spring/summer 89 by claus
'!
!DebugView class methodsFor:'instance creation'!
new
"return a DebugView - return the standard debugger if it already
exists"
|debugger|
"need a blocking debugger if no processes or
or if its a timing/interrupt process (because otherwise we would not get any
events here ..."
ProcessorScheduler isPureEventDriven ifTrue:[
CachedDebugger isNil ifTrue:[
CachedDebugger := self newExclusive
].
^ CachedDebugger
].
((Processor activeProcess priority > Processor userSchedulingPriority)
or:[Processor activeProcess nameOrId endsWith:'dispatcher']) ifTrue:[
"determining this by its name is certainly a kludge ..."
^ self newExclusive
].
(CachedDebugger isNil or:[CachedDebugger busy]) ifTrue:[
debugger := super new.
debugger label:'Debugger'.
debugger icon:(Form fromFile:'Debugger.xbm' resolution:100).
] ifFalse:[
debugger := CachedDebugger
].
CachedDebugger isNil ifTrue:[
CachedDebugger := debugger
].
^ 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
"DebugView newDebugger"
!
enterWithMessage:aString
"the standard way of entering the debugger - sent from Objects
error- and halt messages"
|aDebugger name|
thisContext isRecursive ifTrue:[
^ MiniDebugger enterWithMessage:'recursive error'.
].
StepInterruptPending := nil.
aDebugger := self new.
name := Processor activeProcess nameOrId.
aDebugger label:aString , ' (process: ' , name , ')'.
aDebugger enter.
^ nil
"nil halt"
!
enter
"another way of entering the debugger"
|aDebugger name|
StepInterruptPending := nil.
aDebugger := self new.
name := Processor activeProcess nameOrId.
aDebugger label:'Debugger (process: ' , name , ')'.
aDebugger enter.
^ nil
"Debugger enter"
!
openOn:aProcess
"enter the debugger on aProcess"
|aDebugger name|
aDebugger := super new.
aDebugger icon:(Form fromFile:'Debugger.xbm' resolution:100).
name := aProcess nameOrId.
aDebugger label:'inspecting Debugger (process: ' , name , ')'.
aDebugger realize.
aDebugger iconLabel:'Debugger'.
aDebugger openOn:aProcess.
^ nil
! !
!DebugView methodsFor:'initialization'!
initialize
|v panel hpanel bpanel|
super initialize.
font := font on:device.
busy := false.
exclusive := false.
exitAction := nil.
bigStep := 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.
abortButton := Button
label:(resources at:'abort')
action:[abortButton turnOffWithoutRedraw. self doAbort]
in:bpanel.
resumeButton := Button
label:(resources at:'resume')
action:[resumeButton turnOff. self doResume]
in:bpanel.
restartButton := Button
label:(resources at:'restart')
action:[restartButton turnOff. self doRestart]
in:bpanel.
continueButton := Button
label:(resources at:'continue')
action:[continueButton turnOffWithoutRedraw. self doContinue]
in:bpanel.
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|
labels := resources array:#('continue'
'terminate'
'abort'
'-'
'step'
'trace step'
'send'
"
'trace'
'untrace'
"
'-'
'resume'
'restart'
'-'
"
'breakpoints'
'-'
"
'exit smalltalk'
).
contextView
middleButtonMenu:(PopUpMenu
labels:labels
selectors:#(doContinue
doTerminate
doAbort
nil
doStep
doTraceStep
doSend
"
doTrace
doNoTrace
"
nil
doResume
doRestart
nil
"
doBreakpoints
nil
"
doExit)
receiver:self
for:contextView)
!
addToCurrentProject
"ignored here"
^ self
!
createOnTop
^ false "true"
!
realize
super realize.
exclusive ifTrue:[
windowGroup := nil
].
! !
!DebugView methodsFor:'error handling'!
catch:aSymbol with:someArgument for:anObject
"this one is sent when an error occurs while in the debugger -
we dont want another debugger to come up - do we ?"
anObject class name print.
' ' print.
aSymbol print. '(' print. someArgument print.
') within debugger cought' printNewline.
(aSymbol == #halt:) ifFalse:[
catchBlock value
].
^ nil
! !
!DebugView methodsFor:'interrupt handling'!
stepInterrupt
|where here s|
"is this for a send or a step ?"
bigStep ifTrue:[
where := thisContext.
where := where sender.
where := where sender.
here := where.
(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) == steppedContextAddress ifTrue:[
tracing ifTrue:[
here printString printNewline
].
where := nil. here := nil.
"yes - continue"
"scedule 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:[
s := 'after step'
].
bigStep := false.
tracing := false.
] ifFalse:[
steppedContextAddress := nil.
s := 'after send'
].
name := Processor activeProcess name.
name isNil ifTrue:[
name := Processor activeProcess id printString.
].
self label:(s , ' (process: ' , name , ')').
"release refs to context"
where := nil. here := nil.
self enter
! !
!DebugView methodsFor:'basic'!
busy
^ busy
!
exclusive:aBoolean
exclusive := aBoolean
!
enter
"enter the debugger - get and display the context, then start an
exclusive event loop on top of eveything else"
|where con selection|
busy := true.
bigStep := false.
"if debugger is entered while a box has grabbed the
pointer, we must ungrab - otherwise X wont talk to
us here"
ActiveGrab notNil ifTrue:[
grabber := ActiveGrab.
ActiveGrab device ungrabPointer.
ActiveGrab device synchronizeOutput.
ActiveGrab := nil
] ifFalse:[
grabber := nil
].
drawableId notNil ifTrue:[
"not the first time - realize at old position"
self rerealize
] ifFalse:[
exclusive ifFalse:[
windowGroup isNil ifTrue:[
windowGroup := WindowGroup new.
windowGroup addTopView:self.
].
].
self realize.
self iconLabel:'Debugger'.
].
self raise.
Display synchronizeOutput.
where := thisContext.
where := where sender.
where notNil ifTrue:[
(where receiver == DebugView) ifTrue:[
where := where sender
]
"where is now interrupted methods context"
].
self setContext:where.
"select context, where halt was ..."
( #(halt error raise) includes:where sender selector) ifTrue:[
selection := 3
] ifFalse:[
( #(halt: error:) includes:where selector) ifTrue:[
selection := 2
]
].
where := nil.
"if we came here by a big-step, show the method where we are"
steppedContextAddress notNil ifTrue:[
selection := 3
].
selection notNil ifTrue:[
self showSelection:selection.
contextView selection:selection
].
canAbort := false.
1 to:contextArray size do:[:index |
(#(doIt printIt inspectIt)
includes:(contextArray at:index) selector) ifTrue:[
canAbort := true
]
].
canAbort ifTrue:[
abortButton enable.
contextView middleButtonMenu enable:#doAbort.
] ifFalse:[
abortButton disable.
contextView middleButtonMenu disable:#doAbort.
].
exclusive ifTrue:[
terminateButton disable.
contextView middleButtonMenu disable:#doTerminate.
] ifFalse:[
terminateButton enable.
contextView middleButtonMenu enable:#doTerminate.
].
canContinue := true.
self controlLoop.
"kludge: look for a doIt, printIt or inspectIt frame for abort"
(canAbort and:[exitAction == #abort]) ifTrue:[
selectedContext := nil.
1 to:contextArray size do:[:index |
(#(doIt printIt inspectIt)
includes:(contextArray at:index) selector) ifTrue:[
selectedContext := contextArray at:index
]
].
exitAction := #resume
].
contextArray := nil.
(exitAction == #step) ifFalse:[
self unrealize.
device synchronizeOutput.
(exitAction == #resume) ifTrue:[
selectedContext notNil ifTrue:[
con := selectedContext.
selectedContext := nil.
InInterrupt := nil.
busy := false.
con unwind.
'cannot resume selected context' printNewline
]
] ifFalse:[
(exitAction == #restart) ifTrue:[
selectedContext notNil ifTrue:[
con := selectedContext.
selectedContext := nil.
InInterrupt := nil.
busy := false.
con restart.
'cannot restart selected context' printNewline
]
] ifFalse:[
(exitAction == #terminate) ifTrue:[
selectedContext := nil.
InInterrupt := nil.
busy := false.
Processor activeProcess terminate.
'cannot terminate process' printNewline
]
]
]
].
selectedContext := nil.
grabber notNil ifTrue:[
grabber device grabPointerIn:(grabber id).
ActiveGrab := grabber
].
(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
]
!
openOn:aProcess
"enter the debugger on a process -
in this case, we are just inspecting the context chain of the process,
not offering continue/abort/step and send functions.
Also, we do not run on top of the debugger process, but as a separate
one."
| con selection|
busy := true.
bigStep := false.
"can only look into process - context chain is not active"
abortButton disable.
sendButton disable.
stepButton disable.
continueButton disable.
resumeButton disable.
restartButton disable.
self initializeMiddleButtonMenu.
contextView middleButtonMenu disable:#doAbort.
contextView middleButtonMenu disable:#doSend.
contextView middleButtonMenu disable:#doStep.
contextView middleButtonMenu disable:#doContinue.
contextView middleButtonMenu disable:#doResume.
contextView middleButtonMenu disable:#doRestart.
contextView middleButtonMenu disable:#doTraceStep.
aProcess suspendedContext isNil ifTrue:[
terminateButton disable.
contextView middleButtonMenu disable:#doTerminate.
].
self setContext:aProcess suspendedContext.
catchBlock := [
contextArray := nil.
selectedContext := nil.
(exitAction == #terminate) ifTrue:[
aProcess terminate.
].
super destroy
].
!
controlLoop
"this is a kludge:
start a dispatchloop which exits when
either continue, resume or step is pressed
"
"
Smalltalk at:#ErrorHandler put:self.
"
haveControl := true.
[haveControl] whileTrue:[
self controlLoopCatchingErrors
].
catchBlock := nil.
"
Smalltalk at:#ErrorHandler put:nil.
"
codeView contents:nil.
codeView acceptAction:nil.
contextView contents:nil.
receiverInspector noChoice.
contextInspector noChoice
!
controlLoopCatchingErrors
"setup a catch-block"
catchBlock := [^ 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, resume 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 |
'error within debugger ignored' printNewline.
ex return.
] do:[
windowGroup eventLoop
]
]
!
setContext:aContext
|con text
index "{ Class: SmallInteger }" |
aContext isNil ifTrue:[
text := Array with:'** no context **'.
contextArray := nil
] ifFalse:[
con := aContext.
index := 0.
[con notNil] whileTrue:[
index := index + 1.
con := con sender
].
text := Array new:index.
contextArray := Array new:index.
con := aContext.
index := 1.
[con notNil] whileTrue:[
contextArray at:index put:con.
text at:index put:(con printString).
index := index + 1.
con := con sender
]
].
contextView list:text.
receiverInspector noChoice.
contextInspector noChoice
! !
!DebugView methodsFor:'user interaction'!
showSelection:lineNr
"user clicked on a header line - show selected code in textView"
|con homeContext sel method code
implementorClass lineNrInMethod rec|
contextArray notNil ifTrue:[
con := contextArray at:lineNr.
lineNrInMethod := con lineNumber.
con isBlockContext ifTrue:[
homeContext := con methodHome
] ifFalse:[
homeContext := con
].
homeContext notNil ifTrue:[
sel := homeContext selector.
sel notNil ifTrue:[
implementorClass := homeContext searchClass
whichClassImplements:sel.
implementorClass isNil ifTrue:[
codeView contents:'** no method - no source **'
] ifFalse:[
method := implementorClass compiledMethodAt:sel.
code := method source.
code isNil ifTrue:[
codeView contents:'** no source **'
]
].
code isNil ifTrue:[
codeView acceptAction:nil.
contextInspector noChoice
] 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
].
codeView acceptAction:[:code | self codeAccept:code]
].
contextInspector inspect:con.
"fetch rec here - so we wont need con in doItAction"
rec := homeContext receiver.
receiverInspector inspect:rec.
codeView doItAction:[:theCode |
rec class compiler evaluate:theCode
receiver:rec
notifying:codeView
]
].
].
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
!
codeAccept:someCode
"user wants some code to be recompiled - must unwind stack since everything above
and including selected method cannot be continued"
"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.
con := selectedContext.
top := con.
[con notNil] whileTrue:[
(con methodHome == selectedContext) ifTrue:[
top := con
].
con := con sender
].
"now, remove everything up to and including top from context chain"
"
self setContext:(top sender).
"
sel := selectedContext selector.
implementorClass := selectedContext searchClass whichClassImplements:sel.
method := implementorClass compiledMethodAt:sel.
newMethod := implementorClass compiler compile:someCode
forClass:implementorClass
inCategory:(method category)
notifying:codeView.
"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 := #resume
].
codeView cursor:Cursor normal
!
destroy
"closing the debugger implies an abort"
contextView middleButtonMenu hide.
receiverInspector noChoice.
contextInspector noChoice.
self doAbort
!
doExit
"exit from menu: immediate exit from smalltalk"
Smalltalk exit
!
doBreakpoints
^ self
!
doSend
"send from menu"
canContinue ifTrue:[
steppedContextAddress := nil.
haveControl := false.
exitAction := #step.
ProcessorScheduler isPureEventDriven ifFalse:[
"exit private event-loop"
catchBlock value
].
]
!
doStep
"step from menu"
canContinue ifTrue:[
selectedContext notNil ifTrue:[
bigStep := true.
steppedContextAddress := ObjectMemory addressOf:selectedContext
] ifFalse:[
bigStep := true.
steppedContextAddress := ObjectMemory addressOf:(contextArray at:2)
].
haveControl := false.
exitAction := #step.
ProcessorScheduler isPureEventDriven ifFalse:[
"exit private event-loop"
catchBlock value
].
]
!
doTraceStep
"tracestep from menu"
canContinue ifTrue:[
tracing := true.
self doStep
]
!
doAbort
"abort from menu"
steppedContextAddress := nil.
haveControl := false.
exitAction := #abort.
ProcessorScheduler isPureEventDriven ifFalse:[
"exit private event-loop"
catchBlock notNil ifTrue:[
catchBlock value
]
].
^ self.
"obsolete ..."
Processor activeProcess id == 0 ifTrue:[
"dont allow termination of main-thread"
exitAction := #abort
] ifFalse:[
exitAction := #terminate
]
!
doTerminate
"terminate from menu"
steppedContextAddress := nil.
haveControl := false.
exitAction := #terminate.
ProcessorScheduler isPureEventDriven ifFalse:[
"exit private event-loop"
catchBlock value
].
!
doResume
"resume from menu"
steppedContextAddress := nil.
haveControl := false.
exitAction := #resume.
ProcessorScheduler isPureEventDriven ifFalse:[
"exit private event-loop"
catchBlock value
].
!
doRestart
"restart from menu"
steppedContextAddress := nil.
haveControl := false.
exitAction := #restart.
ProcessorScheduler isPureEventDriven ifFalse:[
"exit private event-loop"
catchBlock value
].
!
doTrace
|v b|
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.
self doStep
!
doNoTrace
traceView notNil ifTrue:[
traceView topView destroy.
traceView := nil.
tracing := false
]
!
doContinue
"continue from menu"
canContinue ifTrue:[
steppedContextAddress := nil.
tracing := false.
haveControl := false.
exitAction := #continue.
ProcessorScheduler isPureEventDriven ifFalse:[
"exit private event-loop"
catchBlock value
].
] ifFalse:[
'resuming top context' printNewline.
self showSelection:1.
self doResume
]
! !