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@anest4.anest.ufl.edu Tel: (352) 846-1285 FAX: (352) 392-7029
squeak-dev@lists.squeakfoundation.org