[Vm-dev] VM Maker: VMMaker.oscog-eem.258.mcz

commits at source.squeak.org commits at source.squeak.org
Fri Jan 18 19:03:35 UTC 2013


Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.258.mcz

==================== Summary ====================

Name: VMMaker.oscog-eem.258
Author: eem
Time: 18 January 2013, 11:01:23.072 am
UUID: da1433f1-de50-475f-be33-f462b300a2ea
Ancestors: VMMaker.oscog-eem.257

Fix becomeForward: when the rootTbale overflows.  There were two
bugs here.  One is that initializeMemoryFirstFree: used to clear the
needGCFlag so if the rootTable overflowed noteAsRoot:headerLoc:'s setting of the needGCFlag would be undone after the sweep.
The other is that rooitTbale overflow was indicated by
rootTableCount >= RootTableSize which could be undone by
becomeForward: freeing roots which need to be removed from
the rootTable.  At some point in becomeForward the rootTable would
fill but at a later point a root would be freed, causing the table to
become not full.

The fix is two fold.  1. Add an explicit rootTableOverflowed flag
instead of relying on rootTableCount >= RootTableSize.
2. move the clearing of the needGCFlag to the GC routines.
Remove unnecessary senders of needGCFlag: false, and remove
the accessor.

As a side effect rewrite primitiveRootTable in terms of a new
ObjectMemory>>rootTableObject.  Remove the rootTable: accessor.

Implement checkAllAccessibleObjectsOkay &
checkOkayInterpreterObjects: (used to debug the above).

Fix NewObjectMemory initialization to set freeStart at the same
time as setting endOfMemory.  This allows load-time scans and
assert code to use freeStart instead of endOfMemory.

Simplify markAndTraceStackPage: ; since the two implementations
are distinct they don't need to contain the isCog if-then-else.

Implement NewObjectMemory>>shorten:toIndexableSize: so that
the last object is correctly shortened (cut back freeStart).  Refactor
the allocation check filling code into
maybeFillWithAllocationCheckFillerFrom:to:.

Make longPrintOop: print the class oop.

Fix bug in printCallStackOf:currentFP: for widowed contexts.
Use fputs for print: instead of printf.

=============== Diff against VMMaker.oscog-eem.257 ===============

Item was added:
+ ----- Method: CoInterpreter>>checkOkayFields: (in category 'debug support') -----
+ checkOkayFields: oop
+ 	"Check if the argument is an ok object.
+ 	 If this is a pointers object, check that its fields are all okay oops."
+ 
+ 	| hasYoung i fieldOop |
+ 	(oop = nil or: [oop = 0]) ifTrue: [ ^true ]. "?? eem 1/16/2013"
+ 	(objectMemory isIntegerObject: oop) ifTrue: [ ^true ].
+ 	(objectMemory checkOkayOop: oop) ifFalse: [ ^false ].
+ 	(self checkOopHasOkayClass: oop) ifFalse: [ ^false ].
+ 	hasYoung := objectMemory isYoung: (objectMemory fetchClassOfNonInt: oop).
+ 	((objectMemory isPointers: oop) or: [objectMemory isCompiledMethod: oop]) ifFalse: [ ^true ].
+ 	(objectMemory isCompiledMethod: oop)
+ 		ifTrue:
+ 			[i := (self literalCountOf: oop) - 1]
+ 		ifFalse:
+ 			[(self isContext: oop)
+ 				ifTrue: [i := CtxtTempFrameStart + (self fetchStackPointerOf: oop) - 1]
+ 				ifFalse: [i := (objectMemory lengthOf: oop) - 1]].
+ 	[i >= 0] whileTrue:
+ 		[fieldOop := objectMemory fetchPointer: i ofObject: oop.
+ 		(objectMemory isNonIntegerObject: fieldOop) ifTrue:
+ 			[(i = 0 and: [objectMemory isCompiledMethod: oop])
+ 				ifTrue:
+ 					[(cogMethodZone methodFor: (self pointerForOop: fieldOop)) = 0 ifTrue:
+ 						[self print: 'method '; printHex: oop; print: ' has an invalid cog method reference'.
+ 						^false]]
+ 				ifFalse:
+ 					[hasYoung := hasYoung or: [objectMemory isYoung: fieldOop].
+ 					(objectMemory checkOkayOop: fieldOop) ifFalse: [ ^false ].
+ 					(self checkOopHasOkayClass: fieldOop) ifFalse: [ ^false ]]].
+ 		i := i - 1].
+ 	hasYoung ifTrue:
+ 		[^objectMemory checkOkayYoungReferrer: oop].
+ 	^true!

Item was changed:
  ----- Method: CoInterpreter>>markAndTraceStackPage: (in category 'object memory support') -----
  markAndTraceStackPage: thePage
  	| theSP theFP frameRcvrOffset callerFP oop |
  	<var: #thePage type: #'StackPage *'>
  	<var: #theSP type: #'char *'>
  	<var: #theFP type: #'char *'>
  	<var: #frameRcvrOffset type: #'char *'>
  	<var: #callerFP type: #'char *'>
  	<inline: false>
  	self assert: (stackPages isFree: thePage) not.
  	theSP := thePage headSP.
  	theFP := thePage  headFP.
  	"Skip the instruction pointer on top of stack of inactive pages."
  	thePage = stackPage ifFalse:
  		[theSP := theSP + BytesPerWord].
  	[frameRcvrOffset := self frameReceiverOffset: theFP.
  	 [theSP <= frameRcvrOffset] whileTrue:
  		[oop := stackPages longAt: theSP.
  		 (objectMemory isIntegerObject: oop) ifFalse:
  			[objectMemory markAndTrace: oop].
  		 theSP := theSP + BytesPerWord].
  	(self frameHasContext: theFP) ifTrue:
  		[self assert: (self isContext: (self frameContext: theFP)).
  		 objectMemory markAndTrace: (self frameContext: theFP)].
  	(self isMachineCodeFrame: theFP)
  		ifTrue: [self markAndTraceMachineCodeMethod: (self mframeCogMethod: theFP)]
  		ifFalse: [objectMemory markAndTrace: (self iframeMethod: theFP)].
  	(callerFP := self frameCallerFP: theFP) ~= 0] whileTrue:
  		[theSP := theFP + FoxCallerSavedIP + BytesPerWord.
  		 theFP := callerFP].
+ 	theSP := theFP + FoxCallerSavedIP + BytesPerWord. "caller ip is ceBaseReturnPC"
- 	theSP := self isCog
- 				ifTrue: [theFP + FoxCallerSavedIP + BytesPerWord] "caller ip is ceBaseReturnPC"
- 				ifFalse: [theFP + FoxCallerSavedIP]. "caller ip is frameCallerContext in a base frame"
  	[theSP <= thePage baseAddress] whileTrue:
  		[oop := stackPages longAt: theSP.
  		 (objectMemory isIntegerObject: oop) ifFalse:
  			[objectMemory markAndTrace: oop].
  		 theSP := theSP + BytesPerWord]!

Item was changed:
  ----- Method: CoInterpreterMT>>checkForEventsMayContextSwitch: (in category 'process primitive support') -----
  checkForEventsMayContextSwitch: mayContextSwitch
  	"Check for possible interrupts and handle one if necessary.
  	 Answer if a context switch has occurred."
  	| switched sema now |
  	<inline: false>
  	<var: #now type: #usqLong>
  	self assertSaneThreadAndProcess.
  	cogit assertCStackWellAligned.
  	statCheckForEvents := statCheckForEvents + 1.
  
  	"restore the stackLimit if it has been smashed."
  	self restoreStackLimit.
  	self externalWriteBackHeadFramePointers.
  	self assert: stackPage = stackPages mostRecentlyUsedPage.
  
  	"Allow the platform to do anything it needs to do synchronously."
  	self ioSynchronousCheckForEvents.
  
  	self checkCogCompiledCodeCompactionCalledFor.
  
  	objectMemory needGCFlag ifTrue:
+ 		["sufficientSpaceAfterGC: runs the incremental GC and
- 		[objectMemory needGCFlag: false.
- 		"sufficientSpaceAfterGC: runs the incremental GC and
  		 then, if not enough space is available, the fullGC."
  		 (objectMemory sufficientSpaceAfterGC: 0) ifFalse:
  			[self setSignalLowSpaceFlagAndSaveProcess]].
  
  	mayContextSwitch ifFalse: [^false].
  
  	switched := false.
  	self assert: deferThreadSwitch not.
  	deferThreadSwitch := true.
  
  	(profileProcess ~= objectMemory nilObject
  	 or: [nextProfileTick > 0 and:[self ioHighResClock >= nextProfileTick]]) ifTrue:
  		["Take a sample (if not already done so) for the profiler if it is active.  This
  		  must be done before any of the synchronousSignals below or else we will
  		  attribute a pause in ioRelinquishProcessor to the newly activated process."
  		profileProcess = objectMemory nilObject ifTrue:
  			[profileProcess := self activeProcess.
  			 profileMethod := objectMemory nilObject].
  		"and signal the profiler semaphore if it is present"
  		(profileSemaphore ~= objectMemory nilObject 
  		 and: [self synchronousSignal: profileSemaphore]) ifTrue:
  			[switched := true].
  		nextProfileTick := 0].
  
  	self checkDeliveryOfLongRunningPrimitiveSignal ifTrue:
  		[switched := true].
  
  	objectMemory signalLowSpace ifTrue:
  		[objectMemory signalLowSpace: false. "reset flag"
  		 sema := objectMemory splObj: TheLowSpaceSemaphore.
  		 (sema ~= objectMemory nilObject 
  		  and: [self synchronousSignal: sema]) ifTrue:
  			[switched := true]].
  
  	"inIOProcessEvents prevents reentrancy into ioProcessEvents and allows disabling
  	 ioProcessEvents e.g. for native GUIs.  We would like to manage that here but can't
  	 since the platform code may choose to call ioProcessEvents itself in various places."
  	false
  		ifTrue:
  			[((now := self ioUTCMicroseconds) >= nextPollUsecs
  			 and: [inIOProcessEvents = 0]) ifTrue:
  				[statIOProcessEvents := statIOProcessEvents + 1.
  				 inIOProcessEvents := inIOProcessEvents + 1.
  				 self ioProcessEvents. "sets interruptPending if interrupt key pressed; may callback"
  				 inIOProcessEvents > 0 ifTrue:
  					[inIOProcessEvents := inIOProcessEvents - 1].
  				 nextPollUsecs := now + 20000
  				 "msecs to wait before next call to ioProcessEvents.  Note that strictly
  				  speaking we might need to update 'now' at this point since
  				  ioProcessEvents could take a very long time on some platforms"]]
  		ifFalse:
  			[(now := self ioUTCMicroseconds) >= nextPollUsecs ifTrue:
  				[statIOProcessEvents := statIOProcessEvents + 1.
  				 self ioProcessEvents. "sets interruptPending if interrupt key pressed; may callback"
  				 nextPollUsecs := now + 20000
  				 "msecs to wait before next call to ioProcessEvents.  Note that strictly
  				  speaking we might need to update 'now' at this point since
  				  ioProcessEvents could take a very long time on some platforms"]].
  
  	interruptPending ifTrue:
  		[interruptPending := false.
  		 "reset interrupt flag"
  		 sema := objectMemory splObj: TheInterruptSemaphore.
  		 (sema ~= objectMemory nilObject 
  		  and: [self synchronousSignal: sema]) ifTrue:
  			[switched := true]].
  
  	nextWakeupUsecs ~= 0 ifTrue:
  		[now >= nextWakeupUsecs ifTrue:
  			[nextWakeupUsecs := 0.
  			 "set timer interrupt to 0 for 'no timer'"
  			 sema := objectMemory splObj: TheTimerSemaphore.
  			 (sema ~= objectMemory nilObject 
  			  and: [self synchronousSignal: sema]) ifTrue:
  				[switched := true]]].
  
  	"signal any pending finalizations"
  	pendingFinalizationSignals > 0 ifTrue:
  		[sema := objectMemory splObj: TheFinalizationSemaphore.
  		 ((objectMemory isClassOfNonImm: sema equalTo: (objectMemory splObj: ClassSemaphore))
  		  and: [self synchronousSignal: sema]) ifTrue:
  			[switched := true].
  		pendingFinalizationSignals := 0].
  
  	"signal all semaphores in semaphoresToSignal"
  	self signalExternalSemaphores ifTrue:
  		[switched := true].
  
  	deferThreadSwitch := false.
  	checkThreadActivation ifTrue:
  		[checkThreadActivation := false.
  		 self cedeToHigherPriorityThreads]. "N.B.  This may not return if we do switch."
  
  	self threadSwitchIfNecessary: self activeProcess from: CSCheckEvents.
  	^switched!

Item was changed:
  ----- Method: Interpreter>>primitiveRootTable (in category 'memory space primitives') -----
  primitiveRootTable
  	"Primitive. Answer a copy (snapshot) element of the root table.
  	The primitive can cause GC itself and if so the return value may
  	be inaccurate - in this case one should guard the read operation
  	by looking at the gc counter statistics."
+ 	self pop: argumentCount + 1 thenPush: self rootTableObject!
- 	| oop sz |
- 	<export: true>
- 	sz := rootTableCount.
- 	oop := self instantiateClass: self classArray indexableSize: sz. "can cause GC"
- 	sz > rootTableCount ifTrue:[sz := rootTableCount].
- 	1 to: sz do:[:i| 
- 		self storePointer: i-1 ofObject: oop withValue: (rootTable at: i).
- 	].
- 	self pop: argumentCount + 1.
- 	self push: oop.!

Item was changed:
  ----- Method: InterpreterPrimitives>>primitiveRootTable (in category 'memory space primitives') -----
  primitiveRootTable
  	"Primitive. Answer a copy (snapshot) element of the root table.
  	The primitive can cause GC itself and if so the return value may
  	be inaccurate - in this case one should guard the read operation
  	by looking at the gc counter statistics."
+ 	self pop: argumentCount + 1 thenPush: objectMemory rootTableObject!
- 	| oop sz |
- 	<export: true>
- 	sz := objectMemory rootTableCount.
- 	oop := objectMemory instantiateClass: objectMemory classArray indexableSize: sz. "can cause GC"
- 	sz > objectMemory rootTableCount ifTrue:[sz := objectMemory rootTableCount].
- 	1 to: sz do:[:i| 
- 		objectMemory storePointer: i-1 ofObject: oop withValue: (objectMemory rootTable at: i).
- 	].
- 	self pop: argumentCount + 1.
- 	self push: oop.!

Item was changed:
  ----- Method: NewCoObjectMemorySimulator>>objectBefore: (in category 'testing') -----
  objectBefore: addr
  	| oop prev |
  	oop := self firstObject.
+ 	[oop < freeStart] whileTrue:
- 	[oop < endOfMemory] whileTrue:
  		[prev := oop.  "look here if debugging prev obj overlapping this one"
  		oop := self objectAfter: oop.
  		oop >= addr ifTrue: [^ prev]].
  	^0!

Item was changed:
  ----- Method: NewCoObjectMemorySimulator>>validOop: (in category 'testing') -----
  validOop: oop
  	" Return true if oop appears to be valid "
  	(oop bitAnd: 1) = 1 ifTrue: [^ true].  "Integer"
  	(oop bitAnd: 3) = 0 ifFalse: [^ false].  "Uneven address"
+ 	oop >= freeStart ifTrue: [^ false].  "Out of range"
- 	oop >= endOfMemory ifTrue: [^ false].  "Out of range"
  	"could test if within the first large freeblock"
  	(self longAt: oop) = 4 ifTrue: [^ false].
  	(self headerType: oop) = 2 ifTrue: [^ false].	"Free object"
  	^ true!

Item was added:
+ ----- Method: NewObjectMemory>>adjustAllOopsBy: (in category 'initialization') -----
+ adjustAllOopsBy: bytesToShift 
+ 	"Adjust all oop references by the given number of bytes. This 
+ 	is done just after reading in an image when the new base 
+ 	address of the object heap is different from the base address 
+ 	in the image."
+ 	"di 11/18/2000 - return number of objects found"
+ 
+ 	| oop totalObjects |
+ 	<inline: false>
+ 	bytesToShift = 0 ifTrue: [^300000].
+ 	"this is probably an improvement over the previous answer of 
+ 	nil, but maybe we should do the obejct counting loop and 
+ 	simply guard the adjustFieldsAndClass... with a bytesToShift 
+ 	= 0 ifFalse: ?"
+ 	totalObjects := 0.
+ 	oop := self firstObject.
+ 	[self oop: oop isLessThan: freeStart]
+ 		whileTrue:
+ 			[(self isFreeObject: oop)
+ 				ifFalse:
+ 					[totalObjects := totalObjects + 1.
+ 					 self adjustFieldsAndClassOf: oop by: bytesToShift].
+ 			 oop := self objectAfter: oop].
+ 	^totalObjects!

Item was changed:
  ----- Method: NewObjectMemory>>become:with:twoWay:copyHash: (in category 'become') -----
  become: array1 with: array2 twoWay: twoWayFlag copyHash: copyHashFlag
  	"All references to each object in array1 are swapped with all references to the corresponding object in array2. That is, all pointers to one object are replaced with with pointers to the other. The arguments must be arrays of the same length. 
  	Returns PrimNoErr if the primitive succeeds."
  	"Implementation: Uses forwarding blocks to update references as done in compaction."
  	| start |
  	self leakCheckBecome ifTrue:
  		[self runLeakCheckerForFullGC: true].
  	(self isArray: array1) ifFalse:
  		[^PrimErrBadReceiver].
  	((self isArray: array2)
  	 and: [(self lastPointerOf: array1) = (self lastPointerOf: array2)]) ifFalse:
  		[^PrimErrBadArgument].
  	(twoWayFlag or: [copyHashFlag])
  		ifTrue: [(self containOnlyOops: array1 and: array2) ifFalse: [^PrimErrInappropriate]]
  		ifFalse: [(self containOnlyOops: array1) ifFalse: [^PrimErrInappropriate]].
  
  	(self prepareForwardingTableForBecoming: array1 with: array2 twoWay: twoWayFlag) ifFalse:
  		[^PrimErrNoMemory]. "fail; not enough space for forwarding table"
  
  	(self allYoung: array1 and: array2)
  		ifTrue: [start := youngStart"sweep only the young objects plus the roots"]
  		ifFalse: [start := self startOfMemory"sweep all objects"].
  	coInterpreter preBecomeAction.
+ 	self mapPointersInObjectsFrom: start to: freeStart.
- 	self mapPointersInObjectsFrom: start to: endOfMemory.
  	twoWayFlag
  		ifTrue: [self restoreHeadersAfterBecoming: array1 with: array2]
  		ifFalse: [self restoreHeadersAfterForwardBecome: copyHashFlag].
  	coInterpreter postBecomeAction.
  
  	self initializeMemoryFirstFree: freeStart. "re-initialize memory used for forwarding table"
  	self leakCheckBecome ifTrue:
  		[self runLeakCheckerForFullGC: true].
  	self forceInterruptCheck. "pretty much guaranteed to take a long time, so check for timers etc ASAP"
  
  	^PrimNoErr "success"!

Item was added:
+ ----- Method: NewObjectMemory>>checkHeapIntegrity (in category 'memory access') -----
+ checkHeapIntegrity
+ 	"Perform an integrity/leak check using the heapMap.  Assume
+ 	 clearLeakMapAndMapAccessibleObjects has set a bit at each
+ 	 object's header.  Scan all objects in the heap checking that every
+ 	 pointer points to a header.  Scan the rootTable, remapBuffer and
+ 	 extraRootTable checking that every entry is a pointer to a header.
+ 	 Check that the number of roots is correct and that all rootTable
+ 	 entries have their rootBit set. Answer if all checks pass."
+ 	| ok obj sz hdr fmt fi fieldOop numRootsInHeap |
+ 	<inline: false>
+ 	ok := true.
+ 	numRootsInHeap := 0.
+ 	obj := self firstObject.
+ 	[self oop: obj isLessThan: self startOfFreeSpace] whileTrue:
+ 		[(self isFreeObject: obj)
+ 			ifTrue:
+ 				[sz := self sizeOfFree: obj]
+ 			ifFalse:
+ 				[hdr := self baseHeader: obj.
+ 				 (self isYoungRootHeader: hdr) ifTrue:
+ 					[numRootsInHeap := numRootsInHeap + 1].
+ 				 (self compactClassIndexOfHeader: hdr) = 0 ifTrue:
+ 					[fieldOop := (self classHeader: obj) bitAnd: AllButTypeMask.
+ 					 ((self isIntegerObject: fieldOop)
+ 					   or: [(self heapMapAtWord: (self pointerForOop: fieldOop)) = 0]) ifTrue:
+ 						[self print: 'object leak in '; printHex: obj; print: ' class = '; printHex: fieldOop; cr.
+ 						 ok := false]].
+ 				 fmt := self formatOfHeader: hdr.
+ 				 (fmt <= 4 "pointers" or: [fmt >= 12 "compiled method"]) ifTrue:
+ 					[fmt >= 12
+ 						ifTrue: [fi := (self literalCountOf: obj) + 1 "+ 1 = methodHeader slot"]
+ 						ifFalse: [(fmt = 3 and: [self isContextHeader: hdr])
+ 									ifTrue: [fi := CtxtTempFrameStart + (self fetchStackPointerOf: obj)]
+ 									ifFalse: [fi := self lengthOf: obj]].
+ 					[(fi := fi - 1) >= 0] whileTrue:
+ 						[fieldOop := self fetchPointer: fi ofObject: obj.
+ 						 (self isNonIntegerObject: fieldOop) ifTrue:
+ 							[(fieldOop bitAnd: BytesPerWord - 1) ~= 0
+ 								ifTrue:
+ 									[self print: 'misaligned oop in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; cr.
+ 									 ok := false]
+ 								ifFalse:
+ 									[(self heapMapAtWord: (self pointerForOop: fieldOop)) = 0 ifTrue:
+ 										[self print: 'object leak in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; cr.
+ 										 ok := false]]]]].
+ 				 sz := self sizeBitsOf: obj].
+ 		 obj := self oopFromChunk: obj + sz].
+ 	numRootsInHeap ~= rootTableCount ifTrue:
+ 		[self print: 'root count mismatch. #heap roots '; printNum: numRootsInHeap; print: '; #roots '; printNum: rootTableCount; cr.
+ 		"But the system copes with overflow..."
+ 		ok := rootTableOverflowed and: [needGCFlag]].
+ 	1 to: rootTableCount do:
+ 		[:ri|
+ 		obj := rootTable at: ri.
+ 		(obj bitAnd: BytesPerWord - 1) ~= 0
+ 			ifTrue:
+ 				[self print: 'misaligned oop in rootTable @ '; printNum: ri; print: ' = '; printHex: obj; cr.
+ 				 ok := false]
+ 			ifFalse:
+ 				[(self heapMapAtWord: (self pointerForOop: obj)) = 0
+ 					ifTrue:
+ 						[self print: 'object leak in rootTable @ '; printNum: ri; print: ' = '; printHex: obj; cr.
+ 						 ok := false]
+ 					ifFalse:
+ 						[hdr := self baseHeader: obj.
+ 						 (self isYoungRootHeader: hdr) ifFalse:
+ 							[self print: 'non-root in rootTable @ '; printNum: ri; print: ' = '; printHex: obj; cr.
+ 							 ok := false]]]].
+ 	1 to: remapBufferCount do:
+ 		[:ri|
+ 		obj := remapBuffer at: ri.
+ 		(obj bitAnd: BytesPerWord - 1) ~= 0
+ 			ifTrue:
+ 				[self print: 'misaligned remapRoot @ '; printNum: ri; print: ' = '; printHex: obj; cr.
+ 				 ok := false]
+ 			ifFalse:
+ 				[(self heapMapAtWord: (self pointerForOop: obj)) = 0
+ 					ifTrue:
+ 						[self print: 'object leak in remapRoots @ '; printNum: ri; print: ' = '; printHex: obj; cr.
+ 						 ok := false]]].
+ 	1 to: extraRootCount do:
+ 		[:ri|
+ 		obj := (extraRoots at: ri) at: 0.
+ 		(obj bitAnd: BytesPerWord - 1) ~= 0
+ 			ifTrue:
+ 				[self print: 'misaligned extraRoot @ '; printNum: ri; print: ' => '; printHex: obj; cr.
+ 				 ok := false]
+ 			ifFalse:
+ 				[(self heapMapAtWord: (self pointerForOop: obj)) = 0
+ 					ifTrue:
+ 						[self print: 'object leak in extraRoots @ '; printNum: ri; print: ' => '; printHex: obj; cr.
+ 						 ok := false]]].
+ 	^ok!

Item was changed:
  ----- Method: NewObjectMemory>>checkOkayOop: (in category 'debug support') -----
  checkOkayOop: oop
  	"Verify that the given oop is legitimate. Check address, header, and size but not class.
  	 Answer true if OK.  Otherwise print reason and answer false."
  
  	<api>
  	<var: #oop type: #usqInt>
  	| sz type fmt unusedBit |
  
  	"address and size checks"
  	(self isIntegerObject: oop) ifTrue: [ ^true ].
+ 	((self oop: oop isGreaterThanOrEqualTo: self startOfMemory) and: [self oop: oop isLessThan: freeStart])
+ 		ifFalse: [ self print: 'oop '; printHex: oop; print: ' is not a valid address'; cr. ^false ].
- 	(oop >= self startOfMemory and: [oop < freeStart])
- 		ifFalse: [ self print: 'oop is not a valid address'; cr. ^false ].
  	((oop \\ BytesPerWord) = 0)
+ 		ifFalse: [ self print: 'oop '; printHex: oop; print: ' is not a word-aligned address'; cr. ^false ].
- 		ifFalse: [ self print: 'oop is not a word-aligned address'; cr. ^false ].
  	sz := self sizeBitsOf: oop.
+ 	(self oop: oop + sz isLessThanOrEqualTo: freeStart)
+ 		ifFalse: [ self print: 'oop '; printHex: oop; print: ' size would make it extend beyond the end of memory'; cr. ^false ].
- 	(oop + sz) < freeStart
- 		ifFalse: [ self print: 'oop size would make it extend beyond the end of memory'; cr. ^false ].
  
  	"header type checks"
  	type := self headerType: oop.
  	type = HeaderTypeFree
+ 		ifTrue:  [ self print: 'oop '; printHex: oop; print: ' is a free chunk, not an object'; cr. ^false ].
- 		ifTrue:  [ self print: 'oop is a free chunk, not an object'; cr. ^false ].
  	type = HeaderTypeShort ifTrue: [
  		(self compactClassIndexOf: oop) = 0
+ 			ifTrue:  [ self print: 'oop '; printHex: oop; print: ' cannot have zero compact class field in a short header'; cr. ^false ].
- 			ifTrue:  [ self print: 'cannot have zero compact class field in a short header'; cr. ^false ].
  	].
  	type = HeaderTypeClass ifTrue: [
  		((oop >= BytesPerWord) and: [(self headerType: oop - BytesPerWord) = type])
+ 			ifFalse: [ self print: 'oop '; printHex: oop; print: ' class header word has wrong type'; cr. ^false ].
- 			ifFalse: [ self print: 'class header word has wrong type'; cr. ^false ].
  	].
  	type = HeaderTypeSizeAndClass ifTrue: [
  		((oop >= (BytesPerWord*2)) and:
  		 [(self headerType: oop - (BytesPerWord*2)) = type and:
  		 [(self headerType: oop - BytesPerWord) = type]])
+ 			ifFalse: [ self print: 'oop '; printHex: oop; print: ' class header word has wrong type'; cr. ^false ].
- 			ifFalse: [ self print: 'class header word has wrong type'; cr. ^false ].
  	].
  
  	"format check"
  	fmt := self formatOf: oop.
  	((fmt = 5) | (fmt = 7))
+ 		ifTrue:  [ self print: 'oop '; printHex: oop; print: ' has an unknown format type'; cr. ^false ].
- 		ifTrue:  [ self print: 'oop has an unknown format type'; cr. ^false ].
  
  	"mark and root bit checks"
  	unusedBit := 16r20000000.
  	BytesPerWord = 8
  		ifTrue:
  			[unusedBit := unusedBit << 16.
  			 unusedBit := unusedBit << 16].
  	((self longAt: oop) bitAnd: unusedBit) = 0
+ 		ifFalse: [ self print: 'oop '; printHex: oop; print: ' unused header bit 30 is set; should be zero'; cr. ^false ].
- 		ifFalse: [ self print: 'unused header bit 30 is set; should be zero'; cr. ^false ].
  "xxx
  	((self longAt: oop) bitAnd: MarkBit) = 0
  		ifFalse: [ self print: 'mark bit should not be set except during GC' ].
  xxx"
  	((self isYoungRoot: oop) and: [oop >= youngStart])
+ 		ifTrue: [ self print: 'oop '; printHex: oop; print: ' root bit is set in a young object'; cr. ^false ].
- 		ifTrue: [ self print: 'root bit is set in a young object'; cr. ^false ].
  	^true
  !

Item was changed:
  ----- Method: NewObjectMemory>>fullGC (in category 'garbage collection') -----
  fullGC
  	"Do a mark/sweep garbage collection of the entire object memory.
  	 Free inaccessible objects but do not move them."
  
  	<inline: false>
  	fullGCLock > 0 ifTrue:
  		[self warning: 'aborting fullGC because fullGCLock > 0'.
  		 ^self].
  	self runLeakCheckerForFullGC: true.
  	self preGCAction: GCModeFull.
+ 	needGCFlag := false.
  	gcStartUsecs := self ioUTCMicrosecondsNow.
  	statSweepCount := statMarkCount := statMkFwdCount := statCompMoveCount := 0.
  	self clearRootsTable.
  	self initWeakTableForIncrementalGC: false.
  	youngStart := self startOfMemory.  "process all of memory"
  	self markPhase: true.
  	"Sweep phase returns the number of survivors.
  	Use the up-to-date version instead the one from startup."
  	totalObjectCount := self sweepPhaseForFullGC.
  	self runLeakCheckerForFullGC: true.
  	self fullCompaction.
  	statFullGCs := statFullGCs + 1.
  	statGCEndUsecs := self ioUTCMicrosecondsNow.
  	statFullGCUsecs := statFullGCUsecs + (statGCEndUsecs - gcStartUsecs).
  	self capturePendingFinalizationSignals.
  
  	youngStart := freeStart.  "reset the young object boundary"
  	self postGCAction.
  	self runLeakCheckerForFullGC: true!

Item was changed:
  ----- Method: NewObjectMemory>>incCompMakeFwd (in category 'gc -- compaction') -----
  incCompMakeFwd
  	"Create and initialize forwarding blocks for all non-free objects  
  	 following compStart. If the supply of forwarding blocks is exhausted,  
  	 set compEnd to the first chunk above the area to be compacted;
  	 otherwise, set it to endOfMemory. Return the number of bytes to be freed."
  	| bytesToBeFreed oop fwdBlock newOop |
  	<inline: false>
  	bytesToBeFreed := 0.
  	oop := self oopFromChunk: compStart.
  	self assert: (self oop: oop isGreaterThan: self startOfMemory andLessThan: freeStart).
  	[self oop: oop isLessThan: freeStart] whileTrue:
  		[statMkFwdCount := statMkFwdCount + 1.
  		 self assert: (self oop: oop isGreaterThan: self startOfMemory andLessThan: freeStart).
  		 (self isFreeObject: oop)
  			ifTrue: [bytesToBeFreed := bytesToBeFreed + (self sizeOfFree: oop)]
  			ifFalse: "create a forwarding block for oop"
  				[fwdBlock := self fwdBlockGet: BytesPerWord*2.
  				 "Two-word block"
  				 fwdBlock = nil ifTrue: "stop; we have used all available forwarding blocks"
  					[compEnd := self chunkFromOop: oop.
  					 ^bytesToBeFreed].
  				newOop := oop - bytesToBeFreed.
  				self assert: (self oop: newOop isGreaterThan: self startOfMemory andLessThan: freeStart).
  				self initForwardBlock: fwdBlock mapping: oop to: newOop withBackPtr: false].
  			oop := self objectAfterWhileForwarding: oop].
+ 	compEnd := freeStart.
- 	compEnd := endOfMemory.
  	^bytesToBeFreed!

Item was changed:
  ----- Method: NewObjectMemory>>incrementalGC (in category 'garbage collection') -----
  incrementalGC
  	"Do a mark/sweep garbage collection of just the young object
  	area of object memory (i.e., objects above youngStart), using
  	the root table to identify objects containing pointers to
  	young objects from the old object area."
  	| survivorCount weDidGrow |
  	<inline: false>
  
+ 	rootTableOverflowed ifTrue:
+ 		["root table overflow; cannot do an incremental GC because some roots are missing.
+ 		 (this should be very rare)"
- 	rootTableCount >= RootTableSize ifTrue:
- 		["root table overflow; cannot do an incremental GC (this should be very rare)"
  		 statRootTableOverflows := statRootTableOverflows + 1.
  		 ^self fullGC].
  	self runLeakCheckerForFullGC: false.
  	self preGCAction: GCModeIncr.
+ 	needGCFlag := false.
  	gcStartUsecs := self ioUTCMicrosecondsNow.
  	statSweepCount := statMarkCount := statMkFwdCount := statCompMoveCount := 0.
  	self initWeakTableForIncrementalGC: true.
  	"implicitly process memory from youngStart to freeStart"
  	self markPhase: false.
  	self assert: weakRootCount <= WeakRootTableSize.
  	1 to: weakRootCount do:
  		[:i| self finalizeReference: (weakRoots at: i)].
  	survivorCount := self sweepPhase.
  	self runLeakCheckerForFullGC: false.
  	self incrementalCompaction.
  	statIncrGCs := statIncrGCs + 1.
  	statGCEndUsecs := self ioUTCMicrosecondsNow.
  	statIGCDeltaUsecs := statGCEndUsecs - gcStartUsecs.
  	statIncrGCUsecs := statIncrGCUsecs + statIGCDeltaUsecs.
  	self capturePendingFinalizationSignals.
  	
  	statRootTableCount  := rootTableCount.
  	statSurvivorCount := survivorCount.
  	weDidGrow := false.
  	(((survivorCount > tenuringThreshold)
  	 or: [rootTableCount >= RootTableRedZone])
  	 or: [forceTenureFlag == true]) ifTrue:
  		["move up the young space boundary if
  		  * there are too many survivors:
  			this limits the number of objects that must be
  			processed on future incremental GC's
  		  * we're about to overflow the roots table:
  			this limits the number of full GCs that may be caused
  			by root table overflows in the near future"
  		forceTenureFlag := false.
  		statTenures := statTenures + 1.
  		self clearRootsTable.
  		((self freeSize < growHeadroom)
  		 and: [gcBiasToGrow > 0]) ifTrue:
  			[self biasToGrow.
  			 weDidGrow := true].
  		youngStart := freeStart].
  	self postGCAction.
  	
  	self runLeakCheckerForFullGC: false.
  	weDidGrow ifTrue:
  		[self biasToGrowCheckGCLimit]!

Item was changed:
  ----- Method: NewObjectMemory>>initialize (in category 'initialization') -----
  initialize
  	<doNotGenerate>
  	"Initialize NewObjectMemory when simulating the VM inside Smalltalk."
  	super initialize.
+ 	checkForLeaks := fullGCLock := 0.
+ 	needGCFlag := false!
- 	checkForLeaks := fullGCLock := 0!

Item was changed:
  ----- Method: NewObjectMemory>>initializeMemoryFirstFree: (in category 'initialization') -----
  initializeMemoryFirstFree: firstFree 
  	"Initialize endOfMemory to the top of oop storage space, reserving some space
  	 for forwarding blocks, and set freeStart from which space is allocated."
  	"Note: The amount of space reserved for forwarding blocks should be chosen to
  	  ensure that incremental compactions can usually be done in a single pass.
  	  However, there should be enough forwarding blocks so a full compaction can be done
  	  in a reasonable number of passes, say ten. (A full compaction requires N object-moving
  	  passes, where N = number of non-garbage objects / number of forwarding blocks).
  
  	di 11/18/2000 Re totalObjectCount: Provide a margin of one byte per object to be
  	 used for forwarding pointers at GC time. Since fwd blocks are 8 bytes, this means
  	 an absolute worst case of 8 passes to compact memory. In most cases it will be
  	 adequate to do compaction in a single pass. "
  	| fwdBlockBytes totalReserve |
  	"reserve space for forwarding blocks and the interpreter.  We can sacrifice
  	 forwarding block space at the cost of slower compactions but we cannot
  	 safely sacrifice interpreter allocation headroom."
  	fwdBlockBytes := totalObjectCount bitAnd: WordMask - BytesPerWord + 1.
  	totalReserve := fwdBlockBytes + self interpreterAllocationReserveBytes.
  	(self oop: memoryLimit - totalReserve isLessThan: firstFree + BaseHeaderSize) ifTrue:
  		["reserve enough space for a minimal free block of BaseHeaderSize bytes.
  		  We are apparently in an emergency situation here because we have no space
  		  for reserve and forwarding blocks.  But a full GC will occur immediately in	
  		  sufficientSpaceAfterGC: which will grow memory and restore the reserve."
  		 fwdBlockBytes := memoryLimit - (firstFree  + BaseHeaderSize)].
  
  	"set endOfMemory reserveStart and freeStart"
  	self setEndOfMemory: memoryLimit - fwdBlockBytes.
  	reserveStart := endOfMemory - self interpreterAllocationReserveBytes.
  	freeStart := firstFree. "bytes available for oops"
  	scavengeThreshold := freeStart + edenBytes min: reserveStart.
+ 	self maybeFillWithAllocationCheckFillerFrom: freeStart to: scavengeThreshold.
- 	AllocationCheckFiller ~= 0 ifTrue:
- 		[freeStart to: scavengeThreshold by: BytesPerWord do:
- 			[:i| self longAt: i put: (AllocationCheckFiller == 16rADD4E55
- 									ifTrue: [i]
- 									ifFalse: [AllocationCheckFiller])]].
- 	needGCFlag := false.
  
+ 	self assert: (self oop: freeStart isLessThan: reserveStart).
+ 	"We would like to assert this but can't because in GC situations it may be false.  It is
+ 	established by sufficientSpaceToAllocate: and sufficientSpaceAfterGC:"
+ 	false ifTrue: [self assert: (self oop: reserveStart isLessThan: endOfMemory)].
+ 	self assert: (self oop: endOfMemory isLessThan: memoryLimit)!
- 	self assert: freeStart < reserveStart.
- 	self assert: reserveStart < endOfMemory.
- 	self assert: endOfMemory < memoryLimit!

Item was changed:
  ----- Method: NewObjectMemory>>initializeObjectMemory: (in category 'initialization') -----
  initializeObjectMemory: bytesToShift
  	"Initialize object memory variables at startup time. Assume endOfMemory is initially set (by the image-reading code) to the end of the last object in the image. Initialization redefines endOfMemory to be the end of the object allocation area based on the total available memory, but reserving some space for forwarding blocks."
  	"Assume: image reader initializes the following variables:
  		memory
  		endOfMemory
  		memoryLimit
  		specialObjectsOop
  		lastHash
  	"
  	"di 11/18/2000 fix slow full GC"
  	<inline: false>
  
  	"set the start of the young object space"
+ 	youngStart := freeStart := endOfMemory.
- 	youngStart := endOfMemory.
  
  	"image may be at a different address; adjust oops for new location"
  	totalObjectCount := self adjustAllOopsBy: bytesToShift.
  
  	self initializeMemoryFirstFree: endOfMemory. "initializes endOfMemory, freeStart"
  
  	specialObjectsOop := specialObjectsOop + bytesToShift.
  
  	"heavily used special objects"
  	nilObj	:= self splObj: NilObject.
  	falseObj	:= self splObj: FalseObject.
  	trueObj	:= self splObj: TrueObject.
  
  	rootTableCount := 0.
+ 	rootTableOverflowed := false.
  	lowSpaceThreshold := 0.
  	signalLowSpace := false.
  	compStart := 0.
  	compEnd := 0.
  	fwdTableNext := 0.
  	fwdTableLast := 0.
  	remapBufferCount := 0.
  	tenuringThreshold := 2000.  "tenure all suriving objects if survivor count is over this threshold"
  	growHeadroom := 4*1024*1024. "four megabytes of headroom when growing"
  	shrinkThreshold := 8*1024*1024. "eight megabytes of free space before shrinking"
  
  	"garbage collection statistics"
  	statFullGCs := 0.
  	statFullGCUsecs := 0.
  	statIncrGCs := 0.
  	statIncrGCUsecs := 0.
  	statTenures := 0.
  	statRootTableOverflows := 0.
  	statGrowMemory := 0.
  	statShrinkMemory := 0.
  	forceTenureFlag := 0.
  	gcBiasToGrow := 0.
  	gcBiasToGrowGCLimit := 0.
  	extraRootCount := 0.
  !

Item was added:
+ ----- Method: NewObjectMemory>>maybeFillWithAllocationCheckFillerFrom:to: (in category 'allocation') -----
+ maybeFillWithAllocationCheckFillerFrom: start to: end
+ 	"Fill free memory with a bit pattern for chekcing if the last object has been overwritten."
+ 	<inline: true>
+ 	AllocationCheckFiller ~= 0 ifTrue:
+ 		[start to: end by: BytesPerWord do:
+ 			[:i|
+ 			self longAt: i put: (AllocationCheckFiller = 16rADD4E55
+ 									ifTrue: [i]
+ 									ifFalse: [AllocationCheckFiller])]]!

Item was removed:
- ----- Method: NewObjectMemory>>needGCFlag: (in category 'accessing') -----
- needGCFlag: aValue
- 	^needGCFlag := aValue!

Item was changed:
  ----- Method: NewObjectMemory>>noteAsRoot:headerLoc: (in category 'garbage collection') -----
  noteAsRoot: oop headerLoc: headerLoc 
+ 	"Record that the given oop in the old object area points to an object in the young area.
+ 	 HeaderLoc is usually = oop, but may be an addr in a forwarding block."
- 	"Record that the given oop in the old object area points to an 
- 	 object in the young area. HeaderLoc is usually = oop, but may
- 	 be an addr in a forwarding block."
  	| header |
  	<inline: true>
  	<asmLabel: false> 
  	header := self longAt: headerLoc.
  	(self isYoungRootHeader: header) ifFalse:
  		"record oop as root only if not already recorded"
+ 		[rootTableCount < RootTableSize
+ 			ifTrue:
+ 				"record root if there is enough room in the roots table.
+ 				 IMPORTANT: since clearRootsTable is the only thing that clears root bits
+ 				 do *not* set the root bit unless an object is in the root table.  checking
+ 				 routines will complain about the root bit being unset instead of the table
+ 				 being full, but that's life"
+ 				[rootTableCount := rootTableCount + 1.
+ 				 rootTable at: rootTableCount put: oop.
+ 				 self longAt: headerLoc put: (header bitOr: RootBit).
+ 				 rootTableCount >= RootTableRedZone ifTrue:
+ 					"if we're now in the red zone force an IGC ASAP"
+ 					[self scheduleIncrementalGC]]
+ 			ifFalse: "note overflow; will need to do a fullGC instead of an incremental."
+ 				[rootTableOverflowed := true]]!
- 		[rootTableCount < RootTableSize ifTrue:
- 			"record root if there is enough room in the roots table"
- 			[rootTableCount := rootTableCount + 1.
- 			 rootTable at: rootTableCount put: oop.
- 			 self longAt: headerLoc put: (header bitOr: RootBit).
- 			 rootTableCount > RootTableRedZone ifTrue:
- 				"if we're now in the red zone force an IGC ASAP"
- 				[self scheduleIncrementalGC]]]!

Item was added:
+ ----- Method: NewObjectMemory>>objectAfter: (in category 'object enumeration') -----
+ objectAfter: oop 
+ 	"Return the object or free chunk immediately following the 
+ 	given object or free chunk in memory. Return endOfMemory 
+ 	when enumeration is complete."
+ 	| sz |
+ 	<api>
+ 	<inline: true>
+ 	<asmLabel: false>
+ 	(self asserta: (self oop: oop isLessThan: freeStart)) ifFalse:
+ 		[self error: 'no objects after the end of memory'].
+ 	(self isFreeObject: oop)
+ 		ifTrue: [sz := self sizeOfFree: oop]
+ 		ifFalse: [sz := self sizeBitsOf: oop].
+ 	^self oopFromChunk: oop + sz!

Item was added:
+ ----- Method: NewObjectMemory>>setEndOfMemory: (in category 'initialization') -----
+ setEndOfMemory: newEndOfMemory
+ 	super setEndOfMemory: newEndOfMemory.
+ 	freeStart isNil ifTrue:
+ 		[freeStart := newEndOfMemory]!

Item was added:
+ ----- Method: NewObjectMemory>>shorten:toIndexableSize: (in category 'allocation') -----
+ shorten: obj toIndexableSize: nSlots
+ 	"Currently this works for pointer objects only, and is almost certainly wrong for 64 bits."
+ 	| deltaBytes desiredLength fixedFields fmt hdr totalLength |
+ 	(self isPointers: obj) ifFalse:
+ 		[^obj].
+ 	hdr := self baseHeader: obj.
+ 	fmt := self formatOfHeader: hdr.
+ 	totalLength := self lengthOf: obj baseHeader: hdr format: fmt.
+ 	fixedFields := self fixedFieldsOf: obj format: fmt length: totalLength.
+ 	desiredLength := fixedFields + nSlots.
+ 	deltaBytes := (totalLength - desiredLength) * BytesPerWord.
+ 	obj + BaseHeaderSize + (totalLength * BytesPerWord) = freeStart
+ 		ifTrue: "Shortening the last object.  Need to reduce freeStart."
+ 			[self maybeFillWithAllocationCheckFillerFrom: obj + BaseHeaderSize + (desiredLength * BytesPerWord) to: freeStart.
+ 			freeStart := obj + BaseHeaderSize + (desiredLength * BytesPerWord)]
+ 		ifFalse: "Shortening some interior object.  Need to create a free block."
+ 			[self setSizeOfFree: obj + BaseHeaderSize + (desiredLength * BytesPerWord)
+ 				to: deltaBytes].
+ 	(self headerType: obj) caseOf:	{
+ 		[HeaderTypeSizeAndClass] ->
+ 			[self longAt: obj put: hdr - deltaBytes].
+ 		[HeaderTypeClass] ->
+ 			[self longAt: obj put: ((hdr bitClear: SizeMask) bitOr: (hdr bitAnd: SizeMask) - deltaBytes)].
+ 		[HeaderTypeShort] ->
+ 			[self longAt: obj put: ((hdr bitClear: SizeMask) bitOr: (hdr bitAnd: SizeMask) - deltaBytes)] }.
+ 	^obj!

Item was changed:
  ----- Method: NewObjectMemorySimulator>>objectBefore: (in category 'testing') -----
  objectBefore: addr
  	| oop prev |
  	oop := self firstObject.
+ 	[oop < freeStart] whileTrue:
- 	[oop < endOfMemory] whileTrue:
  		[prev := oop.  "look here if debugging prev obj overlapping this one"
  		oop := self objectAfter: oop.
  		oop >= addr ifTrue: [^ prev]].
  	^0!

Item was changed:
  ----- Method: NewObjectMemorySimulator>>validOop: (in category 'testing') -----
  validOop: oop
  	" Return true if oop appears to be valid "
  	(oop bitAnd: 1) = 1 ifTrue: [^ true].  "Integer"
  	(oop bitAnd: 3) = 0 ifFalse: [^ false].  "Uneven address"
+ 	oop >= freeStart ifTrue: [^ false].  "Out of range"
- 	oop >= endOfMemory ifTrue: [^ false].  "Out of range"
  	"could test if within the first large freeblock"
  	(self longAt: oop) = 4 ifTrue: [^ false].
  	(self headerType: oop) = 2 ifTrue: [^ false].	"Free object"
  	^ true!

Item was changed:
  ----- Method: NewspeakInterpreter>>primitiveRootTable (in category 'memory space primitives') -----
  primitiveRootTable
  	"Primitive. Answer a copy (snapshot) element of the root table.
  	The primitive can cause GC itself and if so the return value may
  	be inaccurate - in this case one should guard the read operation
  	by looking at the gc counter statistics."
+ 	self pop: argumentCount + 1 thenPush: self rootTableObject!
- 	| oop sz |
- 	<export: true>
- 	sz := rootTableCount.
- 	oop := self instantiateClass: self classArray indexableSize: sz. "can cause GC"
- 	sz > rootTableCount ifTrue:[sz := rootTableCount].
- 	1 to: sz do:[:i| 
- 		self storePointer: i-1 ofObject: oop withValue: (rootTable at: i).
- 	].
- 	self pop: argumentCount + 1.
- 	self push: oop.!

Item was changed:
  VMClass subclass: #ObjectMemory
+ 	instanceVariableNames: 'memory youngStart endOfMemory memoryLimit nilObj falseObj trueObj specialObjectsOop rootTable rootTableCount rootTableOverflowed extraRoots extraRootCount weakRoots weakRootCount child field parentField freeBlock lastHash allocationCount lowSpaceThreshold signalLowSpace compStart compEnd fwdTableNext fwdTableLast remapBuffer remapBufferCount allocationsBetweenGCs tenuringThreshold gcBiasToGrow gcBiasToGrowGCLimit gcBiasToGrowThreshold statFullGCs statIncrGCs statFullGCUsecs statIncrGCUsecs statGCEndTime statIGCDeltaUsecs statTenures statRootTableOverflows freeContexts freeLargeContexts interruptCheckCounter totalObjectCount shrinkThreshold growHeadroom headerTypeBytes youngStartLocal statMarkCount statMarkCountLocal statSweepCount statMkFwdCount statCompMoveCount statGrowMemory statShrinkMemory statRootTableCount statAllocationCount statSurvivorCount statSpecialMarkCount forceTenureFlag gcStartUsecs'
- 	instanceVariableNames: 'memory youngStart endOfMemory memoryLimit nilObj falseObj trueObj specialObjectsOop rootTable rootTableCount extraRoots extraRootCount weakRoots weakRootCount child field parentField freeBlock lastHash allocationCount lowSpaceThreshold signalLowSpace compStart compEnd fwdTableNext fwdTableLast remapBuffer remapBufferCount allocationsBetweenGCs tenuringThreshold gcBiasToGrow gcBiasToGrowGCLimit gcBiasToGrowThreshold statFullGCs statIncrGCs statFullGCUsecs statIncrGCUsecs statGCEndTime statIGCDeltaUsecs statTenures statRootTableOverflows freeContexts freeLargeContexts interruptCheckCounter totalObjectCount shrinkThreshold growHeadroom headerTypeBytes youngStartLocal statMarkCount statMarkCountLocal statSweepCount statMkFwdCount statCompMoveCount statGrowMemory statShrinkMemory statRootTableCount statAllocationCount statSurvivorCount statSpecialMarkCount forceTenureFlag gcStartUsecs'
  	classVariableNames: 'AllButHashBits AllButImmutabilityBit AllButMarkBit AllButMarkBitAndTypeMask AllButRootBit Done ExtraRootSize GCTopMarker HashBits HeaderTypeClass HeaderTypeExtraBytes HeaderTypeFree HeaderTypeGC LongSizeNumBits NilContext RemapBufferSize RootTableRedZone RootTableSize StartField StartObj Upward WeakRootTableSize WordMask'
  	poolDictionaries: 'VMBasicConstants VMObjectIndices VMSqueakV3BytecodeConstants VMSqueakV3ObjectRepresentationConstants'
  	category: 'VMMaker-Interpreter'!
  
  !ObjectMemory commentStamp: '<historical>' prior: 0!
  This class describes a 32-bit direct-pointer object memory for Smalltalk.  The model is very simple in principle:  a pointer is either a SmallInteger or a 32-bit direct object pointer.
  
  SmallIntegers are tagged with a low-order bit equal to 1, and an immediate 31-bit 2s-complement signed value in the rest of the word.
  
  All object pointers point to a header, which may be followed by a number of data fields.  This object memory achieves considerable compactness by using a variable header size (the one complexity of the design).  The format of the 0th header word is as follows:
  
  	3 bits	reserved for gc (mark, root, unused)
  	12 bits	object hash (for HashSets)
  	5 bits	compact class index
  	4 bits	object format
  	6 bits	object size in 32-bit words
  	2 bits	header type (0: 3-word, 1: 2-word, 2: forbidden, 3: 1-word)
  
  If a class is in the compact class table, then this is the only header information needed.  If it is not, then it will have another header word at offset -4 bytes with its class in the high 30 bits, and the header type repeated in its low 2 bits.  It the objects size is greater than 255 bytes, then it will have yet another header word at offset -8 bytes with its full word size in the high 30 bits and its header type repeated in the low two bits.
  
  The object format field provides the remaining information as given in the formatOf: method (including isPointers, isVariable, isBytes, and the low 2 size bits of byte-sized objects).
  
  This implementation includes incremental (2-generation) and full garbage collection, each with compaction and rectification of direct pointers.  It also supports a bulk-become (exchange object identity) feature that allows many objects to be becomed at once, as when all instances of a class must be grown or shrunk.
  
  There is now a simple 64-bit version of the object memory.  It is the simplest possible change that could work.  It merely sign-extends all integer oops, and extends all object headers and oops by adding 32 zeroes in the high bits.  The format of the base header word is changed in one minor, not especially elegant, way.  Consider the old 32-bit header:
  	ggghhhhhhhhhhhhcccccffffsssssstt
  The 64-bit header is almost identical, except that the size field (now being in units of 8 bytes, has a zero in its low-order bit.  At the same time, the byte-size residue bits for byte objects, which are in the low order bits of formats 8-11 and 12-15, are now in need of another bit of residue.  So, the change is as follows:
  	ggghhhhhhhhhhhhcccccffffsssssrtt
  where bit r supplies the 4's bit of the byte size residue for byte objects.  Oh, yes, this is also needed now for 'variableWord' objects, since their size in 32-bit words requires a low-order bit.
  
  See the comment in formatOf: for the change allowing for 64-bit wide bitmaps, now dubbed 'variableLong'.!

Item was changed:
  ----- Method: ObjectMemory>>beRootWhileForwarding: (in category 'gc -- compaction') -----
  beRootWhileForwarding: oop
  	"Record that the given oop in the old object area points to an object in the young area when oop may be forwarded."
  	"Warning: No young objects should be recorded as roots. Callers are responsible for ensuring this constraint is not violated."
+ 	<inline: false> "for debugging..."
+ 	| header fwdBlock headerLoc |
- 
- 	| header fwdBlock |
  	"If labelled, gcc duplicates the label when inlining updatePointersInRangeFrom:to:"
+ 	<asmLabel: false>
- 	<asmLabel: false> 
  	header := self longAt: oop.
  	(header bitAnd: MarkBit) ~= 0
+ 		ifTrue: "This oop is forwarded"
+ 			[fwdBlock := (header bitAnd: AllButMarkBitAndTypeMask) << 1.
+ 			self assert: (self fwdBlockValid: fwdBlock).
+ 			headerLoc := fwdBlock + BytesPerWord]
+ 		ifFalse: "Normal -- no forwarding"
+ 			[headerLoc := oop].
+ 	"use headerLoc var to eliminate duplication on inlining noteAsRoot:headerLoc:
+ 	 older versions of this method had two separate sends of noteAsRoot:headerLoc:"
+ 	self noteAsRoot: oop headerLoc: headerLoc!
- 		ifTrue: ["This oop is forwarded"
- 				fwdBlock := (header bitAnd: AllButMarkBitAndTypeMask) << 1.
- 				self assert: (self fwdBlockValid: fwdBlock).
- 				self noteAsRoot: oop headerLoc: fwdBlock + BytesPerWord]
- 		ifFalse: ["Normal -- no forwarding"
- 				self noteAsRoot: oop headerLoc: oop]!

Item was changed:
  ----- Method: ObjectMemory>>checkHeapIntegrity (in category 'memory access') -----
  checkHeapIntegrity
  	"Perform an integrity/leak check using the heapMap.  Assume
  	 clearLeakMapAndMapAccessibleObjects has set a bit at each
  	 object's header.  Scan all objects in the heap checking that every
  	 pointer points to a header.  Scan the rootTable, remapBuffer and
  	 extraRootTable checking that every entry is a pointer to a header.
  	 Check that the number of roots is correct and that all rootTable
  	 entries have their rootBit set. Answer if all checks pass."
  	| ok obj sz hdr fmt fi fieldOop numRootsInHeap |
  	<inline: false>
  	ok := true.
  	numRootsInHeap := 0.
  	obj := self firstObject.
  	[self oop: obj isLessThan: self startOfFreeSpace] whileTrue:
  		[(self isFreeObject: obj)
  			ifTrue:
  				[sz := self sizeOfFree: obj]
  			ifFalse:
  				[hdr := self baseHeader: obj.
  				 (self isYoungRootHeader: hdr) ifTrue:
  					[numRootsInHeap := numRootsInHeap + 1].
  				 (self compactClassIndexOfHeader: hdr) = 0 ifTrue:
  					[fieldOop := (self classHeader: obj) bitAnd: AllButTypeMask.
  					 ((self isIntegerObject: fieldOop)
  					   or: [(self heapMapAtWord: (self pointerForOop: fieldOop)) = 0]) ifTrue:
  						[self print: 'object leak in '; printHex: obj; print: ' class = '; printHex: fieldOop; cr.
  						 ok := false]].
  				 fmt := self formatOfHeader: hdr.
  				 (fmt <= 4 "pointers" or: [fmt >= 12 "compiled method"]) ifTrue:
  					[fmt >= 12
  						ifTrue: [fi := (self literalCountOf: obj) + 1 "+ 1 = methodHeader slot"]
  						ifFalse: [(fmt = 3 and: [self isContextHeader: hdr])
  									ifTrue: [fi := CtxtTempFrameStart + (self fetchStackPointerOf: obj)]
  									ifFalse: [fi := self lengthOf: obj]].
  					[(fi := fi - 1) >= 0] whileTrue:
  						[fieldOop := self fetchPointer: fi ofObject: obj.
  						 (self isNonIntegerObject: fieldOop) ifTrue:
  							[(fieldOop bitAnd: BytesPerWord - 1) ~= 0
  								ifTrue:
  									[self print: 'misaligned oop in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; cr.
  									 ok := false]
  								ifFalse:
  									[(self heapMapAtWord: (self pointerForOop: fieldOop)) = 0 ifTrue:
  										[self print: 'object leak in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; cr.
  										 ok := false]]]]].
  				 sz := self sizeBitsOf: obj].
  		 obj := self oopFromChunk: obj + sz].
  	numRootsInHeap ~= rootTableCount ifTrue:
  		[self print: 'root count mismatch. #heap roots '; printNum: numRootsInHeap; print: '; #roots '; printNum: rootTableCount; cr.
+ 		"But the system copes with overflow..."
+ 		ok := rootTableOverflowed and: [allocationCount > allocationsBetweenGCs]].
- 		 ok := false].
  	1 to: rootTableCount do:
  		[:ri|
  		obj := rootTable at: ri.
  		(obj bitAnd: BytesPerWord - 1) ~= 0
  			ifTrue:
  				[self print: 'misaligned oop in rootTable @ '; printNum: ri; print: ' = '; printHex: obj; cr.
  				 ok := false]
  			ifFalse:
  				[(self heapMapAtWord: (self pointerForOop: obj)) = 0
  					ifTrue:
  						[self print: 'object leak in rootTable @ '; printNum: ri; print: ' = '; printHex: obj; cr.
  						 ok := false]
  					ifFalse:
  						[hdr := self baseHeader: obj.
  						 (self isYoungRootHeader: hdr) ifFalse:
  							[self print: 'non-root in rootTable @ '; printNum: ri; print: ' = '; printHex: obj; cr.
  							 ok := false]]]].
  	1 to: remapBufferCount do:
  		[:ri|
  		obj := remapBuffer at: ri.
  		(obj bitAnd: BytesPerWord - 1) ~= 0
  			ifTrue:
  				[self print: 'misaligned remapRoot @ '; printNum: ri; print: ' = '; printHex: obj; cr.
  				 ok := false]
  			ifFalse:
  				[(self heapMapAtWord: (self pointerForOop: obj)) = 0
  					ifTrue:
  						[self print: 'object leak in remapRoots @ '; printNum: ri; print: ' = '; printHex: obj; cr.
  						 ok := false]]].
  	1 to: extraRootCount do:
  		[:ri|
  		obj := (extraRoots at: ri) at: 0.
  		(obj bitAnd: BytesPerWord - 1) ~= 0
  			ifTrue:
  				[self print: 'misaligned extraRoot @ '; printNum: ri; print: ' => '; printHex: obj; cr.
  				 ok := false]
  			ifFalse:
  				[(self heapMapAtWord: (self pointerForOop: obj)) = 0
  					ifTrue:
  						[self print: 'object leak in extraRoots @ '; printNum: ri; print: ' => '; printHex: obj; cr.
  						 ok := false]]].
  	^ok!

Item was added:
+ ----- Method: ObjectMemory>>checkOkayYoungReferrer: (in category 'debug support') -----
+ checkOkayYoungReferrer: obj
+ 	"Verify that the given obj is a valid youngReferrer. Check RootBit is set and
+ 	 is in rootTable.  Answer true if OK.  Otherwise print reason and answer false.
+ 	 Assumes the object contains young references."
+ 
+ 	(self oop: obj isGreaterThanOrEqualTo: youngStart) ifTrue:
+ 		[^true].
+ 
+ 	(self isYoungRoot: obj) ifFalse:
+ 		[ self print: 'root bit is not set in '; printHex: obj; cr. ^false ].
+ 
+ 	1 to: rootTableCount do:
+ 		[:i| obj = (rootTable at: i) ifTrue: [^true]].
+ 
+ 	self printHex: obj; print: ' has root bit set but is not in rootTable'; cr.
+ 
+ 	^false
+ !

Item was changed:
  ----- Method: ObjectMemory>>clearRootsTable (in category 'garbage collection') -----
  clearRootsTable
+ 	"Clear the root bits of the current roots, then empty the roots table. "
+ 	"Caution: This should only be done when the young object space is empty."
+ 	"reset the roots table (after this, all objects are old so there are no roots)"
+ 	1 to: rootTableCount do:
+ 		[:i | | oop |
+ 		oop := rootTable at: i.
+ 		self longAt: oop put: ((self longAt: oop) bitAnd: AllButRootBit).
+ 		rootTable at: i put: 0].
+ 	rootTableCount := 0.
+ 	rootTableOverflowed := false.!
- 	"Clear the root bits of the current roots, then empty the roots 
- 	table. "
- 	"Caution: This should only be done when the young object 
- 	space is empty."
- 	"reset the roots table (after this, all objects are old so there 
- 	are no roots)"
- 	| oop |
- 	1 to: rootTableCount do: [:i | 
- 			"clear root bits of current root table entries"
- 			oop := rootTable at: i.
- 			self longAt: oop put: ((self longAt: oop) bitAnd: AllButRootBit).
- 			rootTable at: i put: 0].
- 	rootTableCount := 0!

Item was changed:
  ----- Method: ObjectMemory>>incrementalGC (in category 'garbage collection') -----
  incrementalGC
  	"Do a mark/sweep garbage collection of just the young object 
  	area of object memory (i.e., objects above youngStart), using 
  	the root table to identify objects containing pointers to 
  	young objects from the old object area."
  	| survivorCount weDidGrow |
  	<inline: false>
+ 	rootTableOverflowed ifTrue:
+ 		["root table overflow; cannot do an incremental GC because some roots are missing.
+ 		 (this should be very rare)"
+ 		 statRootTableOverflows := statRootTableOverflows + 1.
+ 		 ^self fullGC].
- 	rootTableCount >= RootTableSize
- 		ifTrue: ["root table overflow; cannot do an incremental GC (this should be very rare)"
- 			statRootTableOverflows := statRootTableOverflows + 1.
- 			^ self fullGC].
  
  	DoAssertionChecks ifTrue:
  		[self reverseDisplayFrom: 8 to: 15.
  		 self checkHeapIntegrity.
  		 self checkInterpreterIntegrity.
  		 self validate].
  
  	self preGCAction: GCModeIncr.
  	"incremental GC and compaction"
  
  	gcStartUsecs := self ioUTCMicrosecondsNow.
  	statSweepCount := statMarkCount := statMkFwdCount := statCompMoveCount := 0.
  	self initWeakTableForIncrementalGC: true.
  	self markPhase.
  	self assert: weakRootCount <= WeakRootTableSize.
  	1 to: weakRootCount do:[:i| self finalizeReference: (weakRoots at: i)].
  	survivorCount := self sweepPhase.
  	self incrementalCompaction.
  	statAllocationCount := allocationCount.
  	allocationCount := 0.
  	statIncrGCs := statIncrGCs + 1.
  	statGCEndTime := self ioMicroMSecs.
  	statIGCDeltaUsecs := self ioUTCMicrosecondsNow - gcStartUsecs.
  	statIncrGCUsecs := statIncrGCUsecs + statIGCDeltaUsecs.
  	self capturePendingFinalizationSignals.
  
  	self forceInterruptCheck. "Force an an interrupt check ASAP.We could choose to be clever here and only do this under certain time conditions. Keep it simple for now"
  	
  	statRootTableCount  := rootTableCount.
  	statSurvivorCount := survivorCount.
  	weDidGrow := false.
  	(((survivorCount > tenuringThreshold)
  			or: [rootTableCount >= RootTableRedZone])
  			or: [forceTenureFlag == true])
  		ifTrue: ["move up the young space boundary if 
  			* there are too many survivors: 
  			this limits the number of objects that must be 
  			processed on future incremental GC's 
  			* we're about to overflow the roots table 
  			this limits the number of full GCs that may be caused 
  			by root table overflows in the near future"
  			forceTenureFlag := false.
  			statTenures := statTenures + 1.
  			self clearRootsTable.
  			(((self sizeOfFree: freeBlock) < growHeadroom) and: 
  				[gcBiasToGrow > 0]) 
  				ifTrue: [self biasToGrow.
  						weDidGrow := true].
  			youngStart := freeBlock].
  	self postGCAction.
  	DoAssertionChecks ifTrue:
  		[self validate.
  		 self checkHeapIntegrity.
  		 self checkInterpreterIntegrity.
  		 self reverseDisplayFrom: 8 to: 15].
  	weDidGrow ifTrue: [self biasToGrowCheckGCLimit]!

Item was changed:
  ----- Method: ObjectMemory>>initializeObjectMemory: (in category 'initialization') -----
  initializeObjectMemory: bytesToShift
  	"Initialize object memory variables at startup time. Assume endOfMemory is initially set (by the image-reading code) to the end of the last object in the image. Initialization redefines endOfMemory to be the end of the object allocation area based on the total available memory, but reserving some space for forwarding blocks."
  	"Assume: image reader initializes the following variables:
  		memory
  		endOfMemory
  		memoryLimit
  		specialObjectsOop
  		lastHash
  	"
  	"di 11/18/2000 fix slow full GC"
  	<inline: false>
  
  	"set the start of the young object space"
  	youngStart := endOfMemory.
  
  	"image may be at a different address; adjust oops for new location"
  	totalObjectCount := self adjustAllOopsBy: bytesToShift.
  
  	self initializeMemoryFirstFree: endOfMemory. "initializes endOfMemory, freeBlock"
  
  	specialObjectsOop := specialObjectsOop + bytesToShift.
  
  	"heavily used special objects"
  	nilObj	:= self splObj: NilObject.
  	falseObj	:= self splObj: FalseObject.
  	trueObj	:= self splObj: TrueObject.
  
  	rootTableCount := 0.
+ 	rootTableOverflowed := false.
  	freeContexts := NilContext.
  	freeLargeContexts := NilContext.
  	allocationCount := 0.
  	lowSpaceThreshold := 0.
  	signalLowSpace := false.
  	compStart := 0.
  	compEnd := 0.
  	fwdTableNext := 0.
  	fwdTableLast := 0.
  	remapBufferCount := 0.
  	allocationsBetweenGCs := 4000.  "do incremental GC after this many allocations"
  	tenuringThreshold := 2000.  "tenure all suriving objects if count is over this threshold"
  	growHeadroom := 4*1024*1024. "four megabyte of headroom when growing"
  	shrinkThreshold := 8*1024*1024. "eight megabyte of free space before shrinking"
  
  	"garbage collection statistics"
  	statFullGCs := 0.
  	statFullGCUsecs := 0.
  	statIncrGCs := 0.
  	statIncrGCUsecs := 0.
  	statTenures := 0.
  	statRootTableOverflows := 0.
  	statGrowMemory := 0.
  	statShrinkMemory := 0.
  	forceTenureFlag := 0.
  	gcBiasToGrow := 0.
  	gcBiasToGrowGCLimit := 0.
  	extraRootCount := 0.
  	gcStartUsecs := 0!

Item was changed:
  ----- Method: ObjectMemory>>noteAsRoot:headerLoc: (in category 'garbage collection') -----
  noteAsRoot: oop headerLoc: headerLoc 
+ 	"Record that the given oop in the old object area points to an object in the young area.
+ 	 HeaderLoc is usually = oop, but may be an addr in a forwarding block."
- 	"Record that the given oop in the old object area points to an 
- 	object in the young area. 
- 	HeaderLoc is usually = oop, but may be an addr in a 
- 	forwarding block."
  	| header |
  	<inline: true>
  	<asmLabel: false> 
  	header := self longAt: headerLoc.
  	(self isYoungRootHeader: header) ifFalse:
+ 		"record oop as root only if not already recorded"
+ 		[rootTableCount < RootTableSize
+ 			ifTrue:
+ 				"record root if there is enough room in the roots table.
+ 				 IMPORTANT: since clearRootsTable is the only thing that clears root bits
+ 				 do *not* set the root bit unless an object is in the root table.  checking
+ 				 routines will complain about the root bit being unset instead of the table
+ 				 being full, but that's life"
+ 				[rootTableCount := rootTableCount + 1.
+ 				 rootTable at: rootTableCount put: oop.
+ 				 self longAt: headerLoc put: (header bitOr: RootBit).
+ 				 rootTableCount >= RootTableRedZone ifTrue:
+ 					"if we're now in the red zone force an IGC ASAP"
+ 					[allocationCount := allocationsBetweenGCs + 1]]
+ 			ifFalse: "note overflow; will need to do a fullGC instead of an incremental."
+ 				[rootTableOverflowed := true]]!
- 		["record oop as root only if not already recorded"
- 		rootTableCount < RootTableRedZone
- 			ifTrue: ["record root if there is enough room in the roots table "
- 				rootTableCount := rootTableCount + 1.
- 				rootTable at: rootTableCount put: oop.
- 				self longAt: headerLoc put: (header bitOr: RootBit)]
- 			ifFalse: ["we're getting in the red zone"
- 				rootTableCount < RootTableSize
- 					ifTrue: ["but there's still space to record it"
- 						rootTableCount := rootTableCount + 1.
- 						rootTable at: rootTableCount put: oop.
- 						self longAt: headerLoc put: (header bitOr: RootBit).
- 						"but force an IGC on the next allocation"
- 						allocationCount := allocationsBetweenGCs + 1]]]!

Item was changed:
  ----- Method: ObjectMemory>>removeYoungRoot: (in category 'become') -----
  removeYoungRoot: obj
+ 	"Remove the given young root from the root table (for freeObject: for becomeForward:)."
- 	"Remove the given young root form the root table (for freeObject: for becomeForward:)."
  	<inline: false>
  	1 to: rootTableCount do:
  		[:i|
  		obj = (rootTable at: i) ifTrue:"swap obj with last entry"
  			[rootTable at: i put: (rootTable at: rootTableCount).
+ 			rootTableCount := rootTableCount - 1.
- 			rootTableCount := rootTableCount-1.
  			^true]].
  	^false "not found"!

Item was removed:
- ----- Method: ObjectMemory>>rootTable: (in category 'accessing') -----
- rootTable: aValue
- 	^rootTable := aValue!

Item was added:
+ ----- Method: ObjectMemory>>rootTableObject (in category 'primitive support') -----
+ rootTableObject
+ 	"Answer an object containing the contents of the rootTable for primitiveRootTable.
+ 	 The allocation can cause a GC itself and if so the return value may be inaccurate
+ 	 - in this case one should guard the read operation by looking at the gc counter statistics."
+ 	| tableObj sz j |
+ 	sz := rootTableCount.
+ 	tableObj := self instantiateClass: self classArray indexableSize: sz. "can cause GC (and hence reduce number of roots)"
+ 	j := 0.
+ 	1 to: rootTableCount do:
+ 		[:i| "By definition the roots are old and being new, tableObj is young so there is no need to store check."
+ 		self storePointerUnchecked: j ofObject: tableObj withValue: (rootTable at: i)].
+ 	rootTableCount < sz ifTrue:
+ 		[self shorten: tableObj toIndexableSize: rootTableCount].
+ 	^tableObj!

Item was added:
+ ----- Method: StackInterpreter>>checkAllAccessibleObjectsOkay (in category 'debug support') -----
+ checkAllAccessibleObjectsOkay
+ 	"Ensure that all accessible objects in the heap are okay."
+ 	<api>
+ 	| ok oop |
+ 	ok := true.
+ 	oop := objectMemory firstAccessibleObject.
+ 	[oop = nil] whileFalse:
+ 		[ok := ok & (self checkOkayFields: oop).
+ 		oop := objectMemory accessibleObjectAfter: oop].
+ 	^ok!

Item was changed:
  ----- Method: StackInterpreter>>checkForEventsMayContextSwitch: (in category 'process primitive support') -----
  checkForEventsMayContextSwitch: mayContextSwitch
  	"Check for possible interrupts and handle one if necessary.
  	 Answer if a context switch has occurred."
  	| switched sema now |
  	<inline: false>
  	<var: #now type: #usqLong>
  	statCheckForEvents := statCheckForEvents + 1.
  
  	"restore the stackLimit if it has been smashed."
  	self restoreStackLimit.
  	self externalWriteBackHeadFramePointers.
  	self assert: stackPage = stackPages mostRecentlyUsedPage.
  
  	"Allow the platform to do anything it needs to do synchronously."
  	self ioSynchronousCheckForEvents.
  
  	self checkCogCompiledCodeCompactionCalledFor.
  
  	objectMemory needGCFlag ifTrue:
+ 		["sufficientSpaceAfterGC: runs the incremental GC and
- 		[objectMemory needGCFlag: false.
- 		"sufficientSpaceAfterGC: runs the incremental GC and
  		 then, if not enough space is available, the fullGC."
  		 (objectMemory sufficientSpaceAfterGC: 0) ifFalse:
  			[self setSignalLowSpaceFlagAndSaveProcess]].
  
  	mayContextSwitch ifFalse: [^false].
  
  	switched := false.
  
  	(profileProcess ~= objectMemory nilObject
  	 or: [nextProfileTick > 0 and:[self ioHighResClock >= nextProfileTick]]) ifTrue:
  		["Take a sample (if not already done so) for the profiler if it is active.  This
  		  must be done before any of the synchronousSignals below or else we will
  		  attribute a pause in ioRelinquishProcessor to the newly activated process."
  		profileProcess = objectMemory nilObject ifTrue:
  			[profileProcess := self activeProcess.
  			 profileMethod := objectMemory nilObject].
  		"and signal the profiler semaphore if it is present"
  		(profileSemaphore ~= objectMemory nilObject 
  		 and: [self synchronousSignal: profileSemaphore]) ifTrue:
  			[switched := true].
  		nextProfileTick := 0].
  
  	self checkDeliveryOfLongRunningPrimitiveSignal ifTrue:
  		[switched := true].
  
  	objectMemory signalLowSpace ifTrue:
  		[objectMemory signalLowSpace: false. "reset flag"
  		 sema := objectMemory splObj: TheLowSpaceSemaphore.
  		 (sema ~= objectMemory nilObject 
  		  and: [self synchronousSignal: sema]) ifTrue:
  			[switched := true]].
  
  	"inIOProcessEvents prevents reentrancy into ioProcessEvents and allows disabling
  	 ioProcessEvents e.g. for native GUIs.  We would like to manage that here but can't
  	 since the platform code may choose to call ioProcessEvents itself in various places."
  	false
  		ifTrue:
  			[((now := self ioUTCMicroseconds) >= nextPollUsecs
  			 and: [inIOProcessEvents = 0]) ifTrue:
  				[statIOProcessEvents := statIOProcessEvents + 1.
  				 inIOProcessEvents := inIOProcessEvents + 1.
  				 self ioProcessEvents. "sets interruptPending if interrupt key pressed; may callback"
  				 inIOProcessEvents > 0 ifTrue:
  					[inIOProcessEvents := inIOProcessEvents - 1].
  				 nextPollUsecs := now + 20000
  				 "msecs to wait before next call to ioProcessEvents.  Note that strictly
  				  speaking we might need to update 'now' at this point since
  				  ioProcessEvents could take a very long time on some platforms"]]
  		ifFalse:
  			[(now := self ioUTCMicroseconds) >= nextPollUsecs ifTrue:
  				[statIOProcessEvents := statIOProcessEvents + 1.
  				 self ioProcessEvents. "sets interruptPending if interrupt key pressed; may callback"
  				 nextPollUsecs := now + 20000
  				 "msecs to wait before next call to ioProcessEvents.  Note that strictly
  				  speaking we might need to update 'now' at this point since
  				  ioProcessEvents could take a very long time on some platforms"]].
  
  	interruptPending ifTrue:
  		[interruptPending := false.
  		 "reset interrupt flag"
  		 sema := objectMemory splObj: TheInterruptSemaphore.
  		 (sema ~= objectMemory nilObject 
  		  and: [self synchronousSignal: sema]) ifTrue:
  			[switched := true]].
  
  	nextWakeupUsecs ~= 0 ifTrue:
  		[now >= nextWakeupUsecs ifTrue:
  			[nextWakeupUsecs := 0.
  			 "set timer interrupt to 0 for 'no timer'"
  			 sema := objectMemory splObj: TheTimerSemaphore.
  			 (sema ~= objectMemory nilObject 
  			  and: [self synchronousSignal: sema]) ifTrue:
  				[switched := true]]].
  
  	"signal any pending finalizations"
  	pendingFinalizationSignals > 0 ifTrue:
  		[sema := objectMemory splObj: TheFinalizationSemaphore.
  		 ((objectMemory isClassOfNonImm: sema equalTo: (objectMemory splObj: ClassSemaphore))
  		  and: [self synchronousSignal: sema]) ifTrue:
  			[switched := true].
  		pendingFinalizationSignals := 0].
  
  	"signal all semaphores in semaphoresToSignal"
  	self signalExternalSemaphores ifTrue:
  		[switched := true].
  
  	^switched!

Item was added:
+ ----- Method: StackInterpreter>>checkOkayFields: (in category 'debug support') -----
+ checkOkayFields: oop
+ 	"Check if the argument is an ok object.
+ 	 If this is a pointers object, check that its fields are all okay oops."
+ 
+ 	| hasYoung i fieldOop |
+ 	(oop = nil or: [oop = 0]) ifTrue: [ ^true ]. "?? eem 1/16/2013"
+ 	(objectMemory isIntegerObject: oop) ifTrue: [ ^true ].
+ 	(objectMemory checkOkayOop: oop) ifFalse: [ ^false ].
+ 	(self checkOopHasOkayClass: oop) ifFalse: [ ^false ].
+ 	hasYoung := objectMemory isYoung: (objectMemory fetchClassOfNonInt: oop).
+ 	((objectMemory isPointers: oop) or: [objectMemory isCompiledMethod: oop]) ifTrue:
+ 		[(objectMemory isCompiledMethod: oop)
+ 			ifTrue:
+ 				[i := (self literalCountOf: oop) - 1]
+ 			ifFalse:
+ 				[(self isContext: oop)
+ 					ifTrue: [i := CtxtTempFrameStart + (self fetchStackPointerOf: oop) - 1]
+ 					ifFalse: [i := (objectMemory lengthOf: oop) - 1]].
+ 		[i >= 0] whileTrue:
+ 			[fieldOop := objectMemory fetchPointer: i ofObject: oop.
+ 			(objectMemory isIntegerObject: fieldOop) ifFalse:
+ 				[hasYoung := hasYoung or: [objectMemory isYoung: fieldOop].
+ 				(objectMemory checkOkayOop: fieldOop) ifFalse: [ ^false ].
+ 				(self checkOopHasOkayClass: fieldOop) ifFalse: [ ^false ]].
+ 			i := i - 1]].
+ 	hasYoung ifTrue:
+ 		[^objectMemory checkOkayYoungReferrer: oop].
+ 	^true!

Item was added:
+ ----- Method: StackInterpreter>>checkOkayInterpreterObjects: (in category 'debug support') -----
+ checkOkayInterpreterObjects: writeBack
+ 	<api>
+ 	| ok oopOrZero oop |
+ 	ok := true.
+ 	ok := ok & (self checkOkayFields: objectMemory nilObject).
+ 	ok := ok & (self checkOkayFields: objectMemory falseObject).
+ 	ok := ok & (self checkOkayFields: objectMemory trueObject).
+ 	ok := ok & (self checkOkayFields: objectMemory specialObjectsOop).
+ 	ok := ok & (self checkOkayFields: messageSelector).
+ 	ok := ok & (self checkOkayFields: newMethod).
+ 	ok := ok & (self checkOkayFields: lkupClass).
+ 	0 to: MethodCacheEntries - 1 by: MethodCacheEntrySize do:
+ 		[ :i |
+ 		oopOrZero := methodCache at: i + MethodCacheSelector.
+ 		oopOrZero = 0 ifFalse:
+ 			[ok := ok & (self checkOkayFields: (methodCache at: i + MethodCacheSelector)).
+ 			ok := ok & (self checkOkayFields: (methodCache at: i + MethodCacheClass)).
+ 			ok := ok & (self checkOkayFields: (methodCache at: i + MethodCacheMethod))]].
+ 	1 to: objectMemory remapBufferCount do:
+ 		[ :i |
+ 		oop := objectMemory remapBuffer at: i.
+ 		(objectMemory isIntegerObject: oop) ifFalse:
+ 			[ok := ok & (self checkOkayFields: oop)]].
+ 	ok := ok & (self checkOkayStackZone: writeBack).
+ 	^ok!

Item was added:
+ ----- Method: StackInterpreter>>checkOkayStackPage: (in category 'debug support') -----
+ checkOkayStackPage: thePage
+ 	| theSP theFP ok frameRcvrOffset callerFP oop |
+ 	<var: #thePage type: #'StackPage *'>
+ 	<var: #theSP type: #'char *'>
+ 	<var: #theFP type: #'char *'>
+ 	<var: #frameRcvrOffset type: #'char *'>
+ 	<var: #callerFP type: #'char *'>
+ 	<inline: false>
+ 	theSP := thePage headSP.
+ 	theFP := thePage  headFP.
+ 	ok := true.
+ 	"Skip the instruction pointer on top of stack of inactive pages."
+ 	thePage = stackPage ifFalse:
+ 		[theSP := theSP + BytesPerWord].
+ 	[frameRcvrOffset := self frameReceiverOffset: theFP.
+ 	 [theSP <= frameRcvrOffset] whileTrue:
+ 		[oop := stackPages longAt: theSP.
+ 		 (objectMemory isIntegerObject: oop) ifFalse:
+ 			[ok := ok & (self checkOkayFields: oop)].
+ 		 theSP := theSP + BytesPerWord].
+ 	(self frameHasContext: theFP) ifTrue:
+ 		[self assert: (self isContext: (self frameContext: theFP)).
+ 		 ok := ok & (self checkOkayFields: (self frameContext: theFP))].
+ 	ok := ok & (self checkOkayFields: (self frameMethodObject: theFP)).
+ 	(callerFP := self frameCallerFP: theFP) ~= 0] whileTrue:
+ 		[theSP := theFP + FoxCallerSavedIP + BytesPerWord.
+ 		 theFP := callerFP].
+ 	theSP := self isCog
+ 				ifTrue: [theFP + FoxCallerSavedIP + BytesPerWord] "caller ip is ceBaseReturnPC"
+ 				ifFalse: [theFP + FoxCallerSavedIP]. "caller ip is frameCallerContext in a base frame"
+ 	[theSP <= thePage baseAddress] whileTrue:
+ 		[oop := stackPages longAt: theSP.
+ 		 (objectMemory isIntegerObject: oop) ifFalse:
+ 			[ok := ok & (self checkOkayFields: oop)].
+ 		 theSP := theSP + BytesPerWord].
+ 	^ok!

Item was added:
+ ----- Method: StackInterpreter>>checkOkayStackZone: (in category 'debug support') -----
+ checkOkayStackZone: writeBack
+ 	"Check that all objects in the stack zone are okay"
+ 	| ok thePage |
+ 	<var: #thePage type: #'StackPage *'>
+ 	<inline: false>
+ 	writeBack ifTrue:
+ 		[self externalWriteBackHeadFramePointers].
+ 	ok := true.
+ 
+ 	0 to: numStackPages - 1 do:
+ 		[:i|
+ 		thePage := stackPages stackPageAt: i.
+ 		(stackPages isFree: thePage) ifFalse:
+ 			[ok := ok & (self checkOkayStackPage: thePage)]].
+ 
+ 	^ok!

Item was changed:
  ----- Method: StackInterpreter>>checkOopHasOkayClass: (in category 'debug support') -----
+ checkOopHasOkayClass: obj
+ 	"Attempt to verify that the given obj has a reasonable behavior. The class must be a
+ 	 valid, non-integer oop and must not be nilObj. It must be a pointers object with three
+ 	 or more fields. Finally, the instance specification field of the behavior must match that
+ 	 of the instance. If OK answer true.  If  not, print reason and answer false."
- checkOopHasOkayClass: oop
- 	"Attempt to verify that the given oop has a reasonable behavior. The class must be a valid, non-integer oop and must not be nilObj. It must be a pointers object with three or more fields. Finally, the instance specification field of the behavior must match that of the instance. If OK answer true.  If  not, print reason and answer false."
  
  	<api>
  	<var: #oop type: #usqInt>
+ 	| objClass formatMask behaviorFormatBits objFormatBits |
- 	| oopClass formatMask behaviorFormatBits oopFormatBits |
  	<var: #oopClass type: #usqInt>
  
+ 	(objectMemory checkOkayOop: obj) ifFalse:
- 	(objectMemory checkOkayOop: oop) ifFalse:
  		[^false].
+ 	objClass := self cCoerce: (objectMemory fetchClassOfNonInt: obj) to: #usqInt.
- 	oopClass := self cCoerce: (objectMemory fetchClassOf: oop) to: #usqInt.
  
+ 	(objectMemory isIntegerObject: objClass) ifTrue:
+ 		[self print: 'obj '; printHex: obj; print: ' a SmallInteger is not a valid class or behavior'; cr. ^false].
+ 	(objectMemory okayOop: objClass) ifFalse:
+ 		[self print: 'obj '; printHex: obj; print: ' class obj is not ok'; cr. ^false].
+ 	((objectMemory isPointers: objClass) and: [(objectMemory lengthOf: objClass) >= 3]) ifFalse:
+ 		[self print: 'obj '; printHex: obj; print: ' a class (behavior) must be a pointers object of size >= 3'; cr. ^false].
+ 	formatMask := (objectMemory isBytes: obj)
- 	(objectMemory isIntegerObject: oopClass) ifTrue:
- 		[self print: 'a SmallInteger is not a valid class or behavior'; cr. ^false].
- 	(objectMemory okayOop: oopClass) ifFalse:
- 		[self print: 'class oop is not ok'; cr. ^false].
- 	((objectMemory isPointers: oopClass) and: [(objectMemory lengthOf: oopClass) >= 3]) ifFalse:
- 		[self print: 'a class (behavior) must be a pointers object of size >= 3'; cr. ^false].
- 	formatMask := (objectMemory isBytes: oop)
  						ifTrue: [16rC00]  "ignore extra bytes size bits"
  						ifFalse: [16rF00].
  
+ 	behaviorFormatBits := (objectMemory formatOfClass: objClass) bitAnd: formatMask.
+ 	objFormatBits := (objectMemory baseHeader: obj) bitAnd: formatMask.
+ 	behaviorFormatBits = objFormatBits ifFalse:
+ 		[self print: 'obj '; printHex: obj; print: ' and its class (behavior) formats differ'; cr. ^false].
- 	behaviorFormatBits := (objectMemory formatOfClass: oopClass) bitAnd: formatMask.
- 	oopFormatBits := (objectMemory baseHeader: oop) bitAnd: formatMask.
- 	behaviorFormatBits = oopFormatBits ifFalse:
- 		[self print: 'object and its class (behavior) formats differ'; cr. ^false].
  	^true!

Item was changed:
  ----- Method: StackInterpreter>>ensureImageFormatIsUpToDate: (in category 'image save/restore') -----
  ensureImageFormatIsUpToDate: swapBytes
  	"Ensure the image data has been updayed to suit the current VM."
  	<inline: false>
  	swapBytes
  		ifTrue: [self reverseBytesInImage]
+ 		ifFalse: [self convertFloatsToPlatformOrderFrom: objectMemory firstObject to: objectMemory freeStart]!
- 		ifFalse: [self convertFloatsToPlatformOrderFrom: objectMemory firstObject to: objectMemory endOfMemory]!

Item was changed:
  ----- Method: StackInterpreter>>longPrintOop: (in category 'debug printing') -----
  longPrintOop: oop
  	<api>
+ 	| class fmt lastIndex startIP bytecodesPerLine column |
- 	| fmt lastIndex startIP bytecodesPerLine column |
  	((objectMemory isIntegerObject: oop)
  	 or: [(oop between: objectMemory startOfMemory and: objectMemory freeStart) not
  	 or: [(oop bitAnd: (BytesPerWord - 1)) ~= 0
  	 or: [(objectMemory isFreeObject: oop)]]]) ifTrue:
  		[^self printOop: oop].
+ 	class := objectMemory fetchClassOfNonInt: oop.
  	self printHex: oop;
+ 		print: ': a(n) '; printNameOfClass: class count: 5;
+ 		print: ' ('; printHex: class; print: ')'.
- 		print: ': a(n) ';
- 		printNameOfClass: (objectMemory fetchClassOfNonInt: oop) count: 5.
  	fmt := objectMemory formatOf: oop.
  	fmt > 4 ifTrue:
  		[self print: ' nbytes '; printNum: (objectMemory byteSizeOf: oop)].
  	objectMemory printHeaderTypeOf: oop.
  	self cr.
  	(fmt between: 5 and: 11) ifTrue:
  		[^self].
  	lastIndex := 256 min: (startIP := (objectMemory lastPointerOf: oop) / BytesPerWord).
  	lastIndex > 0 ifTrue:
  		[1 to: lastIndex do:
  			[:i| | fieldOop |
  			fieldOop := objectMemory fetchPointer: i - 1 ofObject: oop.
  			self space; printNum: i - 1; space; printHex: fieldOop; space.
  			(i = 1 and: [objectMemory isCompiledMethod: oop])
  				ifTrue: [self printMethodHeaderOop: fieldOop]
  				ifFalse: [self printOopShort: fieldOop].
  			self cr]].
  	(objectMemory isCompiledMethod: oop)
  		ifFalse:
  			[startIP > 64 ifTrue: [self print: '...'; cr]]
  		ifTrue:
  			[startIP := startIP * BytesPerWord + 1.
  			 lastIndex := objectMemory lengthOf: oop.
  			 lastIndex - startIP > 100 ifTrue:
  				[lastIndex := startIP + 100].
  			 bytecodesPerLine := 8.
  			 column := 1.
  			 startIP to: lastIndex do:
  				[:index| | byte |
  				column = 1 ifTrue:
  					[self cCode: 'printf("0x%08x: ", oop+BaseHeaderSize+index-1)'
  						inSmalltalk: [self print: (oop+BaseHeaderSize+index-1) hex; print: ': ']].
  				byte := objectMemory fetchByte: index - 1 ofObject: oop.
  				self cCode: 'printf(" %02x/%-3d", byte,byte)'
  					inSmalltalk: [self space; print: (byte radix: 16); printChar: $/; printNum: byte].
  				column := column + 1.
  				column > bytecodesPerLine ifTrue:
  					[column := 1. self cr]].
  			column = 1 ifFalse:
  				[self cr]]!

Item was changed:
  ----- Method: StackInterpreter>>markAndTraceStackPage: (in category 'object memory support') -----
  markAndTraceStackPage: thePage
  	| theSP theFP frameRcvrOffset callerFP oop |
  	<var: #thePage type: #'StackPage *'>
  	<var: #theSP type: #'char *'>
  	<var: #theFP type: #'char *'>
  	<var: #frameRcvrOffset type: #'char *'>
  	<var: #callerFP type: #'char *'>
  	<inline: false>
  	self assert: (stackPages isFree: thePage) not.
  	theSP := thePage headSP.
  	theFP := thePage  headFP.
  	"Skip the instruction pointer on top of stack of inactive pages."
  	thePage = stackPage ifFalse:
  		[theSP := theSP + BytesPerWord].
  	[frameRcvrOffset := self frameReceiverOffset: theFP.
  	 [theSP <= frameRcvrOffset] whileTrue:
  		[oop := stackPages longAt: theSP.
  		 (objectMemory isIntegerObject: oop) ifFalse:
  			[objectMemory markAndTrace: oop].
  		 theSP := theSP + BytesPerWord].
  	(self frameHasContext: theFP) ifTrue:
  		[self assert: (self isContext: (self frameContext: theFP)).
  		 objectMemory markAndTrace: (self frameContext: theFP)].
  	objectMemory markAndTrace: (self iframeMethod: theFP).
  	(callerFP := self frameCallerFP: theFP) ~= 0] whileTrue:
  		[theSP := theFP + FoxCallerSavedIP + BytesPerWord.
  		 theFP := callerFP].
+ 	theSP := theFP + FoxCallerSavedIP. "caller ip is frameCallerContext in a base frame"
- 	theSP := self isCog
- 				ifTrue: [theFP + FoxCallerSavedIP + BytesPerWord] "caller ip is ceBaseReturnPC"
- 				ifFalse: [theFP + FoxCallerSavedIP]. "caller ip is frameCallerContext in a base frame"
  	[theSP <= thePage baseAddress] whileTrue:
  		[oop := stackPages longAt: theSP.
  		 (objectMemory isIntegerObject: oop) ifFalse:
  			[objectMemory markAndTrace: oop].
  		 theSP := theSP + BytesPerWord]!

Item was changed:
  ----- Method: StackInterpreter>>print: (in category 'debug printing') -----
  print: s
  	"For testing in Smalltalk, this method should be overridden in a subclass."
  	<api>
  	<var: #s type: #'char *'>
+ 	self cCode: 'fputs(s, stdout)'!
- 	self cCode: 'printf("%s", s)'.!

Item was changed:
  ----- Method: StackInterpreter>>printCallStackOf:currentFP: (in category 'debug printing') -----
  printCallStackOf: aContext currentFP: currFP
  	| ctxt theFP thePage |
  	<inline: false>
  	<var: #currFP type: #'char *'>
  	<var: #theFP type: #'char *'>
  	<var: #thePage type: #'StackPage *'>
  	ctxt := aContext.
  	[ctxt = objectMemory nilObject] whileFalse:
  		[(self isMarriedOrWidowedContext: ctxt)
  			ifFalse:
  				[self shortPrintContext: ctxt.
  				 ctxt := objectMemory fetchPointer: SenderIndex ofObject: ctxt]
  			ifTrue:
  				[theFP := self frameOfMarriedContext: ctxt.
  				 (self checkIsStillMarriedContext: ctxt currentFP: currFP)
  					ifTrue:
  						[thePage := stackPages stackPageFor: theFP.
  						 (stackPages isFree: thePage) ifTrue:
  							[self printHexPtr: theFP; print: ' is on a free page?!!'; cr.
  							 ^nil].
  						 self shortPrintFrameAndCallers: theFP.
  						 theFP := thePage baseFP.
  						 ctxt := self frameCallerContext: theFP]
+ 					ifFalse: [self print: 'widowed caller frame '; printHexPtr: theFP; cr.
- 					ifFalse: [self print: 'widowed caller frame '; print: theFP; cr.
  							^nil]]]!

Item was changed:
  ----- Method: StackInterpreter>>printHexPtr: (in category 'debug printing') -----
  printHexPtr: p
+ 	"Print p in hex, passed to 10 characters in the form '    0x1234'"
- 	"Print n in hex, passed to 10 characters in the form '    0x1234'"
  	<inline: true>
  	<var: #p type: #'void *'>
  	self printHex: (self oopForPointer: p)!

Item was changed:
  ----- Method: StackInterpreter>>reverseBytesInImage (in category 'image save/restore') -----
  reverseBytesInImage
  	"Byte-swap all words in memory after reading in the entire image file with bulk read. Contributed by Tim Rowledge."
  
  	"First, byte-swap every word in the image. This fixes objects headers."
+ 	objectMemory reverseBytesFrom: objectMemory startOfMemory to: objectMemory freeStart.
- 	objectMemory reverseBytesFrom: objectMemory startOfMemory to: objectMemory endOfMemory.
  
  	"Second, return the bytes of bytes-type objects to their orginal order, and perform any
  	 other format conversions."
+ 	self updateObjectsPostByteSwapFrom: objectMemory firstObject to: objectMemory freeStart!
- 	self updateObjectsPostByteSwapFrom: objectMemory firstObject to: objectMemory endOfMemory!



More information about the Vm-dev mailing list