#printAllStacks
Bill Schwab
BSchwab at anest.ufl.edu
Sat Apr 2 22:05:12 UTC 2005
Hello all,
Here are the promised changes - I think. I did this in 2002 on Squeak
3.2, so file this stuff into a current image with great care. At the
moment, I do not have the time to build a new VM to test this[*], nor do
I have ready access to the altered sources that I used for same. IIRC,
I simply arranged for printing all stacks vs. only the active process'
stack.
I saw mention of some problems with capturing the idle process
(something about it calling a primitve vs. waiting on a semaphore), and
do not know whether the code below addresses that. I am making this
available now vs. waiting until I have time to clean up the loose ends.
Bill
[*] things should improve this summer, but feel free (encouraged even)
to beat me to it.
'From Squeak 3.2 of 11 July 2002 [latest update: #4917] on 2 April 2005
at 3:59:10 pm'!
!Object methodsFor: 'as yet unclassified' stamp: 'wks 11/23/2002 22:22'!
initialize
"Dolphin compatibility"
#wks.
! !
!Interpreter methodsFor: 'debug support' stamp: 'wks 4/2/2005 15:48'!
printAllStacks
"Print all the stacks of all running processes, including those
that are currently suspended."
| oop proc ctx |
self print:'================= ALL STACKS ===================';
cr.
proc _ self fetchPointer: ActiveProcessIndex ofObject: self
schedulerPointer.
self printNameOfClass: (self fetchClassOf: proc) count: 5.
self cr.
self print:'Active process:'; cr.
self printCallStackOf: activeContext. "first the active context"
self print:'Other processes:'; cr.
oop _ self firstObject.
[oop < endOfMemory] whileTrue:[
(self fetchClassOf: oop) == self classSemaphore ifTrue:[
#wks. "wks - do this inside the successful test
below
self cr."
proc _ self fetchPointer: FirstLinkIndex
ofObject: oop.
"wks - print the cr only if we find a link"
proc == self nilObject ifFalse:[
self cr.
].
[proc == self nilObject] whileFalse:[
self printNameOfClass: (self
fetchClassOf: proc) count: 5.
self cr.
ctx _ self fetchPointer:
SuspendedContextIndex ofObject: proc.
ctx == self nilObject ifFalse:[self
printCallStackOf: ctx].
proc _ self fetchPointer: NextLinkIndex
ofObject: proc].
].
oop _ self objectAfter: oop.
].! !
!Interpreter methodsFor: 'debug support' stamp: 'wks 4/2/2005 15:50'!
printCallStackOf: aContext
| ctxt home methClass methodSel |
self inline: false.
#wks. "4-05 cleanup for redistribution; any changes here???"
"self print:'STACK START'; cr."
ctxt _ aContext.
[ctxt = nilObj] whileFalse: [
(self fetchClassOf: ctxt) = (self splObj:
ClassBlockContext)
ifTrue: [ home _ self fetchPointer: HomeIndex
ofObject: ctxt ]
ifFalse: [ home _ ctxt ].
methClass _
self findClassOfMethod: (self fetchPointer:
MethodIndex ofObject: home)
forReceiver: (self
fetchPointer: ReceiverIndex ofObject: home).
methodSel _
self findSelectorOfMethod: (self fetchPointer:
MethodIndex ofObject: home)
forReceiver: (self
fetchPointer: ReceiverIndex ofObject: home).
self printNum: ctxt.
self print: ' '.
ctxt = home ifFalse: [ self print: '[] in ' ].
self printNameOfClass: methClass count: 5.
self print: '>>'.
self printStringOf: methodSel.
self cr.
ctxt _ (self fetchPointer: SenderIndex ofObject: ctxt).
].
"self print:'Stack End'; cr."
! !
!Process methodsFor: 'accessing' stamp: 'wks 10/5/2002 16:42'!
isActive
#wks.
^Processor activeProcess == self
! !
!Process methodsFor: 'debugging' stamp: 'wks 4/2/2005 15:53'!
stackOfSize:depthLimit
"Answer a call stack for the receiver, active or not, and empty
if unavailable."
#wks. "4-05 - not sure why I marked this, so beware."
^self == Processor activeProcess
ifTrue:[
thisContext stackOfSize:depthLimit.
]
ifFalse:[
suspendedContext isNil
ifTrue:[ Array new. ]
ifFalse:[ suspendedContext
stackOfSize:depthLimit. ].
].
! !
!SystemDictionary methodsFor: 'memory space' stamp: 'wks 11/9/2002
20:43'!
lowSpaceWatcher
"Wait until the low space semaphore is signalled, then take
appropriate actions."
| free |
self garbageCollectMost <= self lowSpaceThreshold ifTrue: [
self garbageCollect <= self lowSpaceThreshold ifTrue: [
"free space must be above threshold before
starting low space watcher"
^ self beep]].
LowSpaceSemaphore _ Semaphore new.
self primLowSpaceSemaphore: LowSpaceSemaphore.
self primSignalAtBytesLeft: self lowSpaceThreshold. "enable low
space interrupts"
LowSpaceSemaphore wait. "wait for a low space condition..."
self primSignalAtBytesLeft: 0. "disable low space interrupts"
self primLowSpaceSemaphore: nil.
LowSpaceProcess _ nil.
"Note: user now unprotected until the low space watcher is
re-installed"
self memoryHogs isEmpty ifFalse: [
free := self bytesLeft.
self memoryHogs do: [ :hog | hog freeSomeSpace ].
self bytesLeft > free ifTrue: [ ^ self
installLowSpaceWatcher ]].
#wks. "If space is low enough to leave a Morphic delay
unsignalled, the debugger
probably won't open, and we'd never see it - right???"
Smalltalk logError:'FREE SPACE LOW' inContext:thisContext
to:'LowSpaceWarning.txt'.
Smalltalk isMorphic
ifTrue: [CurrentProjectRefactoring
currentInterruptName: 'Space is low']
ifFalse: [ScheduledControllers interruptName:
'Space is low']! !
!SystemDictionary methodsFor: 'miscellaneous' stamp: 'wks 11/9/2002
20:20'!
logError: errMsg inContext: aContext to: aFilename
"Log the error message and a stack trace to the given file."
| ff |
#wks. "Prevent 'overwrite' of old errors.
FileDirectory default deleteFileNamed: aFilename ifAbsent: []."
(ff _ FileStream fileNamed: aFilename) ifNil: [^ self "avoid
recursive errors"].
#wks.
ff
setToEnd;
cr;
nextPutAll:'============================================'; cr.
ff nextPutAll: errMsg; cr.
aContext errorReportOn: ff.
ff close.! !
Wilhelm K. Schwab, Ph.D.
University of Florida
Department of Anesthesiology
PO Box 100254
Gainesville, FL 32610-0254
Email: bills at anest4.anest.ufl.edu
Tel: (352) 846-1285
FAX: (352) 392-7029
More information about the Squeak-dev
mailing list
|