'From Squeak 2.5 of August 6, 1999 on 1 December 1999 at 3:19:15 pm'!
ObjectMemory subclass: #Interpreter
	instanceVariableNames: 'activeContext theHomeContext method receiver instructionPointer stackPointer localIP localSP localHomeContext messageSelector argumentCount newMethod currentBytecode successFlag primitiveIndex methodCache atCache lkupClass reclaimableContextCount nextPollTick nextWakeupTick lastTick interruptKeycode interruptPending semaphoresToSignal semaphoresToSignalCount savedWindowSize fullScreenFlag deferDisplayUpdates pendingFinalizationSignals compilerInitialized compilerHooks extraVMMemory deferRectL deferRectR deferRectT deferRectB deferLastUpdateTime deferPending deferForceUpdate deferTimeSpan '
	classVariableNames: 'ActiveProcessIndex AtCacheEntries AtCacheFixedFields AtCacheFmt AtCacheMask AtCacheOop AtCacheSize AtCacheTotalSize AtPutBase BlockArgumentCountIndex BytecodeTable CacheProbeMax CallerIndex CharacterValueIndex CompilerHooksSize DirBadPath DirEntryFound DirNoMoreEntries ExcessSignalsIndex FirstLinkIndex HeaderIndex HomeIndex InitialIPIndex InstanceSpecificationIndex InstructionPointerIndex LastLinkIndex LiteralStart MaxPrimitiveIndex MessageArgumentsIndex MessageDictionaryIndex MessageLookupClassIndex MessageSelectorIndex MethodArrayIndex MethodCacheClass MethodCacheEntries MethodCacheEntrySize MethodCacheMask MethodCacheMethod MethodCachePrim MethodCacheSelector MethodCacheSize MethodIndex MyListIndex NextLinkIndex PrimitiveTable PriorityIndex ProcessListsIndex ReceiverIndex SelectorStart SemaphoresToSignalSize SenderIndex StackPointerIndex StreamArrayIndex StreamIndexIndex StreamReadLimitIndex StreamWriteLimitIndex SuperclassIndex SuspendedContextIndex TempFrameStart ValueIndex XIndex YIndex '
	poolDictionaries: ''
	category: 'Squeak-Interpreter'!

!Interpreter methodsFor: 'initialization' stamp: 'JMM 12/1/1999 15:17'!
initializeInterpreter: bytesToShift
	"Initialize Interpreter state before starting execution of a new image."

	self initializeObjectMemory: bytesToShift.
	self initBBOpTable.
	self initCompilerHooks.

	activeContext	_ nilObj.
	theHomeContext	_ nilObj.
	method			_ nilObj.
	receiver		_ nilObj.
	messageSelector	_ nilObj.
	newMethod		_ nilObj.

	self flushMethodCache.
	self loadInitialContext.
	interruptCheckCounter _ 0.
	nextPollTick _ 0.
	nextWakeupTick _ 0.
	lastTick _ 0.
	interruptKeycode _ 2094.  "cmd-."
	interruptPending _ false.
	semaphoresToSignalCount _ 0.
	deferDisplayUpdates _ false.
	pendingFinalizationSignals _ 0.
	deferRectL _ 999999.
	deferRectR _ -999999.
	deferRectT _ 999999.
	deferRectB _ -999999.
	deferLastUpdateTime _ 0.
	deferPending _ false.
	deferForceUpdate _ false.
	deferTimeSpan _ 0.
! !

!Interpreter methodsFor: 'processes' stamp: 'JMM 12/1/1999 14:01'!
checkForInterrupts
	"Check for possible interrupts and handle one if necessary."

	| sema now |
	self inline: false.
	interruptCheckCounter _ 1000.  "reset the interrupt check counter"

	"Mask so same wrap as primitiveMillisecondClock"
	now _ self ioMSecs bitAnd: 16r1FFFFFFF. 

	now < lastTick ifTrue: [
		"millisecond clock wrapped"
		nextPollTick _ now + (nextPollTick - lastTick).
		nextWakeupTick ~= 0
			ifTrue: [nextWakeupTick _ now + (nextWakeupTick - lastTick)]].
	lastTick _ now.  "used to detect millisecond clock wrapping"

	signalLowSpace ifTrue: [
		signalLowSpace _ false.  "reset flag"
		sema _ (self splObj: TheLowSpaceSemaphore).
		sema = nilObj ifFalse: [self synchronousSignal: sema]].

	"If a deferred update is pending and the time exceeded then force an update"
	((deferPending = 1) and: [(self ioLowResMSecs - deferLastUpdateTime) > deferTimeSpan]) 
			ifTrue: [deferForceUpdate _ true.
					self fullDisplayUpdate].

	now >= nextPollTick ifTrue: [
		self ioProcessEvents.  "sets interruptPending if interrupt key pressed"
		nextPollTick _ now + 500].  "msecs to wait before next call to ioProcessEvents"

	interruptPending ifTrue: [
		interruptPending _ false.  "reset interrupt flag"
		sema _ (self splObj: TheInterruptSemaphore).
		sema = nilObj ifFalse: [self synchronousSignal: sema]].

	((nextWakeupTick ~= 0) and: [now >= nextWakeupTick]) ifTrue: [
		nextWakeupTick _ 0.  "reset timer interrupt"
		sema _ (self splObj: TheTimerSemaphore).
		sema = nilObj ifFalse: [self synchronousSignal: sema]].

	"signal any pending finalizations"
	pendingFinalizationSignals > 0 ifTrue:[
		sema _ self splObj: TheFinalizationSemaphore.
		(self fetchClassOf: sema) = (self splObj: ClassSemaphore) 
			ifTrue:[self synchronousSignal: sema].
		pendingFinalizationSignals _ 0.
	].

	"signal all semaphores in semaphoresToSignal" 
	semaphoresToSignalCount > 0 
		ifTrue: [self signalExternalSemaphores].
! !

!Interpreter methodsFor: 'I/O primitives' stamp: 'JMM 12/1/1999 14:03'!
deferShowDisplayBits: dispBitsIndex width: w height: h depth: d left: affectedRectL top: affectedRectT right: affectedRectR bottom: affectedRectB 
	"Track updated rectangle, and defer updates based on deferTimeSpan. This reduces the number
	of screen updates and more critically the number of network transmissions when using X-windows.
	If deferTimeSpan is zero then update screen right away"

	((affectedRectR = affectedRectL) | (affectedRectT = affectedRectB)) ifTrue: [^ 1].
	(deferTimeSpan = 0)
		ifTrue: 
			[self cCode: 'ioShowDisplay(dispBitsIndex, w, h, d, affectedRectL, affectedRectR, affectedRectT, affectedRectB)'.
			^ 1].
	deferForceUpdate ifFalse: 
		[deferRectL > affectedRectL ifTrue: [deferRectL _ affectedRectL].
		deferRectR < affectedRectR ifTrue: [deferRectR _ affectedRectR].
		deferRectT > affectedRectT ifTrue: [deferRectT _ affectedRectT].
		deferRectB < affectedRectB ifTrue: [deferRectB _ affectedRectB].
		deferPending ifFalse: [deferLastUpdateTime _ self ioLowResMSecs].
		((self ioLowResMSecs - deferLastUpdateTime) < deferTimeSpan)
			ifTrue: 
				[deferPending _ true.
				^ 1]].
	self cCode: 'ioShowDisplay(dispBitsIndex, w, h, d, deferRectL, deferRectR, deferRectT, deferRectB)'.
	deferLastUpdateTime _ self ioLowResMSecs.
	deferPending _ false.
	deferForceUpdate _ false.
	deferRectL _ 999999.
	deferRectR _ -999999.
	deferRectT _ 999999.
	deferRectB _ -999999! !

!Interpreter methodsFor: 'I/O primitives' stamp: 'JMM 11/30/1999 14:17'!
fullDisplayUpdate
	"Repaint the entire smalltalk screen, ignoring the affected rectangle. Used when the Smalltalk window is brought to the front or uncovered."

	| displayObj dispBits w h dispBitsIndex d |
	displayObj _ self splObj: TheDisplay.
	((self isPointers: displayObj) and: [(self lengthOf: displayObj) >= 4]) ifTrue: [
		dispBits _ self fetchPointer: 0 ofObject: displayObj.
		w _ self fetchInteger: 1 ofObject: displayObj.
		h _ self fetchInteger: 2 ofObject: displayObj.
		d _ self fetchInteger: 3 ofObject: displayObj.
		dispBitsIndex _ dispBits + BaseHeaderSize.  "index in memory byte array"
		self deferShowDisplayBits: dispBitsIndex width: w height: h depth: d left: 0 top: 0 right: w bottom: h.
		self ioForceDisplayUpdate].
! !

!Interpreter methodsFor: 'I/O primitives' stamp: 'JMM 11/30/1999 14:18'!
primitiveShowDisplayRect
	"Force the given rectangular section of the Display to be copied to the screen."

	| bottom top right left displayObj dispBits w h d dispBitsPtr |
	bottom	_ self stackIntegerValue: 0.
	top		_ self stackIntegerValue: 1.
	right	_ self stackIntegerValue: 2.
	left		_ self stackIntegerValue: 3.
	displayObj _ self splObj: TheDisplay.
	self success: ((self isPointers: displayObj) and: [(self lengthOf: displayObj) >= 4]).
	successFlag ifTrue: [
		dispBits _ self fetchPointer: 0 ofObject: displayObj.
		w _ self fetchInteger: 1 ofObject: displayObj.
		h _ self fetchInteger: 2 ofObject: displayObj.
		d _ self fetchInteger: 3 ofObject: displayObj].
	left < 0 ifTrue: [left _ 0].
	right > w ifTrue: [right _ w].
	top < 0 ifTrue: [top _ 0].
	bottom > h ifTrue: [bottom _ h].
	self success: ((left <= right) and: [top <= bottom]).
	successFlag ifTrue: [
		dispBitsPtr _ dispBits + BaseHeaderSize.
		self deferShowDisplayBits: dispBitsPtr width: w height: h depth: d left: left top: top right: right bottom: bottom.
		self ioForceDisplayUpdate].
	successFlag ifTrue: [self pop: 4].  "pop left, right, top, bottom; leave rcvr on stack"
! !

!Interpreter methodsFor: 'I/O primitives' stamp: 'JMM 11/30/1999 11:36'!
showDisplayBits
	"Repaint the portion of the Smalltalk screen bounded by the affected rectangle. Used to synchronize the screen after a Bitblt to the Smalltalk Display object."

	| displayObj dispBits w h affectedRectL affectedRectR affectedRectT affectedRectB dispBitsIndex d |
	deferDisplayUpdates ifTrue: [^ nil].
	displayObj _ self splObj: TheDisplay.
	self targetForm = displayObj ifFalse: [^ nil].
	self success: ((self isPointers: displayObj) and: [(self lengthOf: displayObj) >= 4]).
	successFlag ifTrue: [
		dispBits _ self fetchPointer: 0 ofObject: displayObj.
		w _ self fetchInteger: 1 ofObject: displayObj.
		h _ self fetchInteger: 2 ofObject: displayObj.
		d _ self fetchInteger: 3 ofObject: displayObj.
	].
	successFlag ifTrue: [
		affectedRectL _ self affectedLeft.
		affectedRectR _ self affectedRight.
		affectedRectT _ self affectedTop.
		affectedRectB _ self affectedBottom.
		dispBitsIndex _ dispBits + BaseHeaderSize.  "index in memory byte array"
		self deferShowDisplayBits: dispBitsIndex width: w height: h depth: d left: affectedRectL top: affectedRectT right: affectedRectR bottom: affectedRectB.
	].! !

!Interpreter methodsFor: 'I/O primitives' stamp: 'JMM 11/30/1999 14:19'!
showDisplayBits: aForm Left: affectedRectL Top: affectedRectT Right: affectedRectR Bottom: affectedRectB
	"Repaint the portion of the Smalltalk screen bounded by the affected rectangle. Used to synchronize the screen after a Bitblt to the Smalltalk Display object."

	| displayObj dispBits w h dispBitsIndex d |
	deferDisplayUpdates ifTrue: [^ nil].
	displayObj _ self splObj: TheDisplay.
	aForm = displayObj ifFalse: [^ nil].
	self success: ((self isPointers: displayObj) and: [(self lengthOf: displayObj) >= 4]).
	successFlag ifTrue: [
		dispBits _ self fetchPointer: 0 ofObject: displayObj.
		w _ self fetchInteger: 1 ofObject: displayObj.
		h _ self fetchInteger: 2 ofObject: displayObj.
		d _ self fetchInteger: 3 ofObject: displayObj.
	].
	successFlag ifTrue: [
		dispBitsIndex _ dispBits + BaseHeaderSize.  "index in memory byte array"
		self deferShowDisplayBits: dispBitsIndex width: w height: h depth: d left: affectedRectL top: affectedRectT right: affectedRectR bottom: affectedRectB.
		self ioForceDisplayUpdate.
	].! !

!Interpreter methodsFor: 'other primitives' stamp: 'JMM 11/30/1999 18:43'!
primitiveVMParameter
	"Behaviour depends on argument count:
		0 args:	return an Array of VM parameter values;
		1 arg:	return the indicated VM parameter;
		2 args:	set the VM indicated parameter.
	VM parameters are numbered as follows:
		1	end of old-space (0-based, read-only)
		2	end of young-space (read-only)
		3	end of memory (read-only)
		4	allocationCount (read-only)
		5	allocations between GCs (read-write)
		6	survivor count tenuring threshold (read-write)
		7	full GCs since startup (read-only)
		8	total milliseconds in full GCs since startup (read-only)
		9	incremental GCs since startup (read-only)
		10	total milliseconds in incremental GCs since startup (read-only)
		11	tenures of surving objects since startup (read-only)
		12-20 specific to the translating VM
		12   defer screen updates (milliseconds)
		21	root table size (read-only)
		22	root table overflows since startup (read-only)
		23	bytes of extra memory to reserve for VM buffers, plugins, etc.
	Note: Thanks to Ian Piumarta for this primitive."

	| mem paramsArraySize result arg index |
	mem _ self cCoerce: memory to: 'int'.
	argumentCount = 0 ifTrue: [
		paramsArraySize _ 23.
		result _ self instantiateClass: (self splObj: ClassArray) indexableSize: paramsArraySize.
		0 to: paramsArraySize - 1 do:
			[:i | self storeWord: i ofObject: result withValue: (self integerObjectOf: 0)].
		self storeWord: 0	ofObject: result withValue: (self integerObjectOf: youngStart - mem).
		self storeWord: 1		ofObject: result withValue: (self integerObjectOf: freeBlock - mem).
		self storeWord: 2	ofObject: result withValue: (self integerObjectOf: endOfMemory - mem).
		self storeWord: 3	ofObject: result withValue: (self integerObjectOf: allocationCount).
		self storeWord: 4	ofObject: result withValue: (self integerObjectOf: allocationsBetweenGCs).
		self storeWord: 5	ofObject: result withValue: (self integerObjectOf: tenuringThreshold).
		self storeWord: 6	ofObject: result withValue: (self integerObjectOf: statFullGCs).
		self storeWord: 7	ofObject: result withValue: (self integerObjectOf: statFullGCMSecs).
		self storeWord: 8	ofObject: result withValue: (self integerObjectOf: statIncrGCs).
		self storeWord: 9	ofObject: result withValue: (self integerObjectOf: statIncrGCMSecs).
		self storeWord: 10	ofObject: result withValue: (self integerObjectOf: statTenures).
		self storeWord: 12	ofObject: result withValue: (self integerObjectOf: deferTimeSpan).
		self storeWord: 20	ofObject: result withValue: (self integerObjectOf: rootTableCount).
		self storeWord: 21	ofObject: result withValue: (self integerObjectOf: statRootTableOverflows).
		self storeWord: 22	ofObject: result withValue: (self integerObjectOf: extraVMMemory).
		self pop: 1 thenPush: result.
		^nil].

	arg _ self stackTop.
	(self isIntegerObject: arg) ifFalse: [^self primitiveFail].
	arg _ self integerValueOf: arg.
	argumentCount = 1 ifTrue: [	 "read VM parameter"
		(arg < 1 or: [arg > 23]) ifTrue: [^self primitiveFail].
		arg = 1		ifTrue: [result _ youngStart - mem].
		arg = 2		ifTrue: [result _ freeBlock - mem].
		arg = 3		ifTrue: [result _ endOfMemory - mem].
		arg = 4		ifTrue: [result _ allocationCount].
		arg = 5		ifTrue: [result _ allocationsBetweenGCs].
		arg = 6		ifTrue: [result _ tenuringThreshold].
		arg = 7		ifTrue: [result _ statFullGCs].
		arg = 8		ifTrue: [result _ statFullGCMSecs].
		arg = 9		ifTrue: [result _ statIncrGCs].
		arg = 10		ifTrue: [result _ statIncrGCMSecs].
		arg = 11		ifTrue: [result _ statTenures].
		arg = 12		ifTrue: [result _ deferTimeSpan].
		((arg >= 13) and: [arg <= 20]) ifTrue: [result _ 0].
		arg = 21		ifTrue: [result _ rootTableCount].
		arg = 22		ifTrue: [result _ statRootTableOverflows].
		arg = 23		ifTrue: [result _ extraVMMemory].
		self pop: 2 thenPush: (self integerObjectOf: result).
		^nil].

	"write a VM parameter"
	argumentCount = 2 ifFalse: [^self primitiveFail].
	index _ self stackValue: 1.
	(self isIntegerObject: index) ifFalse: [^self primitiveFail].
	index _ self integerValueOf: index.
	index <= 0 ifTrue: [^self primitiveFail].
	successFlag _ false.
	index = 5 ifTrue: [
		result _ allocationsBetweenGCs.
		allocationsBetweenGCs _ arg.
		successFlag _ true].
	index = 6 ifTrue: [
		result _ tenuringThreshold.
		tenuringThreshold _ arg.
		successFlag _ true].
	index = 12 ifTrue: [
		result _ deferTimeSpan.
		deferTimeSpan _ arg.
		successFlag _ true].
	index = 23 ifTrue: [
		result _ extraVMMemory.
		extraVMMemory _ arg.
		successFlag _ true].
	successFlag ifTrue: [
		self pop: 3 thenPush: (self integerObjectOf: result).  "return old value"
		^ nil].

	self primitiveFail.  "attempting to write a read-only parameter"
! !


!SystemDictionary methodsFor: 'miscellaneous' stamp: 'JMM 12/1/1999 14:04'!
delayScreenUpdatesBy: timeDelayInMilliseconds
	"Request that the VM delay screen updates for X milliseconds, a 0 value means no delay.
	Use this to improve X-windows performance, 16 is 1/60 or so of second, use 100 for remote screens?"

	^ Smalltalk vmParameterAt: 12 put: timeDelayInMilliseconds
! !