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