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

commits at source.squeak.org commits at source.squeak.org
Wed Oct 22 01:25:58 UTC 2014


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

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

Name: VMMaker.oscog-eem.906
Author: eem
Time: 21 October 2014, 6:20:00.635 pm
UUID: aaa9ffc5-3dc3-455d-b550-92988ab90a8d
Ancestors: VMMaker.oscog-eem.905

Spur:
Implement image segments.  Use Igor's idea of
splitting the computation of the transitive closure
from the writing of the image segment for simplicity,
even if the two are rolled together into a single
primitive for backwards-compatibility.

Status is that raw use of the primtiives works, but use in the context of ImageSegmentTest fails
apparently because something somewhere changes
the version stamp at teh start of a segment.  Any
clues appreciated.


Rename markAccessibleObjects to
markAccessibleObjectsAndFireEphemerons,
rename markObjects to markObjects: flag, where
flag is true if objects are known to be unmarked
before hand.
Move expungeDuplicateAndUnmarkedClasses: and
nilUnmarkedWeaklingSlots into markObjects: from
globalGarbageCollect.  This is all to ensure that the
mark phase of the storeImageSegment prim does
process weaklings fully before computing the
transitive closure.

Extend the object shortening code to include word
objects (for the image segment arrays) and make
them deal with new space objects as well as old
space objects.  Have freeObject: attempt to
coalesce to avoid fragmenting the largest free
chunk all the time it is used for scratch storage).

Nuke the abortive attempt to implement the Spur
image segment code similarly to the V3 code.

Simplify isHiddenObj: for leak checking to tolerate
more punned scratch objects in new space.  Add
a flag to checkForLeaks to specifically check for
leaks around the segment prims.

Change readableFormat: so that on Spur there is as
yet no acceptable compatibility version.

All:
Rewrite the two primitives to pass back an error
code on failure, and rewrite the (New)ObjectMemory
code to answer informative failure codes.

Make findClassContainingMethod:startingAt: et al
robust in the face of faulted-out classes (nil method
dictionaries).

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

Item was changed:
  ----- Method: InterpreterPrimitives>>primitiveLoadImageSegment (in category 'image segment in/out') -----
  primitiveLoadImageSegment
  	"This primitive is called from Squeak as...
  		<imageSegment> loadSegmentFrom: aWordArray outPointers: anArray."
  
  "This primitive will load a binary image segment created by primitiveStoreImageSegment.  It expects the outPointer array to be of the proper size, and the wordArray to be well formed.  It will return as its value the original array of roots, and the erstwhile segmentWordArray will have been truncated to a size of zero.  If this primitive should fail, the segmentWordArray will, sadly, have been reduced to an unrecognizable and unusable jumble.  But what more could you have done with it anyway?"
  
  	| outPointerArray segmentWordArray result |
  
  	outPointerArray := self stackTop.
  	segmentWordArray := self stackValue: 1.
  
  	"Essential type checks"
  	((objectMemory isArray: outPointerArray)		"Must be indexable pointers"
  	 and: [objectMemory isWords: segmentWordArray])	"Must be indexable words"
  		ifFalse: [^self primitiveFail].
  
+ 	"the engine returns the roots array which was first in the segment, or an error code on failure."
- 	"the engine returns the roots array which was first in the segment, or 0 on failure"
  	result := objectMemory loadImageSegmentFrom: segmentWordArray outPointers: outPointerArray.
+ 	(self oop: result isGreaterThan: segmentWordArray)
+ 		ifTrue: [self pop: 3 thenPush: result]
+ 		ifFalse: [self primitiveFailFor: result]!
- 	result = 0
- 		ifTrue: [self primitiveFail]
- 		ifFalse: [self pop: 3 thenPush: result]!

Item was changed:
  ----- Method: NewObjectMemory>>loadImageSegmentFrom:outPointers: (in category 'image segment in/out') -----
  loadImageSegmentFrom: segmentWordArray outPointers: outPointerArray
  	"This primitive is called from Squeak as...
  		<imageSegment> loadSegmentFrom: aWordArray outPointers: anArray."
  
  "This primitive will load a binary image segment created by primitiveStoreImageSegment.  It expects the outPointer array to be of the proper size, and the wordArray to be well formed.  It will return as its value the original array of roots, and the erstwhile segmentWordArray will have been truncated to a size of zero.  If this primitive should fail, the segmentWordArray will, sadly, have been reduced to an unrecognizable and unusable jumble.  But what more could you have done with it anyway?"
  
  	| endSeg segOop fieldPtr fieldOop doingClass lastPtr extraSize mapOop lastOut outPtr hdrTypeBits header data |
  	<inline: false>
  	<var: #endSeg type: #usqInt>
  	<var: #segOop type: #usqInt>
  	<var: #fieldPtr type: #usqInt>
  	<var: #lastOut type: #usqInt>
  	<var: #outPtr type: #usqInt>
  	<var: #lastPtr type: #usqInt>
  
  	DoAssertionChecks ifTrue: [self verifyCleanHeaders].
  	lastOut := outPointerArray + (self lastPointerOf: outPointerArray).
  	endSeg := segmentWordArray + (self sizeBitsOf: segmentWordArray) - BaseHeaderSize.
  
  	"Version check.  Byte order of the WordArray now"
  	data := self longAt: segmentWordArray + BaseHeaderSize.
  	(coInterpreter readableFormat: (data bitAnd: 16rFFFF "low 2 bytes")) ifFalse:
  		"Not readable -- try again with reversed bytes..."
  		[self reverseBytesFrom: segmentWordArray + BaseHeaderSize to: endSeg + BytesPerWord.
  		data := self longAt: segmentWordArray + BaseHeaderSize.
  		(coInterpreter readableFormat: (data bitAnd: 16rFFFF "low 2 bytes")) ifFalse:
  			"Still NG -- put things back and fail"
  			[self reverseBytesFrom: segmentWordArray + BaseHeaderSize to: endSeg + BytesPerWord.
  			DoAssertionChecks ifTrue: [self verifyCleanHeaders].
+ 			^PrimErrBadArgument]].
- 			^0]].
  	"Reverse the Byte type objects if the data is from opposite endian machine.
  	 Revese the words in Floats if from an earlier version with different Float order.
  	 Test top byte.  $d on the Mac or $s on the PC.  Rest of word is equal."
  	(data >> 16) = (self imageSegmentVersion >> 16)
  		ifTrue:
  			"Need to swap floats if the segment is being loaded into a little-endian VM from a version
  			 that keeps Floats in big-endian word order as was the case prior to the 6505 image format."
  			[(self isPlatformFloatOrderVersion: (data bitAnd: 16rFFFF "low 2 bytes")) ifFalse:
  				[self vmEndianness ~= 1 "~= 1 => little-endian" ifTrue:
  					[segOop := self oopFromChunk: segmentWordArray + BaseHeaderSize + BytesPerWord.
  					 self wordSwapFloatsFrom: segOop to: endSeg + BytesPerWord]]]
  		ifFalse: "Reverse the byte-type objects once"
  			[segOop := self oopFromChunk: segmentWordArray + BaseHeaderSize + BytesPerWord.
  				 "Oop of first embedded object"
  			self byteSwapByteObjectsFrom: segOop
  				to: endSeg + BytesPerWord
  				flipFloatsIf: (self isPlatformFloatOrderVersion: (data bitAnd: 16rFFFF "low 2 bytes"))].
  
  	"Proceed through the segment, remapping pointers..."
  	segOop := self oopFromChunk: segmentWordArray + BaseHeaderSize + BytesPerWord.
  	[segOop <= endSeg] whileTrue:
  		[(self headerType: segOop) <= 1
  			ifTrue: ["This object has a class field (type = 0 or 1) -- start with that."
  					fieldPtr := segOop - BytesPerWord.  doingClass := true]
  			ifFalse: ["No class field -- start with first data field"
  					fieldPtr := segOop + BaseHeaderSize.  doingClass := false].
  		lastPtr := segOop + (self lastPointerOf: segOop).	"last field"
  		lastPtr > endSeg ifTrue:
  			[DoAssertionChecks ifTrue: [self verifyCleanHeaders].
+ 			^PrimErrBadIndex "out of bounds"].
- 			^0 "out of bounds"].
  
  		"Go through all oops, remapping them..."
  		[fieldPtr > lastPtr] whileFalse:
  			["Examine each pointer field"
  			fieldOop := self longAt: fieldPtr.
  			doingClass ifTrue:
  				[hdrTypeBits := self headerType: fieldPtr.
  				fieldOop := fieldOop - hdrTypeBits].
  			(self isIntegerObject: fieldOop)
  				ifTrue:
  					["Integer -- nothing to do"
  					fieldPtr := fieldPtr + BytesPerWord]
  				ifFalse:
  					[(fieldOop bitAnd: 3) = 0 ifFalse:
+ 						[^PrimErrBadIndex "bad oop"].
- 						[^0 "bad oop"].
  					(fieldOop bitAnd: 16r80000000) = 0
  						ifTrue: ["Internal pointer -- add segment offset"
  								mapOop := fieldOop + segmentWordArray]
  						ifFalse: ["External pointer -- look it up in outPointers"
  								outPtr := outPointerArray + (fieldOop bitAnd: 16r7FFFFFFF).
  								outPtr > lastOut ifTrue:
+ 									[^PrimErrBadIndex "out of bounds"].
- 									[^0 "out of bounds"].
  								mapOop := self longAt: outPtr].
  					doingClass
  						ifTrue: [self longAt: fieldPtr put: mapOop + hdrTypeBits.
  								fieldPtr := fieldPtr + 8.
  								doingClass := false]
  						ifFalse: [self longAt: fieldPtr put: mapOop.
  								fieldPtr := fieldPtr + BytesPerWord].
  					segOop < youngStart ifTrue:
  						[self possibleRootStoreInto: segOop value: mapOop]]].
  		segOop := self objectAfter: segOop].
  
  	"Again, proceed through the segment checking consistency..."
  	segOop := self oopFromChunk: segmentWordArray + BaseHeaderSize + BytesPerWord.
  	[segOop <= endSeg] whileTrue:
  		[(self oopHasAcceptableClass: segOop) ifFalse:
+ 			[^PrimErrInappropriate "inconsistency"].
- 			[^0 "inconsistency"].
  		fieldPtr := segOop + BaseHeaderSize.		"first field"
  		lastPtr := segOop + (self lastPointerOf: segOop).	"last field"
  		"Go through all oops, remapping them..."
  		[fieldPtr > lastPtr] whileFalse:
  			["Examine each pointer field"
  			fieldOop := self longAt: fieldPtr.
  			(self oopHasAcceptableClass: fieldOop) ifFalse:
+ 				[^PrimErrInappropriate "inconsistency"].
- 				[^0 "inconsistency"].
  			fieldPtr := fieldPtr + BytesPerWord].
  		segOop := self objectAfter: segOop].
  
  	"Truncate the segment word array to size = BytesPerWord (vers stamp only)"
  	extraSize := self extraHeaderBytes: segmentWordArray.
  	hdrTypeBits := self headerType: segmentWordArray.
  	extraSize = 8
  		ifTrue: [self longAt: segmentWordArray-extraSize put: BaseHeaderSize + BytesPerWord + hdrTypeBits]
  		ifFalse: [header := self longAt: segmentWordArray.
  				self longAt: segmentWordArray
  					put: header - (header bitAnd: SizeMask) + BaseHeaderSize + BytesPerWord].	
  	"and return the roots array which was first in the segment"
  	DoAssertionChecks ifTrue: [self verifyCleanHeaders].
  	^self oopFromChunk: segmentWordArray + BaseHeaderSize + BytesPerWord!

Item was changed:
  ----- Method: ObjectMemory>>loadImageSegmentFrom:outPointers: (in category 'image segment in/out') -----
  loadImageSegmentFrom: segmentWordArray outPointers: outPointerArray
  	"This primitive is called from Squeak as...
  		<imageSegment> loadSegmentFrom: aWordArray outPointers: anArray."
  
  "This primitive will load a binary image segment created by primitiveStoreImageSegment.  It expects the outPointer array to be of the proper size, and the wordArray to be well formed.  It will return as its value the original array of roots, and the erstwhile segmentWordArray will have been truncated to a size of zero.  If this primitive should fail, the segmentWordArray will, sadly, have been reduced to an unrecognizable and unusable jumble.  But what more could you have done with it anyway?"
  
  	| endSeg segOop fieldPtr fieldOop doingClass lastPtr extraSize mapOop lastOut outPtr hdrTypeBits header data |
  	<inline: false>
  	<var: #endSeg type: #usqInt>
  	<var: #segOop type: #usqInt>
  	<var: #fieldPtr type: #usqInt>
  	<var: #lastOut type: #usqInt>
  	<var: #outPtr type: #usqInt>
  	<var: #lastPtr type: #usqInt>
  
  	DoAssertionChecks ifTrue: [self verifyCleanHeaders].
  	lastOut := outPointerArray + (self lastPointerOf: outPointerArray).
  	endSeg := segmentWordArray + (self sizeBitsOf: segmentWordArray) - BaseHeaderSize.
  
  	"Version check.  Byte order of the WordArray now"
  	data := self longAt: segmentWordArray + BaseHeaderSize.
  	(self readableFormat: (data bitAnd: 16rFFFF "low 2 bytes")) ifFalse:
  		"Not readable -- try again with reversed bytes..."
  		[self reverseBytesFrom: segmentWordArray + BaseHeaderSize to: endSeg + BytesPerWord.
  		data := self longAt: segmentWordArray + BaseHeaderSize.
  		(self readableFormat: (data bitAnd: 16rFFFF "low 2 bytes")) ifFalse:
  			"Still NG -- put things back and fail"
  			[self reverseBytesFrom: segmentWordArray + BaseHeaderSize to: endSeg + BytesPerWord.
  			DoAssertionChecks ifTrue: [self verifyCleanHeaders].
+ 			^PrimErrBadArgument]].
- 			^0]].
  	"Reverse the Byte type objects if the data is from opposite endian machine.
  	 Test top byte.  $d on the Mac or $s on the PC.  Rest of word is equal."
  	(data >> 16) = (self imageSegmentVersion >> 16)
  		ifFalse: "Reverse the byte-type objects once"
  			[segOop := self oopFromChunk: segmentWordArray + BaseHeaderSize + BytesPerWord.
  				 "Oop of first embedded object"
  			self byteSwapByteObjectsFrom: segOop
  				to: endSeg + BytesPerWord
  				flipFloatsIf: false].
  
  	"Proceed through the segment, remapping pointers..."
  	segOop := self oopFromChunk: segmentWordArray + BaseHeaderSize + BytesPerWord.
  	[segOop <= endSeg] whileTrue:
  		[(self headerType: segOop) <= 1
  			ifTrue: ["This object has a class field (type = 0 or 1) -- start with that."
  					fieldPtr := segOop - BytesPerWord.  doingClass := true]
  			ifFalse: ["No class field -- start with first data field"
  					fieldPtr := segOop + BaseHeaderSize.  doingClass := false].
  		lastPtr := segOop + (self lastPointerOf: segOop).	"last field"
  		lastPtr > endSeg ifTrue:
  			[DoAssertionChecks ifTrue: [self verifyCleanHeaders].
+ 			^PrimErrBadIndex "out of bounds"].
- 			^0 "out of bounds"].
  
  		"Go through all oops, remapping them..."
  		[fieldPtr > lastPtr] whileFalse:
  			["Examine each pointer field"
  			fieldOop := self longAt: fieldPtr.
  			doingClass ifTrue:
  				[hdrTypeBits := self headerType: fieldPtr.
  				fieldOop := fieldOop - hdrTypeBits].
  			(self isIntegerObject: fieldOop)
  				ifTrue:
  					["Integer -- nothing to do"
  					fieldPtr := fieldPtr + BytesPerWord]
  				ifFalse:
  					[(fieldOop bitAnd: 3) = 0 ifFalse:
+ 						[^PrimErrBadIndex "bad oop"].
- 						[^0 "bad oop"].
  					(fieldOop bitAnd: 16r80000000) = 0
  						ifTrue: ["Internal pointer -- add segment offset"
  								mapOop := fieldOop + segmentWordArray]
  						ifFalse: ["External pointer -- look it up in outPointers"
  								outPtr := outPointerArray + (fieldOop bitAnd: 16r7FFFFFFF).
  								outPtr > lastOut ifTrue:
+ 									[^PrimErrBadIndex "out of bounds"].
- 									[^0 "out of bounds"].
  								mapOop := self longAt: outPtr].
  					doingClass
  						ifTrue: [self longAt: fieldPtr put: mapOop + hdrTypeBits.
  								fieldPtr := fieldPtr + 8.
  								doingClass := false]
  						ifFalse: [self longAt: fieldPtr put: mapOop.
  								fieldPtr := fieldPtr + BytesPerWord].
  					segOop < youngStart ifTrue:
  						[self possibleRootStoreInto: segOop value: mapOop]]].
  		segOop := self objectAfter: segOop].
  
  	"Again, proceed through the segment checking consistency..."
  	segOop := self oopFromChunk: segmentWordArray + BaseHeaderSize + BytesPerWord.
  	[segOop <= endSeg] whileTrue:
  		[(self oopHasAcceptableClass: segOop) ifFalse:
+ 			[^PrimErrInappropriate "inconsistency"].
- 			[^0 "inconsistency"].
  		fieldPtr := segOop + BaseHeaderSize.		"first field"
  		lastPtr := segOop + (self lastPointerOf: segOop).	"last field"
  		"Go through all oops, remapping them..."
  		[fieldPtr > lastPtr] whileFalse:
  			["Examine each pointer field"
  			fieldOop := self longAt: fieldPtr.
  			(self oopHasAcceptableClass: fieldOop) ifFalse:
+ 				[^PrimErrInappropriate "inconsistency"].
- 				[^0 "inconsistency"].
  			fieldPtr := fieldPtr + BytesPerWord].
  		segOop := self objectAfter: segOop].
  
  	"Truncate the segment word array to size = BytesPerWord (vers stamp only)"
  	extraSize := self extraHeaderBytes: segmentWordArray.
  	hdrTypeBits := self headerType: segmentWordArray.
  	extraSize = 8
  		ifTrue: [self longAt: segmentWordArray-extraSize put: BaseHeaderSize + BytesPerWord + hdrTypeBits]
  		ifFalse: [header := self longAt: segmentWordArray.
  				self longAt: segmentWordArray
  					put: header - (header bitAnd: SizeMask) + BaseHeaderSize + BytesPerWord].	
  	"and return the roots array which was first in the segment"
  	DoAssertionChecks ifTrue: [self verifyCleanHeaders].
  	^self oopFromChunk: segmentWordArray + BaseHeaderSize + BytesPerWord!

Item was added:
+ ----- Method: Spur32BitMMLESimulator>>loadImageSegmentFrom:outPointers: (in category 'image segment in/out') -----
+ loadImageSegmentFrom: segmentWordArray outPointers: outPointerArray
+ 	self halt.
+ 	^super loadImageSegmentFrom: segmentWordArray outPointers: outPointerArray!

Item was added:
+ ----- Method: Spur32BitMMLESimulator>>newOutPointer:at:in:hashes:topHashBit: (in category 'object access') -----
+ newOutPointer: oop at: outIndex in: outPointerArray hashes: savedOutHashes topHashBit: topHashBit
+ 	self halt.
+ 	^super newOutPointer: oop at: outIndex in: outPointerArray hashes: savedOutHashes topHashBit: topHashBit!

Item was added:
+ ----- Method: Spur32BitMemoryManager>>numSlotsForShortening:toIndexableSize: (in category 'allocation') -----
+ numSlotsForShortening: objOop toIndexableSize: indexableSize
+ 	<inline: true>
+ 	^(self formatOf: objOop) caseOf:
+ 		{ [self arrayFormat]			-> [indexableSize].
+ 		  [self firstLongFormat]		-> [self numSlotsForBytes: indexableSize * 4] }!

Item was added:
+ ----- Method: Spur64BitMemoryManager>>numSlotsForShortening:toIndexableSize: (in category 'allocation') -----
+ numSlotsForShortening: objOop toIndexableSize: indexableSize
+ 	<inline: true>
+ 	^(self formatOf: objOop) caseOf:
+ 		{ [self arrayFormat]			-> [indexableSize].
+ 		  [self firstLongFormat]		-> [self numSlotsForBytes: indexableSize * 4].
+ 		  [self firstLongFormat + 1]	-> [self numSlotsForBytes: indexableSize * 4] }!

Item was added:
+ ----- Method: SpurGenerationScavenger>>forgetObject: (in category 'gc - global') -----
+ forgetObject: objOop
+ 	"Forget the argument."
+ 	self assert: rememberedSetSize > 0.
+ 	self assert: (manager isRemembered: objOop).
+ 	manager setIsRememberedOf: objOop to: false.
+ 	objOop = (rememberedSet at: rememberedSetSize - 1) ifFalse:
+ 		[| index |
+ 		 index := 0.
+ 		 [index < rememberedSetSize] whileTrue:
+ 			[objOop = (rememberedSet at: index) ifTrue:
+ 				[rememberedSet at: index put: (rememberedSet at: rememberedSetSize - 1).
+ 				 index := rememberedSetSize]]].
+ 	rememberedSetSize := rememberedSetSize - 1.
+ 	self assert: rememberedSetSize >= 0!

Item was changed:
  ----- Method: SpurMemoryManager>>allInstancesOf: (in category 'primitive support') -----
  allInstancesOf: aClass
  	"Attempt to answer an array of all objects, excluding those that may
  	 be garbage collected as a side effect of allocating the result array.
  	 If no memory is available answer the number of instances as a SmallInteger.
  	 Since objects are at least 16 bytes big, and the largest SmallInteger covers
  	 1/4 of the address space, the count can never overflow."
  	| classIndex freeChunk ptr start limit count bytes |
  	classIndex := self rawHashBitsOf: aClass.
  	classIndex = 0 ifTrue:
  		[freeChunk := self allocateSlots: 0 format: self arrayFormat classIndex: ClassArrayCompactIndex.
  		 ^freeChunk].
  	MarkObjectsForEnumerationPrimitives ifTrue:
+ 		[self markObjects: true]. "may not want to revive objects unnecessarily; but marking is sloooow."
- 		[self markObjects]. "may not want to revive objects unnecessarily; but marking is sloooow."
  	freeChunk := self allocateLargestFreeChunk.
  	start := freeChunk + self baseHeaderSize.
  	limit := self addressAfter: freeChunk.
  	(self isClassAtUniqueIndex: aClass)
  		ifTrue:
  			[self uniqueIndex: classIndex allInstancesInto: start limit: limit resultsInto: [:c :p| count := c. ptr := p]]
  		ifFalse:
  			[self ambiguousClass: aClass allInstancesInto: start limit: limit resultsInto: [:c :p| count := c. ptr := p]].
  	self assert: (self isEmptyObjStack: markStack).
  	MarkObjectsForEnumerationPrimitives
  		ifTrue:
  			[self assert: self allObjectsUnmarked.
  			 self emptyObjStack: weaklingStack]
  		ifFalse:
  			[self assert: (self isEmptyObjStack: weaklingStack)].
  	(count > (ptr - start / self bytesPerSlot) "not enough room"
  	 or: [limit ~= ptr and: [limit - ptr <= self allocationUnit]]) ifTrue: "can't split a single word"
  		[self freeObject: freeChunk.
  		 ^self integerObjectOf: count].
  	count < self numSlotsMask ifTrue:
  		[| smallObj |
  		 smallObj := self allocateSlots: count format: self arrayFormat classIndex: ClassArrayCompactIndex.
  		 0 to: count - 1 do:
  			[:i|
  			self storePointerUnchecked: i ofObject: smallObj withValue: (self fetchPointer: i ofFreeChunk: freeChunk)].
  		 self freeChunkWithBytes: (self bytesInObject: freeChunk) at: (self startOfObject: freeChunk).
  		 self beRootIfOld: smallObj.
  		 self checkFreeSpace.
  		 ^smallObj].
  	bytes := self largeObjectBytesForSlots: count.
  	start := self startOfObject: freeChunk.
  	self freeChunkWithBytes: limit - start - bytes at: start + bytes.
  	totalFreeOldSpace := totalFreeOldSpace - bytes.
  	self setOverflowNumSlotsOf: freeChunk to: count.
  	self set: freeChunk classIndexTo: ClassArrayCompactIndex formatTo: self arrayFormat.
  	self possibleRootStoreInto: freeChunk.
  	self checkFreeSpace.
  	self runLeakCheckerForFullGC: false.
  	^freeChunk
  	
  	!

Item was changed:
  ----- Method: SpurMemoryManager>>allObjects (in category 'primitive support') -----
  allObjects
  	"Attempt to answer an array of all objects, excluding those that may
  	 be garbage collected as a side effect of allocating the result array.
  	 If no memory is available answer the number of objects as a SmallInteger.
  	 Since objects are at least 16 bytes big, and the largest SmallInteger covers
  	 1/4 of the address space, the count can never overflow."
  	| freeChunk ptr start limit count bytes |
  	MarkObjectsForEnumerationPrimitives ifTrue:
+ 		[self markObjects: true]. "may not want to revive objects unnecessarily; but marking is sloooow."
- 		[self markObjects]. "may not want to revive objects unnecessarily; but marking is sloooow."
  	freeChunk := self allocateLargestFreeChunk.
  	ptr := start := freeChunk + self baseHeaderSize.
  	limit := self addressAfter: freeChunk.
  	count := 0.
  	self allHeapEntitiesDo:
  		[:obj| "continue enumerating even if no room so as to unmark all objects."
  		 (MarkObjectsForEnumerationPrimitives
  				ifTrue: [self isMarked: obj]
  				ifFalse: [true]) ifTrue:
  			[(self isNormalObject: obj)
  				ifTrue:
  					[MarkObjectsForEnumerationPrimitives ifTrue:
  						[self setIsMarkedOf: obj to: false].
  					 count := count + 1.
  					 ptr < limit ifTrue:
  						[self longAt: ptr put: obj.
  						 ptr := ptr + self bytesPerSlot]]
  				ifFalse:
  					[MarkObjectsForEnumerationPrimitives ifTrue:
  						[(self isSegmentBridge: obj) ifFalse:
  							[self setIsMarkedOf: obj to: false]]]]].
  	self assert: (self isEmptyObjStack: markStack).
  	MarkObjectsForEnumerationPrimitives
  		ifTrue:
  			[self assert: self allObjectsUnmarked.
  			 self emptyObjStack: weaklingStack]
  		ifFalse:
  			[self assert: (self isEmptyObjStack: weaklingStack)].
  	self assert: count >= self numSlotsMask.
  	(count > (ptr - start / self bytesPerSlot) "not enough room"
  	 or: [limit ~= ptr and: [limit - ptr <= self allocationUnit]]) ifTrue: "can't split a single word"
  		[self freeChunkWithBytes: (self bytesInObject: freeChunk) at: (self startOfObject: freeChunk).
  		 self checkFreeSpace.
  		 ^self integerObjectOf: count].
  	bytes := self largeObjectBytesForSlots: count.
  	start := self startOfObject: freeChunk.
  	self freeChunkWithBytes: limit - start - bytes at: start + bytes.
  	totalFreeOldSpace := totalFreeOldSpace - bytes.
  	self setOverflowNumSlotsOf: freeChunk to: count.
  	self set: freeChunk classIndexTo: ClassArrayCompactIndex formatTo: self arrayFormat.
  	self possibleRootStoreInto: freeChunk.
  	self checkFreeSpace.
  	self runLeakCheckerForFullGC: false.
  	^freeChunk
  	
  	!

Item was removed:
- ----- Method: SpurMemoryManager>>arrayOfUnmarkedClasses (in category 'image segment in/out') -----
- arrayOfUnmarkedClasses
- 	| nClasses classes i |
- 	nClasses := 0.
- 	self classTableEntriesDo:
- 		[:class :ignored|
- 		 (self isMarked: class) ifFalse:
- 			[nClasses := nClasses + 1]].
- 	nClasses = 0 ifTrue:
- 		[^nilObj].
- 	classes := self allocateSlots: nClasses format: self arrayFormat classIndex: ClassArrayCompactIndex.
- 	classes ifNil:
- 		[^self integerObjectOf: PrimErrNoMemory].
- 	i := 0.
- 	self classTableEntriesDo:
- 		[:class :ignored|
- 		 (self isMarked: class) ifFalse:
- 			[self storePointer: i ofObject: classes withValue: class.
- 			 i := i + 1]].
- 	self assert: nClasses = i.
- 	^classes!

Item was added:
+ ----- Method: SpurMemoryManager>>copyObj:toAddr:startAt:stopAt: (in category 'image segment in/out') -----
+ copyObj: objOop toAddr: segAddr startAt: segStart stopAt: endSeg
+ 	"Copy objOop into the segment beginning at segAddr, and forward it to the copy.
+ 	 If it is a class in the class table, set the copy's hash to 0 for reassignment on load.
+ 	 Answer the next segmentAddr if successful.  Answer an appropriate error code if not"
+ 
+ 	"Copy the object..."
+ 	| bodySize copy hash newOop |
+ 	<inline: false>
+ 	bodySize := self bytesInObject: objOop.
+ 	(self oop: segAddr + bodySize isGreaterThanOrEqualTo: endSeg) ifTrue:
+ 		[^PrimErrWritePastObject].
+ 	self mem: segAddr asVoidPointer cp: (self startOfObject: objOop) asVoidPointer y: bodySize.
+ 	copy := self objectStartingAt: segAddr.
+ 
+ 	"Clear remembered, mark bits of all headers copied into the segment"
+ 	self
+ 		setIsRememberedOf: copy to: false;
+ 		setIsMarkedOf: copy to: false.
+ 	"If the object is a class, zero its identityHash (which is its classIndex).
+ 	 The class will be assigned a new hash on load."
+ 	hash := self rawHashBitsOf: objOop.
+ 	(hash > self lastClassIndexPun and: [(self classOrNilAtIndex: hash) = objOop]) ifTrue:
+ 		[self setHashBitsOf: copy to: 0].
+ 
+ 	newOop := copy - segStart / self allocationUnit.
+ 	newOop > self maxIdentityHash ifTrue:
+ 		[^PrimErrLimitExceeded].
+ 	self setHashBitsOf: objOop to: copy - segStart / self allocationUnit.
+ 	self setIsMarkedOf: objOop to: true.
+ 
+ 	"Answer the new end of segment"
+ 	^segAddr + bodySize!

Item was removed:
- ----- Method: SpurMemoryManager>>copyObj:toSegment:addr:stopAt:saveOopAt: (in category 'image segment in/out') -----
- copyObj: objOop toSegment: segmentWordArray addr: limitSeg stopAt: stopAddr saveOopAt: oopPtr
- 	"Copy objOop into the segment beginning at limitSeg, and forward it to the copy.
- 	 Fail if out of space.  Answer the next segmentAddr if successful."
- 
- 	"Copy the object..."
- 	| bodySize copy |
- 	<inline: false>
- 	bodySize := self bytesInObject: objOop.
- 	(self oop: limitSeg + bodySize isGreaterThanOrEqualTo: stopAddr) ifTrue:
- 		[^0]. "failure"
- 	self mem: limitSeg asVoidPointer cp: (self startOfObject: objOop) asVoidPointer y: bodySize.
- 	copy := self objectStartingAt: limitSeg.
- 
- 	"Clear remebered pinned and mark bits of all headers copied into the segment"
- 	self
- 		setIsRememberedOf: copy to: false;
- 		setIsPinnedOf: copy to: false;
- 		setIsMarkedOf: copy to: false.
- 
- 	"Remember the oop for undoing in case of prim failure."
- 	self longAt: oopPtr put: objOop.	
- 	self forward: objOop to: copy.
- 
- 	"Return new end of segment"
- 	^limitSeg + bodySize!

Item was removed:
- ----- Method: SpurMemoryManager>>ensureAllMarkBitsAreZero (in category 'gc - incremental') -----
- ensureAllMarkBitsAreZero
- 	"If the incremental collector is running mark bits may be set; stop it and clear them if necessary."
- 	self flag: 'need to implement the inc GC first...'.
- 	self assert: self allObjectsUnmarked!

Item was changed:
  ----- Method: SpurMemoryManager>>freeObject: (in category 'free space') -----
  freeObject: objOop
+ 	"Free an object in oldSpace.  Coalesce if possible to reduce fragmentation."
  	<api>
+ 	<inline: false>
+ 	| bytes start next |
+ 	self assert: (self isInOldSpace: objOop).
+ 	(self isRemembered: objOop) ifTrue:
+ 		[scavenger forgetObject: objOop].
- 	| bytes |
  	bytes := self bytesInObject: objOop.
+ 	start := self startOfObject: objOop.
+ 	next := self objectStartingAt: start + bytes.
+ 	(self isFreeObject: next) ifTrue:
+ 		[self detachFreeObject: next.
+ 		 bytes := bytes + (self bytesInObject: next)].
  	totalFreeOldSpace := totalFreeOldSpace + bytes.
+ 	^self freeChunkWithBytes: bytes at: start!
- 	^self freeChunkWithBytes: bytes at: (self startOfObject: objOop)!

Item was removed:
- ----- Method: SpurMemoryManager>>freeSmallObject: (in category 'free space') -----
- freeSmallObject: objOop
- 	"Free a small object.  The wrinkle here is that we don't tolerate a zero-slot
- 	 count in a free object so that the (self longLongAt: objOop) ~= 0 assert in
- 	 isEnumerableObject: isn't triggered."
- 		 
- 	| headerNumSlots bytes index |
- 	headerNumSlots := self rawNumSlotsOf: objOop.
- 	headerNumSlots = 0
- 		ifTrue:
- 			[self setRawNumSlotsOf: objOop to: 1.
- 			 index := self baseHeaderSize + self allocationUnit / self allocationUnit]
- 		ifFalse:
- 			[bytes := self bytesInObject: objOop.
- 			 index := bytes / self allocationUnit.
- 			 self assert: index < self numFreeLists].
- 	self setFree: objOop. 
- 	self storePointer: self freeChunkNextIndex ofFreeChunk: objOop withValue: (freeLists at: index).
- 	freeLists at: index put: objOop!

Item was changed:
  ----- Method: SpurMemoryManager>>globalGarbageCollect (in category 'gc - global') -----
  globalGarbageCollect
  	<inline: true> "inline into fullGC"
  	self assert: self validObjStacks.
  	self assert: (self isEmptyObjStack: markStack).
  	self assert: (self isEmptyObjStack: weaklingStack).
  
+ 	self markObjects: true.
- 	self markObjects.
- 	self expungeDuplicateAndUnmarkedClasses: true.
- 	self nilUnmarkedWeaklingSlots.
  	self freeUnmarkedObjectsAndSortAndCoalesceFreeSpaceForPigCompact.
  
  	"Mid-way the leak check must be more lenient.  Unmarked classes will have been
  	 expunged from the table, but unmarked instances will not yet have been reclaimed."
  	self runLeakCheckerForFullGC: true
  		excludeUnmarkedNewSpaceObjs: true
  		classIndicesShouldBeValid: true.
  
  	self compact.
  	self setHeapSizeAtPreviousGC.
  
  	self assert: self validObjStacks.
  	self assert: (self isEmptyObjStack: markStack).
  	self assert: (self isEmptyObjStack: weaklingStack).
  	self assert: self allObjectsUnmarked.
  	self runLeakCheckerForFullGC: true!

Item was changed:
  ----- Method: SpurMemoryManager>>isHiddenObj: (in category 'debug support') -----
  isHiddenObj: objOop
+ 	^(self classIndexOf: objOop) <= self lastClassIndexPun!
- 	^objOop =  self freeListsObject
- 	  or: [(self numSlotsOfAny: objOop) = ObjStackPageSlots
- 		and: [self isValidObjStackPage: objOop myIndex: (self fetchPointer: ObjStackMyx ofObject: objOop)]]!

Item was added:
+ ----- Method: SpurMemoryManager>>leakCheckImageSegments (in category 'debug support') -----
+ leakCheckImageSegments
+ 	<api>
+ 	^(checkForLeaks bitAnd: 16) ~= 0!

Item was changed:
+ ----- Method: SpurMemoryManager>>loadImageSegmentFrom:outPointers: (in category 'image segment in/out') -----
+ loadImageSegmentFrom: segmentWordArrayArg outPointers: outPointerArray
- ----- Method: SpurMemoryManager>>loadImageSegmentFrom:outPointers: (in category 'primitive support') -----
- loadImageSegmentFrom: segmentWordArray outPointers: outPointerArray
  	"This primitive is called from Squeak as...
  		<imageSegment> loadSegmentFrom: aWordArray outPointers: anArray."
  
+ 	"This primitive will load a binary image segment created by primitiveStoreImageSegment.
+ 	 It expects the outPointer array to be of the proper size, and the wordArray to be well formed.
+ 	 It will return as its value the original array of roots, and the erstwhile segmentWordArray will
+ 	 have been truncated to a size of zero.  If this primitive should fail, the segmentWordArray will,
+ 	 sadly, have been reduced to an unrecognizable and unusable jumble.  But what more could you
+ 	 have done with it anyway?"
- "This primitive will load a binary image segment created by primitiveStoreImageSegment.  It expects the outPointer array to be of the proper size, and the wordArray to be well formed.  It will return as its value the original array of roots, and the erstwhile segmentWordArray will have been truncated to a size of zero.  If this primitive should fail, the segmentWordArray will, sadly, have been reduced to an unrecognizable and unusable jumble.  But what more could you have done with it anyway?"
  
+ 	"First thing is to verify format.  If Spur is ever ported to big-endian machines then the segment
+ 	 may have to be byte/word swapped, but so far it only runs on little-endian machines, so for now
+ 	 just fail if endinanness is wrong."
+ 
+ 	<inline: false>
+ 	| segmentWordArray firstNeedingPostProcessing numOutPointers objOop segLimit segStart segVersion topHashBit topOopBit |
+ 	segVersion := self longAt: segmentWordArrayArg + self baseHeaderSize.
+ 	(coInterpreter readableFormat: (segVersion bitAnd: 16rFFFF "low 2 bytes")) ifFalse:
+ 		[^PrimErrBadArgument].
+ 
+ 	"If segmentWordArrayArg is too short to be truncated, clone it so that the clone is long enough."
+ 	(self hasOverflowHeader: segmentWordArrayArg)
+ 		ifTrue:
+ 			[segmentWordArray := segmentWordArrayArg]
+ 		ifFalse:
+ 			[segmentWordArray := self allocateSlots: self numSlotsMask + 1
+ 										format: (self formatOf: segmentWordArrayArg)
+ 										classIndex: (self classIndexOf: segmentWordArrayArg).
+ 			 segmentWordArray ifNil: [^PrimErrNoMemory].
+ 			 self mem: segmentWordArray + self baseHeaderSize
+ 				 cp: segmentWordArrayArg + self baseHeaderSize
+ 				 y: (self numSlotsOf: segmentWordArrayArg) * self bytesPerOop].
+ 
+ 	segStart := segmentWordArray + self baseHeaderSize + self allocationUnit.
+ 	segLimit := (self numSlotsOf: segmentWordArrayArg) * self bytesPerOop + segmentWordArray + self baseHeaderSize.
+ 
+ 	"scan through mapping oops and validating class references.
+ 	 Defer entering any class objects into the class table and/or
+ 	 pinning objects until a second pass."
+ 	numOutPointers := self numSlotsOf: outPointerArray.
+ 	firstNeedingPostProcessing := 0.
+ 	topHashBit := 1 bitShift: self identityHashFieldWidth - 1.
+ 	topOopBit := 1 bitShift: self bytesPerOop * 8 - 1.
+ 	objOop := self objectStartingAt: segStart.
+ 	[objOop < segLimit] whileTrue:
+ 		[| classIndex hash oop outPointer |
+ 		 ((self isRemembered: objOop) or: [self isMarked: objOop]) ifTrue:
+ 			[^PrimErrInappropriate].
+ 		 (firstNeedingPostProcessing = 0
+ 		  and: [(self isInNewSpace: objOop)
+ 		  and: [self isPinned: objOop]]) ifTrue:
+ 			[firstNeedingPostProcessing := objOop].
+ 		 classIndex := self classIndexOf: objOop.
+ 		 (classIndex anyMask: topHashBit)
+ 			ifTrue:
+ 				[classIndex - topHashBit >= numOutPointers ifTrue:
+ 					[^PrimErrBadIndex].
+ 				 outPointer := self fetchPointer: classIndex - topHashBit ofObject: outPointerArray.
+ 				 hash := self rawHashBitsOf: outPointer.
+ 				 (hash > self lastClassIndexPun and: [(self classOrNilAtIndex: hash) = outPointer]) ifFalse:
+ 					[^PrimErrInappropriate].
+ 				 self setClassIndexOf: objOop to: hash]
+ 			ifFalse: "The class is contained within the segment."
+ 				[(oop := classIndex * self allocationUnit + segStart) >= segLimit ifTrue:
+ 					[^PrimErrBadIndex].
+ 				 (self rawHashBitsOf: oop) ~= 0 ifTrue:
+ 					[^PrimErrInappropriate].
+ 				 self setIsRememberedOf: objOop to: true.
+ 				 "Don't populate the classTable until all oops have been mapped."
+ 				 firstNeedingPostProcessing = 0 ifTrue:
+ 					[firstNeedingPostProcessing := objOop]].
+ 		 0 to: (self numPointerSlotsOf: objOop) - 1 do:
+ 			[:i|
+ 			 oop := self fetchPointer: i ofObject: objOop.
+ 			 (self isNonImmediate: oop) ifTrue:
+ 				[(oop bitAnd: self allocationUnit - 1) ~= 0 ifTrue:
+ 					[^PrimErrInappropriate].
+ 				 (oop anyMask: topOopBit)
+ 					ifTrue:
+ 						[oop / self bytesPerOop >= numOutPointers ifTrue:
+ 							[^PrimErrBadIndex].
+ 						 outPointer := self fetchPointer: oop / self bytesPerOop ofObject: outPointerArray.
+ 						 self storePointerUnchecked: i ofObject: objOop withValue: outPointer]
+ 					ifFalse:
+ 						[oop + segStart >= segLimit ifTrue:
+ 							[^PrimErrBadIndex].
+ 						 self storePointerUnchecked: i ofObject: objOop withValue: oop + segStart]]].
+ 		 objOop := self objectAfter: objOop limit: segLimit].
+ 
+ 	"Scan for classes contained in the segment, entering them into
+ 	 the class table, and assigning the class indices of their instances."
+ 	firstNeedingPostProcessing ~= 0 ifTrue:
+ 		[objOop := firstNeedingPostProcessing.
+ 		 self assert: (self isRemembered: objOop).
+ 		 [objOop < segLimit] whileTrue:
+ 			[(self isRemembered: objOop) ifTrue:
+ 				[| classIndex hash oop errorCode |
+ 				 self setIsRememberedOf: objOop to: false.
+ 				 classIndex := self classIndexOf: objOop.
+ 				 self deny: (classIndex anyMask: topHashBit). "The class is contained within the segment."
+ 				 oop := classIndex * self allocationUnit + segStart.
+ 				 (hash := self rawHashBitsOf: oop) = 0 ifTrue: "The class needs to be added to the classTable"
+ 					[(errorCode := self enterIntoClassTable: oop) ~= 0 ifTrue:
+ 						[objOop := self objectStartingAt: segStart.
+ 						 [objOop < segLimit] whileTrue:
+ 							[hash := self rawHashBitsOf: objOop.
+ 							 hash > self lastClassIndexPun and: [(self classOrNilAtIndex: hash) = objOop ifTrue:
+ 								[self expungeFromClassTable: objOop].
+ 							 objOop := self objectAfter: objOop limit: segLimit]].
+ 						 ^errorCode].
+ 					 hash := self rawHashBitsOf: oop].
+ 				self setClassIndexOf: objOop to: hash].
+ 			 ((self isInNewSpace: objOop)
+ 			  and: [self isPinned: objOop]) ifTrue:
+ 				[| oldClone |
+ 				 oldClone := self cloneInOldSpaceForPinning: objOop.
+ 				 oldClone ~= 0 ifTrue:
+ 					[self setIsPinnedOf: oldClone to: true.
+ 					 self forward: objOop to: oldClone]].
+ 			 objOop := self objectAfter: objOop limit: segLimit]].
+ 
+ 	"Finally evaporate the container, leaving the newly loaded objects in place."
+ 	self setOverflowNumSlotsOf: segmentWordArray to: 0.
+ 	
+ 	self leakCheckImageSegments ifTrue:
+ 		[self runLeakCheckerForFullGC: true].
+ 
+ 	^self objectStartingAt: segStart!
- 	^PrimErrUnsupported!

Item was added:
+ ----- Method: SpurMemoryManager>>mappedOopOf:topHashBit:topOopBit: (in category 'image segment in/out') -----
+ mappedOopOf: objOop topHashBit: topHashBit topOopBit: topOopBit
+ 	"objOop is an object whose hash has been set to its mapped oop in either the segment or the
+ 	 out pointers.  If its hash's top bit is set then it is in out pointers.  Answer the mapped oop."
+ 	<inline: true>
+ 	| hash |
+ 	hash := self rawHashBitsOf: objOop.
+ 	^(hash anyMask: topHashBit)
+ 		ifTrue: [hash - topHashBit * self bytesPerOop + topOopBit]
+ 		ifFalse: [hash * self allocationUnit]!

Item was removed:
- ----- Method: SpurMemoryManager>>markAccessibleObjects (in category 'gc - global') -----
- markAccessibleObjects
- 	self assert: self validClassTableRootPages.
- 	self assert: segmentManager allBridgesMarked.
- 	self cCode: [] "for debugging markAndTrace: set (MarkStackRecord := OrderedCollection new)"
- 		inSmalltalk: [MarkStackRecord ifNotNil: [MarkStackRecord resetTo: 1]].
- 
- 	marking := true.
- 	"This must come first to enable stack page reclamation.  It clears
- 	  the trace flags on stack pages and so must preceed any marking.
- 	  Otherwise it will clear the trace flags of reached pages."
- 	coInterpreter initStackPageGC.
- 	self markAndTraceHiddenRoots.
- 	self markAndTraceExtraRoots.
- 	self assert: self validClassTableRootPages.
- 	coInterpreter markAndTraceInterpreterOops: true.
- 	self assert: self validObjStacks.
- 	self markWeaklingsAndMarkAndFireEphemerons.
- 	self assert: self validObjStacks.
- 	marking := false!

Item was added:
+ ----- Method: SpurMemoryManager>>markAccessibleObjectsAndFireEphemerons (in category 'gc - global') -----
+ markAccessibleObjectsAndFireEphemerons
+ 	self assert: self validClassTableRootPages.
+ 	self assert: segmentManager allBridgesMarked.
+ 	self cCode: [] "for debugging markAndTrace: set (MarkStackRecord := OrderedCollection new)"
+ 		inSmalltalk: [MarkStackRecord ifNotNil: [MarkStackRecord resetTo: 1]].
+ 
+ 	marking := true.
+ 	"This must come first to enable stack page reclamation.  It clears
+ 	  the trace flags on stack pages and so must preceed any marking.
+ 	  Otherwise it will clear the trace flags of reached pages."
+ 	coInterpreter initStackPageGC.
+ 	self markAndTraceHiddenRoots.
+ 	self markAndTraceExtraRoots.
+ 	self assert: self validClassTableRootPages.
+ 	coInterpreter markAndTraceInterpreterOops: true.
+ 	self assert: self validObjStacks.
+ 	self markWeaklingsAndMarkAndFireEphemerons.
+ 	self assert: self validObjStacks.
+ 	marking := false!

Item was removed:
- ----- Method: SpurMemoryManager>>markAllExceptTransitiveClosureOf: (in category 'image segment in/out') -----
- markAllExceptTransitiveClosureOf: arrayOfRoots
- 	"Mark all objects in the system except those in arrayOfRoots and objects only reachable from arrayOfRoots.
- 	 This is how the image segment writing primitive computes the set of objects to include in a segment."
- 
-  	self assert: self allObjectsUnmarked.
- 	self markObjectsIn: arrayOfRoots.
- 	self markObjects.
- 	self unmarkObjectsIn: arrayOfRoots.!

Item was changed:
  ----- Method: SpurMemoryManager>>markAndTrace: (in category 'gc - global') -----
  markAndTrace: objOop
  	"Mark the argument, and all objects reachable from it, and any remaining objects
  	 on the mark stack. Follow forwarding pointers in the scan."
  	<api>
- 	| objToScan scanLargeObject numStrongSlots index field |
  	"if markAndTrace: is to follow and eliminate forwarding pointers
  	 in its scan it cannot be handed an r-value which is forwarded.
  	 The assert for this is in markAndShouldScan:"
  	(self markAndShouldScan: objOop) ifFalse:
  		[^self].
  
  	"Now scan the object, and any remaining objects on the mark stack."
+ 	self markLoopFrom: objOop!
- 	objToScan := objOop.
- 	"To avoid overflowing the mark stack when we encounter large objects, we
- 	 push the obj, then its numStrongSlots, and then index the object from the stack."
- 	[(self isImmediate: objToScan)
- 		ifTrue: [scanLargeObject := true]
- 		ifFalse:
- 			[numStrongSlots := self numStrongSlotsOfInephemeral: objToScan.
- 			 scanLargeObject := numStrongSlots > self traceImmediatelySlotLimit].
- 	 scanLargeObject
- 		ifTrue: "scanning a large object. scan until hitting an unmarked object, then switch to it, if any."
- 			[(self isImmediate: objToScan)
- 				ifTrue:
- 					[index := self integerValueOf: objToScan.
- 					 objToScan := self topOfObjStack: markStack]
- 				ifFalse:
- 					[index := numStrongSlots.
- 					 self markAndTraceClassOf: objToScan].
- 			 [index > 0] whileTrue:
- 				[index := index - 1.
- 				 field := self fetchPointer: index ofObject: objToScan.
- 				 (self isNonImmediate: field) ifTrue:
- 					[(self isForwarded: field) ifTrue: "fixFollowedField: is /not/ inlined"
- 						[field := self fixFollowedField: index ofObject: objToScan withInitialValue: field].
- 					 (self markAndShouldScan: field) ifTrue:
- 						[index > 0 ifTrue:
- 							[(self topOfObjStack: markStack) ~= objToScan ifTrue: 
- 								[self push: objToScan onObjStack: markStack].
- 							 self push: (self integerObjectOf: index) onObjStack: markStack].
- 						 objToScan := field.
- 						 index := -1]]].
- 			 index >= 0 ifTrue: "if loop terminated without finding an unmarked referent, switch to top of stack."
- 				[objToScan := self popObjStack: markStack.
- 				 objToScan = objOop ifTrue:
- 					[objToScan := self popObjStack: markStack]]]
- 		ifFalse: "scanning a small object. scan, marking, pushing unmarked referents, then switch to the top of the stack."
- 			[index := numStrongSlots.
- 			 self markAndTraceClassOf: objToScan.
- 			 [index > 0] whileTrue:
- 				[index := index - 1.
- 				 field := self fetchPointer: index ofObject: objToScan.
- 				 (self isNonImmediate: field) ifTrue:
- 					[(self isForwarded: field) ifTrue: "fixFollowedField: is /not/ inlined"
- 						[field := self fixFollowedField: index ofObject: objToScan withInitialValue: field].
- 					 (self markAndShouldScan: field) ifTrue:
- 						[self push: field onObjStack: markStack.
- 						 ((self rawNumSlotsOf: field) > self traceImmediatelySlotLimit
- 						  and: [(numStrongSlots := self numStrongSlotsOfInephemeral: field) > self traceImmediatelySlotLimit]) ifTrue:
- 							[self push: (self integerObjectOf: numStrongSlots) onObjStack: markStack]]]].
- 			 objToScan := self popObjStack: markStack].
- 	 objToScan notNil] whileTrue!

Item was added:
+ ----- Method: SpurMemoryManager>>markLoopFrom: (in category 'gc - global') -----
+ markLoopFrom: objOop
+ 	"Scan objOop and all objects on the mark stack, until the mark stack is empty.
+ 	 N.B. When the incremental GC is written this will probably be refactored as
+ 	 markLoopFrom: objOop while: aBlock"
+ 	<inline: true>
+ 	| objToScan field index numStrongSlots scanLargeObject |
+ 
+ 	"Now scan the object, and any remaining objects on the mark stack."
+ 	objToScan := objOop.
+ 	"To avoid overflowing the mark stack when we encounter large objects, we
+ 	 push the obj, then its numStrongSlots, and then index the object from the stack."
+ 	[(self isImmediate: objToScan)
+ 		ifTrue: [scanLargeObject := true]
+ 		ifFalse:
+ 			[numStrongSlots := self numStrongSlotsOfInephemeral: objToScan.
+ 			 scanLargeObject := numStrongSlots > self traceImmediatelySlotLimit].
+ 	 scanLargeObject
+ 		ifTrue: "scanning a large object. scan until hitting an unmarked object, then switch to it, if any."
+ 			[(self isImmediate: objToScan)
+ 				ifTrue:
+ 					[index := self integerValueOf: objToScan.
+ 					 objToScan := self topOfObjStack: markStack]
+ 				ifFalse:
+ 					[index := numStrongSlots.
+ 					 self markAndTraceClassOf: objToScan].
+ 			 [index > 0] whileTrue:
+ 				[index := index - 1.
+ 				 field := self fetchPointer: index ofObject: objToScan.
+ 				 (self isNonImmediate: field) ifTrue:
+ 					[(self isForwarded: field) ifTrue: "fixFollowedField: is /not/ inlined"
+ 						[field := self fixFollowedField: index ofObject: objToScan withInitialValue: field].
+ 					 (self markAndShouldScan: field) ifTrue:
+ 						[index > 0 ifTrue:
+ 							[(self topOfObjStack: markStack) ~= objToScan ifTrue: 
+ 								[self push: objToScan onObjStack: markStack].
+ 							 self push: (self integerObjectOf: index) onObjStack: markStack].
+ 						 objToScan := field.
+ 						 index := -1]]].
+ 			 index >= 0 ifTrue: "if loop terminated without finding an unmarked referent, switch to top of stack."
+ 				[objToScan := self popObjStack: markStack.
+ 				 objToScan = objOop ifTrue:
+ 					[objToScan := self popObjStack: markStack]]]
+ 		ifFalse: "scanning a small object. scan, marking, pushing unmarked referents, then switch to the top of the stack."
+ 			[index := numStrongSlots.
+ 			 self markAndTraceClassOf: objToScan.
+ 			 [index > 0] whileTrue:
+ 				[index := index - 1.
+ 				 field := self fetchPointer: index ofObject: objToScan.
+ 				 (self isNonImmediate: field) ifTrue:
+ 					[(self isForwarded: field) ifTrue: "fixFollowedField: is /not/ inlined"
+ 						[field := self fixFollowedField: index ofObject: objToScan withInitialValue: field].
+ 					 (self markAndShouldScan: field) ifTrue:
+ 						[self push: field onObjStack: markStack.
+ 						 ((self rawNumSlotsOf: field) > self traceImmediatelySlotLimit
+ 						  and: [(numStrongSlots := self numStrongSlotsOfInephemeral: field) > self traceImmediatelySlotLimit]) ifTrue:
+ 							[self push: (self integerObjectOf: numStrongSlots) onObjStack: markStack]]]].
+ 			 objToScan := self popObjStack: markStack].
+ 	 objToScan notNil] whileTrue!

Item was removed:
- ----- Method: SpurMemoryManager>>markObjects (in category 'gc - global') -----
- markObjects
- 	<inline: #never> "for profiling"
- 	"Mark all accessible objects."
- 	"If the incremental collector is running mark bits may be set; stop it and clear them if necessary."
- 	self cCode: '' inSmalltalk: [coInterpreter transcript nextPutAll: 'marking...'; flush].
- 	self runLeakCheckerForFullGC: true.
- 
- 	self ensureAllMarkBitsAreZero.
- 	self initializeUnscannedEphemerons.
- 	self initializeMarkStack.
- 	self initializeWeaklingStack.
- 	self markAccessibleObjects!

Item was added:
+ ----- Method: SpurMemoryManager>>markObjects: (in category 'gc - global') -----
+ markObjects: objectsShouldBeUnmarked
+ 	<inline: #never> "for profiling"
+ 	"Mark all accessible objects.  "
+ 	"If the incremental collector is running mark bits may be set; stop it and clear them if necessary."
+ 	self cCode: '' inSmalltalk: [coInterpreter transcript nextPutAll: 'marking...'; flush].
+ 	self runLeakCheckerForFullGC: true.
+ 
+ 	self shutDownIncrementalGC: objectsShouldBeUnmarked.
+ 	self initializeUnscannedEphemerons.
+ 	self initializeMarkStack.
+ 	self initializeWeaklingStack.
+ 	self markAccessibleObjectsAndFireEphemerons.
+ 	self expungeDuplicateAndUnmarkedClasses: true.
+ 	self nilUnmarkedWeaklingSlots!

Item was added:
+ ----- Method: SpurMemoryManager>>markObjectsIn: (in category 'image segment in/out') -----
+ markObjectsIn: arrayOfRoots
+ 	self setIsMarkedOf: arrayOfRoots to: true.
+ 	0 to: (self numSlotsOf: arrayOfRoots) - 1 do:
+ 		[:i| | oop |
+ 		oop := self followField: i ofObject: arrayOfRoots.
+ 		(self isNonImmediate: oop) ifTrue:
+ 			[self setIsMarkedOf: oop to: true]]!

Item was added:
+ ----- Method: SpurMemoryManager>>newOutPointer:at:in:hashes:topHashBit: (in category 'image segment in/out') -----
+ newOutPointer: oop at: outIndex in: outPointerArray hashes: savedOutHashes topHashBit: topHashBit
+ 	"oop is a new outPointer; allocate its oop, and answer the new outIndex.
+ 	 If outPointerArray is full, answer 0."
+ 	<inline: true>
+ 	outIndex >= (self rawOverflowSlotsOf: outPointerArray) ifTrue:
+ 						["no room in outPointers; fail"
+ 						 ^0].
+ 	self storePointer: outIndex ofObject: outPointerArray withValue: oop.
+ 	self storeLong32: outIndex ofObject: savedOutHashes withValue: (self rawHashBitsOf: oop).
+ 	self setHashBitsOf: oop to: outIndex + topHashBit.
+ 	self setIsMarkedOf: oop to: true.
+ 	^outIndex + 1!

Item was added:
+ ----- Method: SpurMemoryManager>>numSlotsForShortening:toIndexableSize: (in category 'allocation') -----
+ numSlotsForShortening: objOop toIndexableSize: indexableSize
+ 	self subclassResponsibility!

Item was added:
+ ----- Method: SpurMemoryManager>>objectsReachableFromRoots: (in category 'image segment in/out') -----
+ objectsReachableFromRoots: arrayOfRoots
+ 	"Answer an Array of all the objects only reachable from the argument, an Array of root objects,
+ 	 starting with arrayOfRoots.  If there is no space, answer a SmallInteger whose value is the
+ 	 number of slots required.  This is used to collect the objects to include in an image segment
+ 	 on Spur, separate from creating the segment, hence simplifying the implementation.
+ 	 Thanks to Igor Stasenko for this idea."
+ 
+ 	| freeChunk ptr start limit count oop objOop |
+ 	self assert: (self isArray: arrayOfRoots).
+ 	"Mark all objects except those only reachable from the arrayOfRoots by marking
+ 	 each object in arrayOfRoots and then marking all reachable objects (from the
+ 	 system roots).  This leaves unmarked only objects reachable from the arrayOfRoots.
+ 	 N.B. A side-effect of the marking is that all forwarders in arrayOfRoots will be followed."
+  	self assert: self allObjectsUnmarked.
+ 	self setIsMarkedOf: arrayOfRoots to: true.
+ 	self markObjects: false.
+ 
+ 	"After the mark phase all unreachable weak slots will have been nilled
+ 	 and all active ephemerons fired."
+ 	self assert: (self isEmptyObjStack: markStack).
+ 	self assert: (self isEmptyObjStack: weaklingStack).
+ 	self assert: self noUnscannedEphemerons.
+ 
+ 	"Use the largest free chunk to answer the result."
+ 	freeChunk := self allocateLargestFreeChunk.
+ 	ptr := start := freeChunk + self baseHeaderSize.
+ 	limit := self addressAfter: freeChunk.
+ 	count := 0.
+ 	"First put the roots; order is important."
+ 	self push: arrayOfRoots onObjStack: markStack.
+ 
+ 	"Now collect the unmarked objects reachable from the roots."
+ 	[self isEmptyObjStack: markStack] whileFalse:
+ 		[objOop := self popObjStack: markStack.
+ 		 count := count + 1.
+ 		 ptr < limit ifTrue:
+ 			[self longAt: ptr put: objOop.
+ 			 ptr := ptr + self bytesPerSlot].
+ 		 oop := self fetchClassOfNonImm: objOop.
+ 		 (self isMarked: oop) ifFalse:
+ 			[self setIsMarkedOf: objOop to: true.
+ 			 self push: oop onObjStack: markStack].
+ 		 0 to: (self numPointerSlotsOf: objOop) - 1 do:
+ 			[:i|
+ 			 oop := self fetchPointer: i ofObject: objOop.
+ 			 ((self isImmediate: oop)
+ 			  or: [self isMarked: oop]) ifFalse:
+ 				[self setIsMarkedOf: objOop to: true.
+ 				 self push: oop onObjStack: markStack]]].
+ 
+ 	self unmarkAllObjects.
+ 
+ 	totalFreeOldSpace := totalFreeOldSpace - (self bytesInObject: freeChunk).
+ 	"Now try and allocate the result"
+ 	(count > (ptr - start / self bytesPerSlot) "not enough room"
+ 	 or: [limit ~= ptr and: [limit - ptr <= self allocationUnit]]) ifTrue: "can't split a single word"
+ 		[self freeChunkWithBytes: (self bytesInObject: freeChunk) at: (self startOfObject: freeChunk).
+ 		 self checkFreeSpace.
+ 		 ^self integerObjectOf: count].
+ 	"There's room; set the format, & classIndex and shorten."
+ 	self setFormatOf: freeChunk to: self arrayFormat.
+ 	self setClassIndexOf: freeChunk to: ClassArrayCompactIndex.
+ 	self shorten: freeChunk toIndexableSize: count.
+ 	self possibleRootStoreInto: freeChunk.
+ 	self checkFreeSpace.
+ 	self runLeakCheckerForFullGC: false.
+ 	^freeChunk!

Item was removed:
- ----- Method: SpurMemoryManager>>restoreObjectsFrom:to:from:to: (in category 'image segment in/out') -----
- restoreObjectsFrom: firstIn to: lastIn from: firstSeg to: limitSeg
- 	"Unforward objects"
- 	| originalPtr originalObj copyPtr copyObj |
- 	originalPtr := firstIn.
- 	copyPtr := firstSeg.
- 	[self oop: originalPtr isLessThanOrEqualTo: lastIn] whileTrue:
- 		[originalObj := self longAt: originalPtr.
- 		 copyObj := self objectStartingAt: copyPtr.
- 		 self unforward: originalObj from: copyObj.
- 		 originalPtr := originalPtr + self bytesPerOop.
- 		 copyPtr := self addressAfter: copyObj].
- 	self assert: copyPtr = limitSeg!

Item was added:
+ ----- Method: SpurMemoryManager>>restoreObjectsIn:savedHashes: (in category 'image segment in/out') -----
+ restoreObjectsIn: objArray savedHashes: savedHashes
+ 	"Enumerate the objects in objArray,unmarking them and restoring their hashes
+ 	 from the corresponding 32-bit slots in savedHashes.  The first unused entry in
+ 	 objArray will have a non-hash value entry in savedHashes.  Free savedHashes."
+ 	<inline: false>
+ 	0 to: (self numSlotsOf: objArray) - 1 do:
+ 		[:i| | hash oop |
+ 		(hash := self fetchLong32: i ofObject: savedHashes) > self maxIdentityHash ifTrue:
+ 			[(self isInOldSpace: savedHashes) ifTrue:
+ 				[self freeObject: savedHashes].
+ 			 ^self].
+ 		oop := self fetchPointer: i ofObject: objArray.
+ 		self setHashBitsOf: oop to: hash.
+ 		self setIsMarkedOf: oop to: false].
+ 	(self isInOldSpace: savedHashes) ifTrue:
+ 		[self freeObject: savedHashes]!

Item was added:
+ ----- Method: SpurMemoryManager>>return:restoringObjectsIn:savedHashes:and:savedHashes: (in category 'image segment in/out') -----
+ return: errCode restoringObjectsIn: firstArray savedHashes: firstSavedHashes and: secondArray savedHashes: secondSavedHashes
+ 	self restoreObjectsIn: firstArray savedHashes: firstSavedHashes.
+ 	self restoreObjectsIn: secondArray savedHashes: secondSavedHashes.
+ 	self leakCheckImageSegments ifTrue:
+ 		[self runLeakCheckerForFullGC: true].
+ 	self assert: self allObjectsUnmarked.
+ 	^errCode!

Item was changed:
  ----- Method: SpurMemoryManager>>shorten:toIndexableSize: (in category 'allocation') -----
  shorten: objOop toIndexableSize: indexableSize
  	"Reduce the number of indexable fields in objOop, a pointer object, to nSlots. Convert the
+ 	 unused residual to a free chunk. Without changes to numSlotsForShortening:toIndexableSize:
+ 	 this only works for arrayFormat and longFormat objects.
- 	 unused residual to a free chunk. Word and byte indexable objects are not changed.
  	 Answer the number of bytes returned to free memory, which may be zero if no change
  	 was possible."
  	<inline: false>
+ 	| numSlots bytesBefore delta freeChunk |
+ 	numSlots := self numSlotsForShortening: objOop toIndexableSize: indexableSize.
+ 	numSlots = (self numSlotsOf: objOop) ifTrue:
+ 		[^0].
- 	| numSlots bytesBefore bytesAfter |
- 	(self formatOf: objOop) caseOf:
- 		{ [self arrayFormat]	->	[numSlots := indexableSize] }.
  	bytesBefore := self bytesInObject: objOop.
  	(self hasOverflowHeader: objOop)
  		ifTrue: [self rawOverflowSlotsOf: objOop put: numSlots]
  		ifFalse:
  			[self assert: numSlots < self numSlotsMask.
  			 self rawNumSlotsOf: objOop put: numSlots].
+ 	delta := bytesBefore - (self bytesInObject: objOop).
+ 	freeChunk := self initFreeChunkWithBytes: delta at: (self addressAfter: objOop).
+ 	(self isInOldSpace: objOop)
+ 		ifTrue:
+ 			[totalFreeOldSpace := totalFreeOldSpace + delta.
+ 			 self addToFreeList: freeChunk bytes: delta]
+ 		ifFalse:
+ 			[self
+ 				setClassIndexOf: freeChunk to: self wordSizeClassIndexPun;
+ 				setFormatOf: freeChunk to: self firstLongFormat].
+ 	^delta!
- 	bytesAfter := self bytesInObject: objOop.
- 	self freeChunkWithBytes: bytesAfter - bytesBefore at: (self addressAfter: objOop).
- 	^bytesAfter - bytesBefore!

Item was added:
+ ----- Method: SpurMemoryManager>>shutDownIncrementalGC: (in category 'gc - incremental') -----
+ shutDownIncrementalGC: objectsShouldBeUnmarked
+ 	"If the incremental collector is running mark bits may be set; stop it and clear them if necessary."
+ 	self flag: 'need to implement the inc GC first...'.
+ 	objectsShouldBeUnmarked ifTrue:
+ 		[self assert: self allObjectsUnmarked]!

Item was changed:
  ----- Method: SpurMemoryManager>>storeImageSegmentInto:outPointers:roots: (in category 'image segment in/out') -----
  storeImageSegmentInto: segmentWordArray outPointers: outPointerArray roots: arrayOfRoots
  	"This primitive is called from Squeak as...
+ 		<imageSegment> storeSegmentFor: arrayOfRoots into: aWordArray outPointers: anArray.
- 		<imageSegment> storeSegmentFor: arrayOfRoots into: aWordArray outPointers: anArray."
  
+ 	 This primitive will store a binary image segment (in the same format as objercts in the heap) of the
+ 	 set of objects in arrayOfObjects.  All pointers from within the set to objects outside the set will be
+ 	 copied into the array of outPointers.  In their place in the image segment will be an oop equal to the
+ 	 offset in the outPointer array (the first would be 4). but with the high bit set.
- "This primitive will store a binary image segment (in the same format as the Squeak image file) of the receiver and every object in its proper tree of subParts (ie, that is not refered to from anywhere else outside the tree).  All pointers from within the tree to objects outside the tree will be copied into the array of outpointers.  In their place in the image segment will be an oop equal to the offset in the outPointer array (the first would be 4). but with the high bit set."
  
+ 	 The primitive expects the segmentWordArray and outPointerArray to be more than adequately long.
+ 	 In this case it returns normally, and truncates the two arrays to exactly the right size.  To simplify
+ 	 truncation, both incoming arrays are required to be whatever the objectMemory considers long
+ 	 objects.  If either array is too small, the primitive will fail.
- "The primitive expects the array and wordArray to be more than adequately long.  In this case it returns normally, and truncates the two arrays to exactly the right size.  To simplify truncation, both incoming arrays are required to have large headers (i.e. be 256 words long or larger).  If either array is too small, the primitive will fail, but in no other case.
  
+ 	 The primitive can fail for the following reasons with the specified failure codes:
+ 		PrimErrWritePastObject:	the segmentWordArray is too small
+ 		PrimErrBadIndex:			the outPointerArray is too small
+ 		PrimErrNoMemory:			additional allocations failed
+ 		PrimErrLimitExceeded:		there is no room in the hash field to store object oops."
+ 	<inline: false>
+ 	| arrayOfObjects savedInHashes savedOutHashes fillValue endSeg segAddr topHashBit objOop outIndex segStart topOopBit |
- During operation of the primitive, it is necessary to convert from both internal and external oops to their mapped values.  To make this fast, the original objects in question are forwarded to the mapped values.  Tables are kept of both kinds of oops.  Note that markObjects eliminates forwarding pointers, so there will be no forwarding pointers in the object graph once objects have been marked.
  
+ 	(self hasOverflowHeader: segmentWordArray) ifFalse:	"Must have 128-bit header"
+ 		[^PrimErrWritePastObject].
+ 	(self hasOverflowHeader: outPointerArray) ifFalse:		"Must have 128-bit header"
+ 		[^PrimErrBadIndex].
- To be specific, there are two similar tables, the outPointer array, and one in the upper eight of the segmentWordArray.  Each grows oops from the bottom up.
  
+ 	self leakCheckImageSegments ifTrue:
+ 		[self runLeakCheckerForFullGC: true].
- In case of either success or failure, the headers must be restored.  In the event of primitive failure, the table of outPointers must also be nilled out (since the garbage in the high half will not have been discarded)."
  
+ 	"First compute the transitive closure, collecting the sequence of objects to be stored in the arrayOfObjects array."
+ 	arrayOfObjects := self objectsReachableFromRoots: arrayOfRoots.
+ 	arrayOfObjects ifNil:
+ 		[^PrimErrNoMemory].
- 	| endSeg firstIn firstOut lastIn lastOut limitSeg scanned newSegLimit unmarkedClasses |
- 	true ifTrue: [^PrimErrUnsupported] ifFalse: [
  
+ 	
+ 	"The scheme is to copy the objects into segmentWordArray, and then map the oops in sementWordArray.
+ 	 Therefore the primitive needs to both map efficiently originals to copies in segmentWordArray and
+ 	 be able to undo any side-effects if the primitive fails because either sementWordArray or outPointerArray
+ 	 is too small.  The mapping is done by having the originals (either the objects in arrayOfObjects or the
+ 	 objects in outPointerArray) refer to their mapped locations through their identityHash, and saving their
+ 	 identityHashes in two ByteArrays, one that mirrors arrayOfObjects, and one that mirrors outPointerArray.
+ 	 Since arrayOfObjects and its saved hashes, and outPointerArray and its saved hashes, can be enumerated
+ 	 side-by-side, the hashes can be restored to the originals.  So the hash of an object in arrayOfObjects
+ 	 is set to its offset in segmentWordArray / self allocationUnit, and the hash of an object in outPointerArray
+ 	 is set to its index in outPointerArray plus the top hash bit.  Oops in segmentWordArray are therefore
+ 	 mapped by accessing the original oop's identityHash, testing the bottom bit to distinguish between internal
+ 	 and external oops.  The saved hash arrays are initialized with an out-of-range hash value so that the first
+ 	 unused entry can be identified."
- 	((self hasOverflowHeader: outPointerArray)						"Must have 128-bit header"
- 	and: [self hasOverflowHeader: segmentWordArray]) ifFalse:		"Must have 128-bit header"
- 		[^PrimErrGenericFailure].
  
+ 	savedInHashes := self allocateSlots: (self numSlotsForBytes: (self numSlotsOf: arrayOfObjects) * 4)
+ 							format: self firstLongFormat
+ 							classIndex: self thirtyTwoBitLongsClassIndexPun.
+ 	savedOutHashes := self allocateSlots: (self numSlotsForBytes: (self numSlotsOf: outPointerArray) * 4)
+ 							format: self firstLongFormat
+ 							classIndex: self thirtyTwoBitLongsClassIndexPun.
+ 	(savedInHashes isNil or: [savedOutHashes isNil]) ifTrue:
+ 		[^PrimErrNoMemory].
+ 	fillValue := self wordSize = 4 ifTrue: [self maxIdentityHash + 1] ifFalse: [self maxIdentityHash + 1 << 32 + (self maxIdentityHash + 1)].
+ 	self fillObj: savedInHashes numSlots: (self numSlotsOf: savedInHashes) with: fillValue.
+ 	self fillObj: savedOutHashes numSlots: (self numSlotsOf: savedOutHashes) with: fillValue.
- 	firstOut := outPointerArray + self baseHeaderSize.
- 	lastOut := firstOut - self bytesPerOop.
  
+ 	segAddr := segmentWordArray + self baseHeaderSize.
+ 	endSeg := self addressAfter: segmentWordArray.
- 	limitSeg := segmentWordArray + self baseHeaderSize.
- 	endSeg := segmentWordArray + (self addressAfter: segmentWordArray).
  
+ 	"Write a version number for byte order and version check."
+ 	segAddr >= endSeg ifTrue: [^PrimErrGenericFailure].
+ 	self long32At: segAddr put: self imageSegmentVersion.
+ 	self long32At: segAddr + 4 put: self imageSegmentVersion.
+ 	segStart := segAddr := segAddr + self allocationUnit.
- 	"Allocate top 1/8 of segment for table of internal oops"
- 	firstIn := endSeg - ((self numSlotsOf: segmentWordArray) // 8).  "Take 1/8 of seg"
- 	lastIn := firstIn - self bytesPerOop.
  
+ 	self assert: self allObjectsUnmarked. "work to be done when the incremental GC is written"
- 	"N.B.  A side effect of this marking is that all forwarders are followed,
- 	 so while forwarders may exist in te heap they will *not* be reachable."
- 	self markAllExceptTransitiveClosureOf: arrayOfRoots.
  
+ 	0 to: (self numSlotsOf: arrayOfObjects) - 1 do:
+ 		[:i| | newSegAddrOrError |
+ 		objOop := self fetchPointer: i ofObject: arrayOfObjects.
+ 		self deny: ((self isImmediate: objOop) or: [self isForwarded: objOop]).
+ 		self storeLong32: i ofObject: savedInHashes withValue: (self rawHashBitsOf: objOop).
+ 		newSegAddrOrError := self copyObj: objOop toAddr: segAddr startAt: segStart stopAt: endSeg.
+ 		newSegAddrOrError < segStart ifTrue:
+ 			[^self return: newSegAddrOrError
+ 					restoringObjectsIn: arrayOfObjects savedHashes: savedInHashes
+ 					and: outPointerArray savedHashes: savedOutHashes].
+ 		 segAddr := newSegAddrOrError].
- 	"All external objects, and only they, are now marked."
- 	unmarkedClasses := self arrayOfUnmarkedClasses.
- 	(self isImmediate: unmarkedClasses) ifTrue:
- 		[^PrimErrGenericFailure].
  
+ 	(endSeg ~= segAddr
+ 	 and: [endSeg - segAddr < (self baseHeaderSize + self bytesPerSlot)]) ifTrue:
+ 		[^self return: PrimErrWritePastObject
+ 				restoringObjectsIn: arrayOfObjects savedHashes: savedInHashes
+ 				and: outPointerArray savedHashes: savedOutHashes].
- 	"Write a version number for byte order and version check, followed by the number of classes."
- 	limitSeg >= endSeg ifTrue: [^PrimErrGenericFailure].
- 	self long32At: limitSeg put: self imageSegmentVersion.
- 	self long32At: limitSeg + 4 put: (self numSlotsOf: unmarkedClasses).
- 	scanned := limitSeg := limitSeg + 8.
  
+ 	"Now scan, adding out pointers to the outPointersArray; all objects in arrayOfObjects
+ 	 have their hashes set to point to their copies in segmentWordArray."
+ 	outIndex := 0.
+ 	self fillObj: outPointerArray numSlots: (self numSlotsOf: outPointerArray) with: nilObj.
+ 	topHashBit := 1 bitShift: self identityHashFieldWidth - 1.
+ 	topOopBit := 1 bitShift: self bytesPerOop * 8 - 1.
+ 	objOop := self objectStartingAt: segStart.
+ 	[objOop < segAddr] whileTrue:
+ 		[| oop hash |
+ 		 oop := self fetchClassOfNonImm: objOop.
+ 		 (self isMarked: oop) ifFalse: "oop is a new outPointer; allocate its oop"
+ 			[outIndex := self newOutPointer: oop at: outIndex in: outPointerArray hashes: savedOutHashes topHashBit: topHashBit.
+ 			 outIndex = 0 ifTrue:"no room in outPointers; fail"
+ 				[^self return: PrimErrBadIndex
+ 						restoringObjectsIn: arrayOfObjects savedHashes: savedInHashes
+ 						and: outPointerArray savedHashes: savedOutHashes]].
+ 		 hash := self rawHashBitsOf: oop.
+ 		 self setClassIndexOf: objOop to: hash.
+ 		 0 to: (self numPointerSlotsOf: objOop) - 1 do:
+ 			[:i|
+ 			 oop := self fetchPointer: i ofObject: objOop.
+ 			 (self isNonImmediate: oop) ifTrue:
+ 				[(self isMarked: oop) ifFalse: "oop is a new outPointer; allocate its oop"
+ 					[outIndex := self newOutPointer: oop at: outIndex in: outPointerArray hashes: savedOutHashes topHashBit: topHashBit.
+ 					 outIndex = 0 ifTrue: "no room in outPointers; fail"
+ 						[^self return: PrimErrBadIndex
+ 								restoringObjectsIn: arrayOfObjects savedHashes: savedInHashes
+ 								and: outPointerArray savedHashes: savedOutHashes]].
+ 				 oop := self mappedOopOf: oop topHashBit: topHashBit topOopBit: topOopBit..
+ 				 self storePointerUnchecked: i ofObject: objOop withValue: oop]].
+ 		 objOop := self objectAfter: objOop limit: segAddr].
- 	"If there are any classes then copy them into the segment, and forward their oop."
- 	(self numSlotsOf: unmarkedClasses) > 0 ifTrue:
- 		[((lastIn := lastIn + self bytesPerOop) >= endSeg
- 		 or: [0 = (newSegLimit := self copyObj: arrayOfRoots toSegment: segmentWordArray addr: limitSeg stopAt: firstIn saveOopAt: lastIn)]) ifTrue:
- 			[lastIn := lastIn - self bytesPerWord.
- 			self restoreObjectsFrom: firstIn to: lastIn from: segmentWordArray + self baseHeaderSize to: limitSeg.
- 			self fillObj: outPointerArray numSlots: (self numSlotsOf: outPointerArray) with: nilObj.
- 			^PrimErrGenericFailure].
- 		limitSeg := newSegLimit].
  
+ 	self shorten: segmentWordArray toIndexableSize: segAddr - (segmentWordArray + self baseHeaderSize) / 4.
+ 	self shorten: outPointerArray toIndexableSize: outIndex.
+ 	^self return: PrimNoErr
+ 		restoringObjectsIn: arrayOfObjects savedHashes: savedInHashes
+ 		and: outPointerArray savedHashes: savedOutHashes!
- 	"Copy the array of roots into the segment, and forward its oop."
- 	((lastIn := lastIn + self bytesPerOop) >= endSeg
- 	 or: [0 = (newSegLimit := self copyObj: arrayOfRoots toSegment: segmentWordArray addr: limitSeg stopAt: firstIn saveOopAt: lastIn)]) ifTrue:
- 		[lastIn := lastIn - self bytesPerWord.
- 		self restoreObjectsFrom: firstIn to: lastIn from: segmentWordArray + self baseHeaderSize to: limitSeg.
- 		self fillObj: outPointerArray numSlots: (self numSlotsOf: outPointerArray) with: nilObj.
- 		^PrimErrGenericFailure].
- 	limitSeg := newSegLimit.
- 
- 	"Now traverse the objects copied to the segment so far, copying unmarked objects into the segment.
- 	 This is essentially the same algorithm as the breadth-first copying algorithm in scavenging."
- 	scanned := self objectStartingAt: scanned.
- 	[scanned < limitSeg] whileTrue:	
- 		[1 to: (self numPointerSlotsOf: scanned) do:
- 			[:i| | oop |
- 			 oop := self fetchPointer: i ofObject: scanned.
- 			 ((self isImmediate: oop) or: [(self isForwarded: oop) or: [self isMarked: oop]]) ifFalse:
- 				[((lastIn := lastIn + self bytesPerOop) >= endSeg
- 				  or: [0 = (newSegLimit := self copyObj: oop toSegment: segmentWordArray addr: limitSeg stopAt: firstIn saveOopAt: lastIn)]) ifTrue:
- 					[lastIn := lastIn - self bytesPerWord.
- 					self restoreObjectsFrom: firstIn to: lastIn from: segmentWordArray + self baseHeaderSize to: limitSeg.
- 					self fillObj: outPointerArray numSlots: (self numSlotsOf: outPointerArray) with: nilObj.
- 					^PrimErrGenericFailure].
- 				 limitSeg := newSegLimit]].
- 		scanned := self objectAfter: scanned].
- 
- 	"Now the primitive can not fail; traverse the objects in the segment, unforwarding the originals and mapping external oops."
- 	self flag: 'you are here']!

Item was removed:
- ----- Method: SpurMemoryManager>>unforward:from: (in category 'image segment in/out') -----
- unforward: obj1 from: obj2
- 	"Undo a forward: obj1 to: obj2 given that obj2 is a copy of obj1"
- 	self set: obj1 classIndexTo: (self classIndexOf: obj2) formatTo: (self formatOf: obj2).
- 	self storePointer: 0 ofForwarder: obj1 withValue: (self fetchPointer: 0 ofObject: obj2).
- 	(self rawNumSlotsOf: obj2) = 0 ifTrue:
- 		[self setRawNumSlotsOf: obj1 to: 0]!

Item was changed:
  ----- Method: StackInterpreter>>findClassContainingMethod:startingAt: (in category 'debug support') -----
  findClassContainingMethod: meth startingAt: classObj
  	| currClass classDict classDictSize methodArray i |
  	(objectMemory isOopForwarded: classObj)
  		ifTrue: [currClass := objectMemory followForwarded: classObj]
  		ifFalse: [currClass := classObj].
  	[self assert: (objectMemory isForwarded: currClass) not.
  	 classDict := objectMemory noFixupFollowField: MethodDictionaryIndex ofObject: currClass.
  	 self assert: (objectMemory isForwarded: classDict) not.
  	 classDictSize := objectMemory numSlotsOf: classDict.
+ 	 classDictSize > MethodArrayIndex ifTrue:
+ 		[methodArray := objectMemory noFixupFollowField: MethodArrayIndex ofObject: classDict.
+ 		 self assert: (objectMemory isForwarded: methodArray) not.
+ 		 i := 0.
+ 		 [i < (classDictSize - SelectorStart)] whileTrue:
+ 			[meth = (objectMemory noFixupFollowField: i ofObject: methodArray) ifTrue:
+ 				[^currClass].
+ 			 i := i + 1]].
- 	 methodArray := objectMemory noFixupFollowField: MethodArrayIndex ofObject: classDict.
- 	 self assert: (objectMemory isForwarded: methodArray) not.
- 	 i := 0.
- 	 [i < (classDictSize - SelectorStart)] whileTrue:
- 		[meth = (objectMemory noFixupFollowField: i ofObject: methodArray) ifTrue:
- 			[^currClass].
- 		 i := i + 1].
  	 currClass := self noFixupSuperclassOf: currClass.
  	 currClass = objectMemory nilObject] whileFalse.
  	^currClass		"method not found in superclass chain"!

Item was changed:
  ----- Method: StackInterpreter>>findSelectorAndClassForMethod:lookupClass:do: (in category 'debug support') -----
  findSelectorAndClassForMethod: meth lookupClass: startClass do: binaryBlock
  	"Search startClass' class hierarchy searching for method and if found, evaluate aBinaryBlock
  	 with the selector and class where the method is found.  Otherwise evaluate aBinaryBlock
  	 with doesNotUnderstand: and nil."
  	| currClass classDict classDictSize methodArray i |
  	currClass := startClass.
  	[classDict := objectMemory fetchPointer: MethodDictionaryIndex ofObject: currClass.
  	 classDictSize := objectMemory numSlotsOf: classDict.
+ 	 classDictSize > MethodArrayIndex ifTrue:
+ 		[methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: classDict.
+ 		 i := 0.
+ 		 [i <= (classDictSize - SelectorStart)] whileTrue:
+ 			[meth = (objectMemory fetchPointer: i ofObject: methodArray) ifTrue:
+ 				[^binaryBlock
+ 					value: (objectMemory fetchPointer: i + SelectorStart ofObject: classDict)
+ 					value: currClass].
+ 				i := i + 1]].
- 	 methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: classDict.
- 	 i := 0.
- 	 [i <= (classDictSize - SelectorStart)] whileTrue:
- 		[meth = (objectMemory fetchPointer: i ofObject: methodArray) ifTrue:
- 			[^binaryBlock
- 				value: (objectMemory fetchPointer: i + SelectorStart ofObject: classDict)
- 				value: currClass].
- 			i := i + 1].
  	 currClass := self superclassOf: currClass.
  	 currClass = objectMemory nilObject] whileFalse.
  	^binaryBlock    "method not found in superclass chain"
  		value: (objectMemory splObj: SelectorDoesNotUnderstand)
  		value: nil!

Item was changed:
  ----- Method: StackInterpreter>>findSelectorOfMethod: (in category 'debug support') -----
  findSelectorOfMethod: methArg
  	| meth classObj classDict classDictSize methodArray i |
  	(objectMemory addressCouldBeObj: methArg) ifFalse:
  		[^objectMemory nilObject].
  	(objectMemory isForwarded: methArg)
  		ifTrue: [meth := objectMemory followForwarded: methArg]
  		ifFalse: [meth := methArg].
  	 (objectMemory isOopCompiledMethod: meth) ifFalse:
  		[^objectMemory nilObject].
  	classObj := self safeMethodClassOf: meth.
  	(self addressCouldBeClassObj: classObj) ifTrue:
  		[classDict := objectMemory fetchPointer: MethodDictionaryIndex ofObject: classObj.
  		 classDictSize := objectMemory numSlotsOf: classDict.
+ 		 classDictSize > MethodArrayIndex ifTrue:
+ 			[methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: classDict.
+ 			 i := 0.
+ 			 [i < (classDictSize - SelectorStart)] whileTrue:
+ 				[meth = (objectMemory fetchPointer: i ofObject: methodArray) ifTrue:
+ 					[^(objectMemory fetchPointer: i + SelectorStart ofObject: classDict)].
+ 					 i := i + 1]]].
- 		 methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: classDict.
- 		 i := 0.
- 		 [i < (classDictSize - SelectorStart)] whileTrue:
- 			[meth = (objectMemory fetchPointer: i ofObject: methodArray) ifTrue:
- 				[^(objectMemory fetchPointer: i + SelectorStart ofObject: classDict)].
- 				 i := i + 1]].
  	^objectMemory nilObject!

Item was changed:
  ----- Method: StackInterpreter>>readableFormat: (in category 'image save/restore') -----
  readableFormat: imageVersion
  	"Anwer true if images of the given format are readable by this interpreter.
  	 Allows a virtual machine to accept selected older image formats."
  
  	^imageVersion = self imageFormatVersion "Float words in platform-order"
+ 	   or: [objectMemory hasSpurMemoryManagerAPI not "No compatibility version for Spur as yet"
+ 			and: [imageVersion = self imageFormatCompatibilityVersion]] "Float words in BigEndian order"!
- 	   or: [imageVersion = self imageFormatCompatibilityVersion] "Float words in BigEndian order"!



More information about the Vm-dev mailing list