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

commits at source.squeak.org commits at source.squeak.org
Tue Jun 22 22:09:06 UTC 2021


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

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

Name: VMMaker.oscog-eem.2972
Author: eem
Time: 22 June 2021, 3:08:58.533933 pm
UUID: d3fd6149-f8a8-495d-bdb0-57456ffa277c
Ancestors: VMMaker.oscog-eem.2971

Fix th woefully broken Spur shorten:toIndexableSize: which is needed ror ImageSegment loading and was hanging on by a thread.

To support this allow slimbridges throughout new space, and hence use objectAfterMaybeSlimBridge:limit: in place of objectAfter:limit: in all new space enumeration.  Also implement SpurMemoryManager>>memcpy:_:_: more fully.

Extend leak checking with GCCheckShorten, renaming all non-GC leak check operarions that used to use GCModeXXX names to GCCheckXXX.

Have cloneSimulation update byteCountText for evidence of progress when doing several slow leak checks.

TestingPrimitives is now one of the names defines at compile time.

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

Item was changed:
  ----- Method: BalloonEnginePlugin>>bitmapValue:bits:atX:y: (in category 'fills-bitmaps') -----
  bitmapValue: bmFill bits: bits atX: xp y: yp
  
  	| bmDepth bmRaster value rShift cMask r g b a |
  	<inline: true>
  
  	bmDepth := self bitmapDepthOf: bmFill.
  	bmRaster := self bitmapRasterOf: bmFill.
  	bmDepth = 32 ifTrue: [
+ 		value := (self cCoerce: bits to: 'int *') at: (bmRaster * yp) + xp.
- 		value := (self cCoerce: bits to:'int*') at: (bmRaster * yp) + xp.
  		(value ~= 0 and: [(value bitAnd: 16rFF000000) = 0])
  				ifTrue: [value := value bitOr: 16rFF000000].
  		^self uncheckedTransformColor: value].
  	"rShift - shift value to convert from pixel to word index"
  	rShift := self rShiftTable at: bmDepth.
  	value := self makeUnsignedFrom: 
+ 		((self cCoerce: bits to: 'int *') at: (bmRaster * yp) + (xp >> rShift)).
- 		((self cCoerce: bits to:'int*') at: (bmRaster * yp) + (xp >> rShift)).
  	"cMask - mask out the pixel from the word"
  	cMask := (1 << bmDepth) - 1.
  	"rShift - shift value to move the pixel in the word to the lowest bit position"
  	rShift := 32 - bmDepth - ((xp bitAnd: (1 << rShift - 1)) * bmDepth).
  	value := (value >> rShift) bitAnd: cMask.
  	bmDepth = 16 ifTrue: [
  		"Must convert by expanding bits"
  		value = 0 ifFalse: [
  			b := (value bitAnd: 31) << 3.		b := b + (b >> 5).
  			g := (value >> 5 bitAnd: 31) << 3.	g := g + (g >> 5).
  			r := (value >> 10 bitAnd: 31) << 3.	r := r + (r >> 5).
  			a := 255.
  			value := b + (g << 8) + (r << 16) + (a << 24)].
  	] ifFalse: [
  		"Must convert by using color map"
  		(self bitmapCmSizeOf: bmFill) = 0
  			ifTrue: [value := 0]
  			ifFalse: [value := self makeUnsignedFrom: ((self colormapOf: bmFill) at: value)].
  	].
+ 	^self uncheckedTransformColor: value!
- 	^self uncheckedTransformColor: value.!

Item was changed:
  ----- Method: CogVMSimulator>>cloneSimulation (in category 'debug support') -----
  cloneSimulation
  	| savedDisplayView savedDisplayForm savedQuitBlock savedTranscript |
  	savedDisplayView := displayView. displayView := nil.
  	savedDisplayForm := displayForm. displayForm = nil.
  	savedQuitBlock := quitBlock. quitBlock := nil.
  	savedTranscript := transcript. transcript := nil.
  
  	^[| theClone |
+ 	 self changed: #byteCountText.
  	 Smalltalk garbageCollect.
  	 theClone := self veryDeepCopy.
  	 theClone parent: self; transcript: Transcript.
  	 theClone objectMemory parent: objectMemory.
  	 theClone]
  		ensure:
  			[displayView := savedDisplayView.
  			 displayForm = savedDisplayForm.
  			 quitBlock := savedQuitBlock.
  			 transcript := savedTranscript]!

Item was changed:
  ----- Method: InterpreterPrimitives>>primitiveTestShortenIndexableSize (in category 'object access primitives') -----
  primitiveTestShortenIndexableSize
  	"Given an object with indexable pointer fields, reduce the size of the indexable fields
  	to the requested size. Answer the number of bytes freed, or zero if the object cannot
  	be shortened."
  	<option: #TestingPrimitives>
  	<export: true>
+ 	| array newSizeOop |
+ 	newSizeOop := self stackTop.
- 	| array newSize bytesFreed |
- 	newSize := self stackIntegerValue: 0.
  	array := self stackValue: 1.
+ 	((objectMemory isIntegerObject: newSizeOop)
+ 	 and: [(objectMemory integerValueOf: newSizeOop) between: 0 and: (self stSizeOf: array) - 1]) ifFalse:
+ 		[^self primitiveFailFor: PrimErrBadArgument].
+ 	(objectMemory canShorten: array) ifFalse:
+ 		[^self primitiveFailFor: PrimErrBadReceiver].
+ 	self methodReturnInteger: (objectMemory
+ 									shorten: array
+ 									toIndexableSize: (objectMemory integerValueOf: newSizeOop))!
- 	self pop: argumentCount + 1.
- 	bytesFreed := self shorten: array toIndexableSize: newSize.
- 	self pushInteger: bytesFreed!

Item was added:
+ ----- Method: Spur32BitMMLECoSimulator>>shorten:toIndexableSize: (in category 'indexing primitive support') -----
+ shorten: objOop toIndexableSize: indexableSize
+ 	self leakCheckShorten ifTrue:
+ 		[parent ifNil:
+ 			[| result |
+ 			 result := coInterpreter cloneSimulation objectMemory shorten: objOop toIndexableSize: indexableSize.
+ 			 Smalltalk garbageCollect]].
+ 	^super shorten: objOop toIndexableSize: indexableSize!

Item was added:
+ ----- Method: Spur32BitMMLESimulator>>shorten:toIndexableSize: (in category 'indexing primitive support') -----
+ shorten: objOop toIndexableSize: indexableSize
+ 	self leakCheckShorten ifTrue:
+ 		[parent ifNil:
+ 			[| result |
+ 			 result := coInterpreter cloneSimulation objectMemory shorten: objOop toIndexableSize: indexableSize.
+ 			 Smalltalk garbageCollect]].
+ 	^super shorten: objOop toIndexableSize: indexableSize!

Item was changed:
  ----- Method: Spur32BitMemoryManager>>changeClassOf:to: (in category 'interpreter access') -----
  changeClassOf: rcvr to: argClass
  	"Attempt to change the class of the receiver to the argument given that the
  	 format of the receiver matches the format of the argument.  If successful,
  	 answer 0, otherwise answer an error code indicating the reason for failure. 
  	 Fail if the format of the receiver is incompatible with the format of the argument,
  	 or if the argument is a fixed class and the receiver's size differs from the size
  	 that an instance of the argument should have."
  	<inline: false>
  	| classFormat fixedFields instFormat newFormat classIndex instSlots instBytes |
  	(self isObjImmutable: rcvr) ifTrue:
  		[^PrimErrNoModification].
  	classFormat := self formatOfClass: argClass.
  	fixedFields := self fixedFieldsOfClassFormat: classFormat.
  	classFormat := self instSpecOfClassFormat: classFormat.
  	instFormat := self formatOf: rcvr.
  
  	"Fail for inability to access classIndex before making contexts snapshot-safe."
  	(classIndex := self ensureBehaviorHash: argClass) < 0 ifTrue:
  		[^classIndex negated].
  
  	"Now check the instance for compatibility and compute odd bits if necessary."
  	classFormat <= self lastPointerFormat
  		ifTrue:
  			[instFormat > self lastPointerFormat ifTrue:
  				[^PrimErrInappropriate].
  			 ((instSlots := self numSlotsOf: rcvr) < fixedFields
  			  or: [instSlots > fixedFields and: [self isFixedSizePointerFormat: classFormat]]) ifTrue:
  				[^PrimErrBadReceiver].
  			 (instFormat = self indexablePointersFormat
  			  and: [self isContextNonImm: rcvr]) ifTrue:
  				[coInterpreter makeContextSnapshotSafe: rcvr].
  			 newFormat := classFormat]
  		ifFalse:
  			["Fail if the class's format is somehow invalid."
+ 			 classFormat ~= (self classFormatFromInstFormat: classFormat) ifTrue:
- 			 classFormat ~= (self classFormatForInstanceFormat: classFormat) ifTrue:
  				[^PrimErrBadArgument].
  
  			 instBytes := self numBytesOf: rcvr.
  			 classFormat
  				caseOf: {
  				[self sixtyFourBitIndexableFormat]
  					-> [(instBytes anyMask: 7) ifTrue: [^PrimErrBadReceiver].
  						newFormat := classFormat].
  				[self firstLongFormat] 		
  					-> [(instBytes anyMask: 3) ifTrue: [^PrimErrBadReceiver].
  						newFormat := classFormat].
  				[self firstShortFormat] 		
  					-> [(instBytes anyMask: 1) ifTrue: [^PrimErrBadReceiver].
  						newFormat := classFormat + (2 - (instBytes >> 1) bitAnd: 1)].
  				[self firstByteFormat]
  					-> [newFormat := classFormat + (4 - instBytes bitAnd: 3)].
  				[self firstCompiledMethodFormat]
  					-> [classFormat ~= self firstCompiledMethodFormat ifTrue:
  							[^PrimErrInappropriate].
  						newFormat := instFormat] }
  				otherwise: "bits instances cannot be adopted by pointer-like classes..."
  					[^PrimErrInappropriate]].
  
  	self set: rcvr classIndexTo: classIndex formatTo: newFormat.
  
  	self assert: (self numBytesOf: rcvr) = (classFormat <= self lastPointerFormat
  											ifTrue: [instSlots * self bytesPerOop]
  											ifFalse: [instBytes]).
  	"ok"
  	^0!

Item was changed:
  ----- Method: Spur32BitMemoryManager>>hackSlimBridgeTo:at: (in category 'object enumeration-private') -----
+ hackSlimBridgeTo: objOop at: startAddress
- hackSlimBridgeTo: firstEdenObject at: lastWordInPastSpace
  	"This is a horrible hack for getting to the first object in eden if pastSpace is almost full.
  	 If there is only one (64-bit) word at the end of pastSpace there is no room for a full
  	 bridge, but there is room for this hack."
  	self flag: #endianness.
+ 	self assert: (self oop: startAddress isLessThan: objOop).
+ 	self assert: (self oop: objOop isLessThanOrEqualTo: oldSpaceStart).
+ 	self assert: (startAddress + self allocationUnit = objOop
+ 				or: [startAddress + self allocationUnit + self allocationUnit = objOop]).
+ 	self longAt: startAddress
+ 		put: (startAddress + self allocationUnit = objOop ifTrue: [0] ifFalse: [1]).
+ 	self longAt: startAddress + 4
+ 		put: self numSlotsMask << self numSlotsHalfShift!
- 	self assert: lastWordInPastSpace = pastSpaceStart.
- 	self assert: lastWordInPastSpace + self baseHeaderSize = scavenger eden start.
- 	self longAt: lastWordInPastSpace
- 		put: (firstEdenObject = scavenger eden start ifTrue: [0] ifFalse: [1]).
- 	self longAt: lastWordInPastSpace + 4 put: self numSlotsMask << self numSlotsHalfShift!

Item was added:
+ ----- Method: Spur32BitMemoryManager>>normalisedFormatFor:indexableSize: (in category 'indexing primitive support') -----
+ normalisedFormatFor: objOop indexableSize: indexableSize
+ 	"Answer the format for an objOop clone with indexableSize.  Needs to work for longFormat and arrayFormat only."
+ 	^self classFormatFromInstFormat: (self formatOf: objOop)!

Item was changed:
  ----- 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] }
+ 		otherwise:
+ 			[self assertf: 'invalid format for shortening'. 0]!
- 	^(self formatOf: objOop) caseOf:
- 		{ [self arrayFormat]			-> [indexableSize].
- 		  [self firstLongFormat]		-> [self numSlotsForBytes: indexableSize * 4] }!

Item was changed:
  ----- Method: Spur32BitMemoryManager>>objectAfterMaybeSlimBridge:limit: (in category 'object enumeration-private') -----
  objectAfterMaybeSlimBridge: objOop limit: limit
  	"Object parsing.
  	1. all objects have at least a word following the header, for a forwarding pointer.
  	2. objects with an overflow size have a preceding word with a saturated numSlots.  If the word
  	   following an object doesn't have a saturated numSlots field it must be a single-header object.
  	   If the word following does have a saturated numSlots it must be the overflow size word.
  	This variation on objectAfter:limit: allows for a single (64-bit) word bridge which may be needed
  	to bridge from an almost full pastSpace to eden.  It is only used in the flat enumerators that use
  	startAddressForBridgedHeapEnumeration and enumerate over pastSpace, eden and oldSpace
  	in that order.  Note that the order for allObjects, and allInstances enumerates over oldSpace first.
  
  	This hack is cheap.  It increases the size of the objectAfter code, but saves two extra copies of
  	the inner loop, since the inner loop now enumerates over all of pastSpace, eden and oldSpace.
  	The test for a slim bridge is only performed if applied to an overflow header, and typically only
  	 1 in 400 objects have overflow headers in 32-bits, 1 in 500 in 64-bits.  The complication is that
  	image segment loading evaporates the word array by setting the overflow slots to 1, and this
  	is ambiguous with a slimbridge.  The resolution is that slimbridges are used only in new space."
  	<inline: true>
  	| followingWordAddress followingWord |
  	followingWordAddress := self addressAfter: objOop.
  	(self oop: followingWordAddress isGreaterThanOrEqualTo: limit) ifTrue:
  		[^limit].
  	self flag: #endianness.
  	followingWord := self longAt: followingWordAddress + 4.
  	^followingWord >> self numSlotsHalfShift = self numSlotsMask
+ 		ifTrue: [((self oop: objOop isLessThan: oldSpaceStart)
- 		ifTrue: [((self oop: objOop isGreaterThanOrEqualTo: oldSpaceStart)
  				 and: [1 = (self longAt: followingWordAddress)]) "i.e. the raw overflow slots in the overflow word"
+ 					ifTrue: [followingWordAddress + self baseHeaderSize + self baseHeaderSize] "skip the one word slimbridge"
- 					ifTrue: [followingWordAddress + self baseHeaderSize + self baseHeaderSize]
  					ifFalse: [followingWordAddress + self baseHeaderSize]]
  		ifFalse: [followingWordAddress]!

Item was changed:
  ----- Method: Spur32BitMemoryManager>>rawOverflowSlotsOf:put: (in category 'object access') -----
  rawOverflowSlotsOf: objOop put: numSlots
  	<returnTypeC: #usqInt>
  	<inline: true>
  	self flag: #endianness.
- 	self deny: (numSlots = 1 and: [self oop: objOop isLessThan: newSpaceLimit]). "otherwise ambiguous with a slimbridge"
  	^self longAt: objOop - self baseHeaderSize put: numSlots!

Item was removed:
- ----- Method: Spur32BitMemoryManager>>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.
- 	 Answer the number of bytes returned to free memory, which may be zero if no change
- 	 was possible."
- 	<inline: false>
- 	<api>
- 	| numSlots bytesBefore delta copy freeChunk |
- 	self assert: (self oop: (self addressAfter: objOop) isLessThanOrEqualTo: endOfMemory).
- 	numSlots := self numSlotsForShortening: objOop toIndexableSize: indexableSize.
- 	numSlots = (self numSlotsOf: objOop) ifTrue:
- 		[^0].
- 	bytesBefore := self bytesInObject: objOop.
- 	delta := bytesBefore - (self objectBytesForSlots: numSlots).
- 
- 	(delta > 0
- 	 and: [delta <= self allocationUnit]) ifTrue:
- 		[copy := self allocateSlots: numSlots
- 					format: (self formatOf: objOop)
- 					classIndex: (self classIndexOf: objOop).
- 		 copy ifNil: [self error: 'shorten:toIndexableSize: attempted to shorten to allocationUnit!!'].
- 		 0 to: numSlots - 1 do:
- 			[:i|
- 			self storePointerUnchecked: i
- 				ofObject: copy
- 				withValue: (self fetchPointer: i ofObject: objOop)].
- 		 (self isRemembered: objOop) ifTrue:
- 			[scavenger remember: copy].
- 		 self forward: objOop to: copy.
- 		 ^0].
- 
- 	(self hasOverflowHeader: objOop)
- 		ifTrue:
- 			[self rawOverflowSlotsOf: objOop put: numSlots.
- 			 numSlots < self numSlotsMask ifTrue:
- 				[delta := delta - self allocationUnit]]
- 		ifFalse:
- 			[self assert: numSlots < self numSlotsMask.
- 			 self rawNumSlotsOf: objOop put: numSlots].
- 
- 	self assert: (self oop: (self addressAfter: objOop) + delta isLessThanOrEqualTo: endOfMemory).
- 	"Since the 32-bit system rounds objects up to 64-bits, loosing
- 	 a slot may not actually change the bytes occupied by the object."
- 	delta = 0 ifTrue:
- 		[^0].
- 
- 	freeChunk := self initFreeChunkWithBytes: delta at: (self addressAfter: objOop).
- 	self assert: (self addressAfter: freeChunk) <= endOfMemory.
- 	(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!

Item was added:
+ ----- Method: Spur32BitMemoryManager>>updateFormatOfShortenedObject:to: (in category 'indexing primitive support') -----
+ updateFormatOfShortenedObject: objOop to: indexableSize
+ 	"This is currently a noop on 32-bits. It will need to be implemented if
+ 	 shortening of 16-bit or 8-bit pure bits objects is ever supported."!

Item was added:
+ ----- Method: Spur64BitMMLECoSimulator>>shorten:toIndexableSize: (in category 'indexing primitive support') -----
+ shorten: objOop toIndexableSize: indexableSize
+ 	self leakCheckShorten ifTrue:
+ 		[parent ifNil:
+ 			[| result |
+ 			 result := coInterpreter cloneSimulation objectMemory shorten: objOop toIndexableSize: indexableSize.
+ 			 Smalltalk garbageCollect]].
+ 	^super shorten: objOop toIndexableSize: indexableSize!

Item was added:
+ ----- Method: Spur64BitMMLESimulator>>shorten:toIndexableSize: (in category 'indexing primitive support') -----
+ shorten: objOop toIndexableSize: indexableSize
+ 	self leakCheckShorten ifTrue:
+ 		[parent ifNil:
+ 			[| result |
+ 			 result := coInterpreter cloneSimulation objectMemory shorten: objOop toIndexableSize: indexableSize.
+ 			 Smalltalk garbageCollect]].
+ 	^super shorten: objOop toIndexableSize: indexableSize!

Item was changed:
  ----- Method: Spur64BitMemoryManager>>changeClassOf:to: (in category 'interpreter access') -----
  changeClassOf: rcvr to: argClass
  	"Attempt to change the class of the receiver to the argument given that the
  	 format of the receiver matches the format of the argument.  If successful,
  	 answer 0, otherwise answer an error code indicating the reason for failure. 
  	 Fail if the format of the receiver is incompatible with the format of the argument,
  	 or if the argument is a fixed class and the receiver's size differs from the size
  	 that an instance of the argument should have."
  	<inline: false>
  	| classFormat fixedFields instFormat newFormat classIndex instSlots instBytes |
  	(self isObjImmutable: rcvr) ifTrue:
  		[^PrimErrNoModification].
  	classFormat := self formatOfClass: argClass.
  	fixedFields := self fixedFieldsOfClassFormat: classFormat.
  	classFormat := self instSpecOfClassFormat: classFormat.
  	instFormat := self formatOf: rcvr.
  
  	"Fail for inability to access classIndex before making contexts snapshot-safe."
  	(classIndex := self ensureBehaviorHash: argClass) < 0 ifTrue:
  		[^classIndex negated].
  
  	"Now check the instance for compatibility and compute odd bits if necessary."
  	classFormat <= self lastPointerFormat
  		ifTrue:
  			[instFormat > self lastPointerFormat ifTrue:
  				[^PrimErrInappropriate].
  			 ((instSlots := self numSlotsOf: rcvr) < fixedFields
  			  or: [instSlots > fixedFields and: [self isFixedSizePointerFormat: classFormat]]) ifTrue:
  				[^PrimErrBadReceiver].
  			 (instFormat = self indexablePointersFormat
  			  and: [self isContextNonImm: rcvr]) ifTrue:
  				[coInterpreter makeContextSnapshotSafe: rcvr].
  			 newFormat := classFormat]
  		ifFalse:
  			["Fail if the class's format is somehow invalid."
+ 			 classFormat ~= (self classFormatFromInstFormat: classFormat) ifTrue:
- 			 classFormat ~= (self classFormatForInstanceFormat: classFormat) ifTrue:
  				[^PrimErrBadArgument].
  
  			 instBytes := self numBytesOf: rcvr.
  			 classFormat
  				caseOf: {
  				[self sixtyFourBitIndexableFormat]
  					-> [(instBytes anyMask: 7) ifTrue: [^PrimErrBadReceiver].
  						newFormat := classFormat].
  				[self firstLongFormat] 		
  					-> [(instBytes anyMask: 3) ifTrue: [^PrimErrBadReceiver].
  						newFormat := classFormat + (2 - (instBytes >> 2) bitAnd: 1)].
  				[self firstShortFormat] 		
  					-> [(instBytes anyMask: 1) ifTrue: [^PrimErrBadReceiver].
  						newFormat := classFormat + (4 - (instBytes >> 1) bitAnd: 3)].
  				[self firstByteFormat]
  					-> [newFormat := classFormat + (8 - instBytes bitAnd: 7)].
  				[self firstCompiledMethodFormat]
  					-> [classFormat ~= self firstCompiledMethodFormat ifTrue:
  							[^PrimErrInappropriate].
  						newFormat := instFormat] }
  				otherwise: "bits instances cannot be adopted by pointer-like classes..."
  					[^PrimErrInappropriate]].
  
  	self set: rcvr classIndexTo: classIndex formatTo: newFormat.
  
  	self assert: (self numBytesOf: rcvr) = (classFormat <= self lastPointerFormat
  											ifTrue: [instSlots * self bytesPerOop]
  											ifFalse: [instBytes]).
  	"ok"
  	^0!

Item was changed:
  ----- Method: Spur64BitMemoryManager>>hackSlimBridgeTo:at: (in category 'object enumeration-private') -----
+ hackSlimBridgeTo: objOop at: startAddress
- hackSlimBridgeTo: firstEdenObject at: lastWordInPastSpace
  	"This is a horrible hack for getting to the first object in eden if pastSpace is almost full.
  	 If there is only one (64-bit) word at the end of pastSpace there is no room for a full
  	 bridge, but there is room for this hack."
+ 	self assert: (self oop: startAddress isLessThan: objOop).
+ 	self assert: (self oop: objOop isLessThanOrEqualTo: oldSpaceStart).
+ 	self assert: (startAddress + self allocationUnit = objOop
+ 				or: [startAddress + self allocationUnit + self allocationUnit = objOop]).
+ 	self longAt: startAddress
+ 		put: (startAddress + self allocationUnit = objOop
- 	self assert: lastWordInPastSpace = pastSpaceStart.
- 	self assert: lastWordInPastSpace + self baseHeaderSize = scavenger eden start.
- 	self longAt: lastWordInPastSpace
- 		put: (firstEdenObject = scavenger eden start
  				ifTrue: [self numSlotsMask << self numSlotsFullShift]
  				ifFalse: [self numSlotsMask << self numSlotsFullShift + 1])!

Item was added:
+ ----- Method: Spur64BitMemoryManager>>normalisedFormatFor:indexableSize: (in category 'indexing primitive support') -----
+ normalisedFormatFor: objOop indexableSize: indexableSize
+ 	"Answer the format for an objOop clone with indexableSize.  Needs to work for longFormat and arrayFormat only."
+ 	| format |
+ 	format := self classFormatFromInstFormat: (self formatOf: objOop).
+ 	^(format = self firstLongFormat and: [indexableSize anyMask: 1])
+ 		ifTrue: [format + 1]
+ 		ifFalse: [format]!

Item was changed:
  ----- 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] }
+ 		otherwise:
+ 			[self assertf: 'invalid format for shortening'. 0]!
- 		  [self firstLongFormat + 1]	-> [self numSlotsForBytes: indexableSize * 4] }!

Item was changed:
  ----- Method: Spur64BitMemoryManager>>objectAfterMaybeSlimBridge:limit: (in category 'object enumeration-private') -----
  objectAfterMaybeSlimBridge: objOop limit: limit
  	"Object parsing.
  	1. all objects have at least a word following the header, for a forwarding pointer.
  	2. objects with an overflow size have a preceding word with a saturated numSlots.  If the word
  	   following an object doesn't have a saturated numSlots field it must be a single-header object.
  	   If the word following does have a saturated numSlots it must be the overflow size word.
  	This variation on objectAfter:limit: allows for a single (64-bit) word bridge which may be needed
  	to bridge from an almost full pastSpace to eden.  It is only used in the flat enumerators that use
  	startAddressForBridgedHeapEnumeration and enumerate over pastSpace, eden and oldSpace
  	in that order.  Note that the order for allObjects, and allInstances enumerates over oldSpace first.
  
  	This hack is cheap.  It increases the size of the objectAfter code, but saves two extra copies of
  	the inner loop, since the inner loop now enumerates over all of pastSpace, eden and oldSpace.
  	The test for a slim bridge is only performed if applied to an overflow header, and typically only
  	1 in 400 objects have overflow headers in 32-bits, 1 in 500 in 64-bits.  The complication is that
  	image segment loading evaporates the word array by setting the overflow slots to 1, and this
  	is ambiguous with a slimbridge.  The resolution is that slimbridges are used only in new space."
  	<inline: true>
  	| followingWordAddress followingWord |
  	followingWordAddress := self addressAfter: objOop.
  	(self oop: followingWordAddress isGreaterThanOrEqualTo: limit) ifTrue:
  		[^limit].
  	self flag: #endianness.
  	followingWord := self longAt: followingWordAddress.
  	^followingWord >> self numSlotsFullShift = self numSlotsMask
  		ifTrue:
+ 			[((self oop: objOop isLessThan: oldSpaceStart)
- 			[((self oop: objOop isGreaterThanOrEqualTo: oldSpaceStart)
  			 and: [(followingWord bitAnd: 16rFFFFFFFFFFFFFF) = 1])
+ 				ifTrue: [followingWordAddress + self baseHeaderSize + self baseHeaderSize] "skip the one word slimbridge"
- 				ifTrue: [followingWordAddress + self baseHeaderSize + self baseHeaderSize]
  				ifFalse: [followingWordAddress + self baseHeaderSize]]
  		ifFalse: [followingWordAddress]!

Item was changed:
  ----- Method: Spur64BitMemoryManager>>rawOverflowSlotsOf:put: (in category 'object access') -----
  rawOverflowSlotsOf: objOop put: numSlots
  	<returnTypeC: #usqLong>
  	<inline: true>
  	self flag: #endianness.
- 	self deny: (numSlots = 1 and: [self oop: objOop isLessThan: newSpaceLimit]). "otherwise ambiguous with a slimbridge"
  	self longAt: objOop - self baseHeaderSize put: self numSlotsMask << 56 + numSlots.
  	^numSlots!

Item was removed:
- ----- Method: Spur64BitMemoryManager>>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.
- 	 Answer the number of bytes returned to free memory, which may be zero if no change
- 	 was possible."
- 	<inline: false>
- 	<api>
- 	| numSlots bytesBefore delta copy freeChunk |
- 	numSlots := self numSlotsForShortening: objOop toIndexableSize: indexableSize.
- 	numSlots = (self numSlotsOf: objOop) ifTrue:
- 		[^0].
- 	bytesBefore := self bytesInObject: objOop.
- 	delta := bytesBefore - (self objectBytesForSlots: numSlots).
- 
- 	self flag: 'this should update format for 32-bit indexable words; too lazy today.'.
- 
- 	delta = 0 ifTrue:
- 		[^0].
- 
- 	delta <= self allocationUnit ifTrue:
- 		[copy := self allocateSlots: numSlots
- 					format: (self formatOf: objOop)
- 					classIndex: (self classIndexOf: objOop).
- 		 copy ifNil: [self error: 'shorten:toIndexableSize: attempted to shorten to allocationUnit!!'].
- 		 0 to: numSlots - 1 do:
- 			[:i|
- 			self storePointerUnchecked: i
- 				ofObject: copy
- 				withValue: (self fetchPointer: i ofObject: objOop)].
- 		 (self isRemembered: objOop) ifTrue:
- 			[scavenger remember: copy].
- 		 self forward: objOop to: copy.
- 		 ^0].
- 
- 	(self hasOverflowHeader: objOop)
- 		ifTrue:
- 			[self rawOverflowSlotsOf: objOop put: numSlots.
- 			 numSlots < self numSlotsMask ifTrue:
- 				[delta := delta - self allocationUnit]]
- 		ifFalse:
- 			[self assert: numSlots < self numSlotsMask.
- 			 self rawNumSlotsOf: objOop put: numSlots].
- 
- 	freeChunk := self initFreeChunkWithBytes: delta at: (self addressAfter: objOop).
- 	self assert: (self addressAfter: freeChunk) <= endOfMemory.
- 	(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!

Item was added:
+ ----- Method: Spur64BitMemoryManager>>updateFormatOfShortenedObject:to: (in category 'indexing primitive support') -----
+ updateFormatOfShortenedObject: objOop to: indexableSize
+ 	"Update the odd bits of a word object, if required. It will need to be extended if
+ 	 shortening of 16-bit or 8-bit pure bits objects is ever supported."
+ 	((self formatOf: objOop) between: self firstLongFormat and: self firstLongFormat + 1) ifTrue:
+ 		[self setFormatOf: objOop to: self firstLongFormat + (indexableSize bitAnd: 1)]!

Item was added:
+ ----- Method: SpurGenerationScavenger>>printSpaces (in category 'debug support') -----
+ printSpaces
+ 	coInterpreter print: 'eden start '; printHex: eden start; print: ' end/free '; printHex: manager freeStart; print: ' limit '; printHex: eden limit; cr.
+ 	coInterpreter print: 'past start '; printHex: pastSpace start; print: ' end '; printHex: manager pastSpaceStart; print: ' limit '; printHex: pastSpace limit; cr.
+ 	coInterpreter print: 'future start '; printHex: futureSpace start; print: ' survivorStart '; printHex: futureSurvivorStart; print: ' limit '; printHex: futureSpace limit; cr!

Item was changed:
  ----- Method: SpurImageSegmentTests>>testSaveHashedCollectionAndAllSubclasses (in category 'tests') -----
  testSaveHashedCollectionAndAllSubclasses
  	SimulatorHarnessForTests new
  		withExecutableInterpreter: self initializedVM
  		do: [:vm :harness| | error objects |
  			CheckForLeaks == true ifTrue: "CheckForLeaks := self confirm: 'Check for leaks?'"
+ 				[vm objectMemory setCheckForLeaks: (vm objectMemory class bindingOf: #GCCheckImageSegment) value].
- 				[vm objectMemory setCheckForLeaks: (vm objectMemory class bindingOf: #GCModeImageSegment) value].
  			error := harness findSymbol: #error.
  			self deny: error isNil.
  			objects := harness
  				interpreter: vm
  				object: (harness findClassNamed: 'Compiler')
  				perform: (harness findSymbol: #evaluate:)
  				withArguments: {vm objectMemory stringForCString:
  					'[| seg out roots result |
  					 seg := WordArray new: 1024 * 1024.
  					 out := Array new: 512.
  					 roots := HashedCollection withAllSubclasses asArray.
  					 roots := roots, (roots collect: [:ea| ea class]).
  					 (thisContext isPrimFailToken: (nil tryPrimitive: 98 withArgs: { roots. seg. out })) ifTrue:
  						[^#error].
  					 result := { seg. out }.
  					 (thisContext isPrimFailToken: (nil tryPrimitive: 99 withArgs: result)) ifTrue:
  						[^#error].
  					 result]
  						on: Error
  						do: [:ex| ^#error]'}.
  			self deny: objects = error]!

Item was changed:
  ----- Method: SpurImageSegmentTests>>testSaveHashedCollectionSubclasses (in category 'tests') -----
  testSaveHashedCollectionSubclasses
  	SimulatorHarnessForTests new
  		withExecutableInterpreter: self initializedVM
  		do: [:vm :harness| | error objects |
  			CheckForLeaks == true ifTrue: "CheckForLeaks := self confirm: 'Check for leaks?'"
+ 				[vm objectMemory setCheckForLeaks: (vm objectMemory class bindingOf: #GCCheckImageSegment) value].
- 				[vm objectMemory setCheckForLeaks: (vm objectMemory class bindingOf: #GCModeImageSegment) value].
  			error := harness findSymbol: #error.
  			self deny: error isNil.
  			objects := harness
  				interpreter: vm
  				object: (harness findClassNamed: 'Compiler')
  				perform: (harness findSymbol: #evaluate:)
  				withArguments: {vm objectMemory stringForCString:
  					'[| seg out roots result |
  					 seg := WordArray new: 1024 * 1024.
  					 out := Array new: 256.
  					 roots := HashedCollection subclasses asArray.
  					 roots := roots, (roots collect: [:ea| ea class]).
  					 (thisContext isPrimFailToken: (nil tryPrimitive: 98 withArgs: { roots. seg. out })) ifTrue:
  						[^#error].
  					 result := { seg. out }.
  					 (thisContext isPrimFailToken: (nil tryPrimitive: 99 withArgs: result)) ifTrue:
  						[^#error].
  					 result]
  						on: Error
  						do: [:ex| ^#error]'}.
  			self deny: objects = error]!

Item was changed:
  CogClass subclass: #SpurMemoryManager
(excessive size, no diff calculated)

Item was changed:
  ----- Method: SpurMemoryManager>>allEntitiesFrom:do: (in category 'object enumeration-private') -----
  allEntitiesFrom: initialObject do: aBlock
  	<inline: true>
+ 	| prevObj prevPrevObj obj |
- 	| prevObj prevPrevObj objOop |
  	prevPrevObj := prevObj := nil.
+ 	obj := initialObject.
- 	objOop := initialObject.
  	self enableObjectEnumerationFrom: initialObject.
+ 	[self assert: obj \\ self allocationUnit = 0.
+ 	 self oop: obj isLessThan: endOfMemory] whileTrue:
+ 		[self assert: (self long64At: obj) ~= 0.
+ 		 aBlock value: obj.
- 	[self assert: objOop \\ self allocationUnit = 0.
- 	 self oop: objOop isLessThan: endOfMemory] whileTrue:
- 		[self assert: (self long64At: objOop) ~= 0.
- 		 aBlock value: objOop.
  		 prevPrevObj := prevObj.
+ 		 prevObj := obj.
+ 		 obj := self objectAfterMaybeSlimBridge: obj limit: endOfMemory.
+ 		 self assert: (self oop: obj isGreaterThan: prevObj)].
- 		 prevObj := objOop.
- 		 objOop := self objectAfterMaybeSlimBridge: objOop limit: endOfMemory].
  	self touch: prevPrevObj.
  	self touch: prevObj!

Item was changed:
  ----- Method: SpurMemoryManager>>allNewSpaceEntitiesDo: (in category 'object enumeration-private') -----
  allNewSpaceEntitiesDo: aBlock
  	"Enumerate all new space objects, including free objects."
  	<inline: true>
  	| start prevObj prevPrevObj objOop |
  	prevPrevObj := prevObj := nil.
  	"After a scavenge eden is empty, futureSpace is empty, and all newSpace objects are
  	  in pastSpace.  Objects are allocated in eden.  So enumerate only pastSpace and eden."
  	self assert: (scavenger pastSpace start < scavenger eden start).
  	start := self startAddressForBridgedHeapEnumeration.
  	start > freeStart ifTrue: [^self].
  	self bridgePastSpaceAndEden.
  	objOop := self objectStartingAt: start.
  	[self oop: objOop isLessThan: freeStart] whileTrue:
  		[aBlock value: objOop.
  		 prevPrevObj := prevObj.
  		 prevObj := objOop.
+ 		 objOop := self objectAfterMaybeSlimBridge: objOop limit: freeStart].
- 		 objOop := self objectAfter: objOop limit: freeStart].
  	self touch: prevPrevObj.
  	self touch: prevObj!

Item was changed:
  ----- Method: SpurMemoryManager>>allPastSpaceEntitiesDo: (in category 'object enumeration-private') -----
  allPastSpaceEntitiesDo: aBlock
  	"Enumerate all past space objects, including free objects."
  	<inline: true>
  	| prevObj prevPrevObj objOop |
  	prevPrevObj := prevObj := nil.
  	objOop := self objectStartingAt: scavenger pastSpace start.
  	[self oop: objOop isLessThan: pastSpaceStart] whileTrue:
  		[aBlock value: objOop.
  		 prevPrevObj := prevObj.
  		 prevObj := objOop.
+ 		 objOop := self objectAfterMaybeSlimBridge: objOop limit: pastSpaceStart].
- 		 objOop := self objectAfter: objOop limit: pastSpaceStart].
  	self touch: prevPrevObj.
  	self touch: prevObj!

Item was added:
+ ----- Method: SpurMemoryManager>>canShorten: (in category 'indexing primitive support') -----
+ canShorten: objOop
+ 	^(self isNonImmediate: objOop)
+ 	 and: [(self numSlotsOf: objOop) > 0
+ 	 and: [(self isArrayNonImm: objOop) or: [self isWordsNonImm: objOop]]]!

Item was changed:
  ----- Method: SpurMemoryManager>>checkFreeSpace: (in category 'debug support') -----
  checkFreeSpace: gcModes
  	<api>
  	self assert: self bitsSetInFreeSpaceMaskForAllFreeLists.
  	self assert: totalFreeOldSpace = self totalFreeListBytes.
  	(gcModes > 0
+ 	 and: [checkForLeaks allMask: (GCCheckFreeSpace bitOr: gcModes)]) ifTrue:
+ 		[self runLeakCheckerForFreeSpace: GCCheckFreeSpace ignoring: nil]!
- 	 and: [checkForLeaks allMask: (GCModeFreeSpace bitOr: gcModes)]) ifTrue:
- 		[self runLeakCheckerForFreeSpace: GCModeFreeSpace ignoring: nil]!

Item was changed:
  ----- Method: SpurMemoryManager>>checkFreeSpace:ignoring: (in category 'debug support') -----
  checkFreeSpace: gcModes ignoring: anOopToIgnore
  	<api>
  	self assert: self bitsSetInFreeSpaceMaskForAllFreeLists.
  	self assert: totalFreeOldSpace = self totalFreeListBytes.
  	(gcModes > 0
+ 	 and: [checkForLeaks allMask: (GCCheckFreeSpace bitOr: gcModes)]) ifTrue:
+ 		[self runLeakCheckerForFreeSpace: GCCheckFreeSpace ignoring: anOopToIgnore]!
- 	 and: [checkForLeaks allMask: (GCModeFreeSpace bitOr: gcModes)]) ifTrue:
- 		[self runLeakCheckerForFreeSpace: GCModeFreeSpace ignoring: anOopToIgnore]!

Item was removed:
- ----- Method: SpurMemoryManager>>classFormatForInstanceFormat: (in category 'header format') -----
- classFormatForInstanceFormat: aFormat
- 	"Clear any odd bits from the format so that it matches its class's format"
- 	aFormat < self firstLongFormat ifTrue:
- 		[^aFormat].
- 	aFormat >= self firstByteFormat ifTrue:
- 		[^aFormat bitAnd: -8].
- 	^aFormat >= self firstShortFormat
- 		ifTrue: [aFormat bitAnd: -4]
- 		ifFalse: [aFormat bitAnd: -2]!

Item was added:
+ ----- Method: SpurMemoryManager>>doShorten:toIndexableSize: (in category 'indexing primitive support') -----
+ doShorten: 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.
+ 	 Answer the number of bytes returned to free memory, which may be zero if no change
+ 	 was possible."
+ 	<inline: false>
+ 	<api>
+ 	| followingAddress numSlots bytesBefore delta copy freeChunk |
+ 	followingAddress := self addressAfter: objOop. "for assert checking"
+ 	self assert: (self oop: followingAddress isLessThanOrEqualTo: endOfMemory).
+ 	numSlots := self numSlotsForShortening: objOop toIndexableSize: indexableSize.
+ 	bytesBefore := self bytesInObject: objOop.
+ 	delta := bytesBefore - (self objectBytesForSlots: numSlots).
+ 
+ 	"Since the system rounds objects up to 64-bits, losing a 32-bit
+ 	 slot may not actually change the bytes occupied by the object."
+ 	delta = 0 ifTrue:
+ 		[(self hasOverflowHeader: objOop)
+ 			ifTrue: [self rawOverflowSlotsOf: objOop put: numSlots]
+ 			ifFalse: [self rawNumSlotsOf: objOop put: numSlots].
+ 		 self updateFormatOfShortenedObject: objOop to: indexableSize.
+ 		 ^0].
+ 
+ 	"Currently we can't have one word gaps in oldSpace but we can in newSpace.  So only create
+ 	 a copy and forward if objOop is in old space. If in newSpace we'll create a slimbridge below."
+ 	(delta <= self allocationUnit
+ 	 and: [self isOldObject: objOop]) ifTrue:
+ 		[| format |
+ 		 format := self normalisedFormatFor: objOop indexableSize: indexableSize.
+ 		 copy := self allocateSlots: numSlots
+ 					format: format
+ 					classIndex: (self classIndexOf: objOop).
+ 		 copy ifNil: [self error: 'shorten:toIndexableSize: attempted to shorten by allocationUnit and failed to allocate space for copy!!'].
+ 		 (self isPureBitsFormat: format)
+ 			ifTrue:
+ 				[self memcpy: (self firstIndexableField: copy)
+ 							_: (self firstIndexableField: objOop)
+ 							_: (self numBytesOfBits: copy format: format)]
+ 			ifFalse:
+ 				[0 to: numSlots - 1 do:
+ 					[:i|
+ 					self storePointerUnchecked: i
+ 						ofObject: copy
+ 						withValue: (self fetchPointer: i ofObject: objOop)]].
+ 		 (self isRemembered: objOop) ifTrue:
+ 			[scavenger remember: copy].
+ 		 self forward: objOop to: copy.
+ 		 ^0].
+ 
+ 	(self hasOverflowHeader: objOop)
+ 		ifTrue:
+ 			[self rawOverflowSlotsOf: objOop put: numSlots.
+ 			 "Setting an overflow slot count to 0 or 1 in newSpace creates a slimbridge.
+ 			  So we must also change the normal slot count so that the object no
+ 			  longer has the overflow header word, which has become the slimbridge."
+ 			 numSlots <= 1 ifTrue:
+ 			 	[(self oop: objOop isLessThan: oldSpaceStart) ifTrue:
+ 					[self rawNumSlotsOf: objOop put: numSlots.
+ 					 self hackSlimBridgeTo: objOop at: objOop - self allocationUnit]]]
+ 		ifFalse:
+ 			[self assert: numSlots < self numSlotsMask.
+ 			 self rawNumSlotsOf: objOop put: numSlots].
+ 
+ 	"{self addressAfter: objOop. delta. (self addressAfter: objOop) + delta. followingAddress} collect: #hex"
+ 	delta := followingAddress - (self addressAfter: objOop).
+ 	self assert: (delta >= self allocationUnit and: [delta \\ self allocationUnit = 0]).
+ 	delta = self allocationUnit
+ 		ifTrue:
+ 			[self deny: (self isOldObject: objOop).
+ 			 delta := 0.
+ 			 followingAddress = freeStart
+ 				ifTrue: [freeStart := self addressAfter: objOop]
+ 				ifFalse: [self hackSlimBridgeTo: followingAddress at: (self addressAfter: objOop)]]
+ 		ifFalse:
+ 			[freeChunk := self initFreeChunkWithBytes: delta at: (self addressAfter: objOop).
+ 			self assert: (self objectAfter: objOop) = freeChunk.
+ 			self assert: (self addressAfter: freeChunk) = followingAddress.
+ 			(self isInOldSpace: objOop)
+ 				ifTrue:
+ 					[totalFreeOldSpace := totalFreeOldSpace + delta.
+ 					 self addToFreeList: freeChunk bytes: delta]
+ 				ifFalse:
+ 					[delta := 0.
+ 					 self
+ 						setClassIndexOf: freeChunk to: self wordSizeClassIndexPun;
+ 						setFormatOf: freeChunk to: self firstLongFormat]].
+ 	self wordSize = 8 ifTrue:
+ 		[self setFormatOf: objOop to: (self normalisedFormatFor: objOop indexableSize: indexableSize)].
+ 	^delta!

Item was removed:
- ----- Method: SpurMemoryManager>>ensureHasOverflowHeader:forwardIfCloned: (in category 'image segment in/out') -----
- ensureHasOverflowHeader: arrayArg forwardIfCloned: forwardIfCloned
- 	"If arrayArg is too short to be truncated, clone it so that the clone is long enough.
- 	 Answer nil if it can't be cloned."
- 	<inline: false>
- 	(self hasOverflowHeader: arrayArg) ifTrue:
- 		[^arrayArg].
- 	^(self
- 		allocateSlots: self numSlotsMask + 1
- 		format: (self formatOf: arrayArg)
- 		classIndex: (self classIndexOf: arrayArg)) ifNotNil:
- 			[:clonedArray|
- 			 self memcpy: clonedArray + self baseHeaderSize
- 				 _: arrayArg + self baseHeaderSize
- 				 _: (self numSlotsOf: arrayArg) * self bytesPerOop.
- 			 (self isRemembered: arrayArg) ifTrue:
- 				[scavenger remember:  clonedArray].
- 			 forwardIfCloned ifTrue:
- 				[self forward: arrayArg to: clonedArray].
- 			 clonedArray]!

Item was changed:
  ----- Method: SpurMemoryManager>>growOldSpaceByAtLeast: (in category 'growing/shrinking memory') -----
  growOldSpaceByAtLeast: minAmmount
  	"Attempt to grow memory by at least minAmmount.
  	 Answer the size of the new segment, or nil if the attempt failed."
  	| ammount headroom total start interval |
  	<var: #segInfo type: #'SpurSegmentInfo *'>
  	"statGrowMemory counts attempts, not successes."
  	statGrowMemory := statGrowMemory + 1."we need to include overhead for a new object header plus the segment bridge."
  	ammount := minAmmount + (self baseHeaderSize * 2 + self bridgeSize).
  	"round up to the nearest power of two."
  	ammount := 1 << (ammount - 1) highBit.
  	"and grow by at least growHeadroom."
  	ammount := ammount max: growHeadroom.
  
  	"Now apply the maxOldSpaceSize limit, if one is in effect."
  	maxOldSpaceSize > 0 ifTrue:
  		[total := segmentManager totalBytesInSegments.
  		 total >= maxOldSpaceSize ifTrue:
  			[needGCFlag := true.
  			 ^nil].
  		 headroom := maxOldSpaceSize - total.
  		 headroom < ammount ifTrue:
  			[headroom < (minAmmount + (self baseHeaderSize * 2 + self bridgeSize)) ifTrue:
  				[needGCFlag := true.
  				 ^nil].
  			 ammount := headroom]].
  		 
  	start := coInterpreter ioUTCMicrosecondsNow.
  	^(segmentManager addSegmentOfSize: ammount)
  		ifNil: [needGCFlag := true. nil]
  		ifNotNil:
  			[:segInfo|
  			 self assimilateNewSegment: segInfo.
  			 "and add the new free chunk to the free list; done here
  			  instead of in assimilateNewSegment: for the assert"
  			 self addFreeChunkWithBytes: segInfo segSize - self bridgeSize at: segInfo segStart.
  			 self assert: (self addressAfter: (self objectStartingAt: segInfo segStart))
  						= (segInfo segLimit - self bridgeSize).
+ 			 self checkFreeSpace: GCCheckFreeSpace.
- 			 self checkFreeSpace: GCModeFreeSpace.
  			 segmentManager checkSegments.
  			 interval := coInterpreter ioUTCMicrosecondsNow - start.
  			 interval > statMaxAllocSegmentTime ifTrue: [statMaxAllocSegmentTime := interval].
  			 segInfo segSize]!

Item was changed:
  ----- Method: SpurMemoryManager>>inLineRunLeakCheckerFor:excludeUnmarkedObjs:classIndicesShouldBeValid: (in category 'debug support') -----
  inLineRunLeakCheckerFor: gcModes excludeUnmarkedObjs: excludeUnmarkedObjs classIndicesShouldBeValid: classIndicesShouldBeValid
  	<inline: true>
  	(gcModes anyMask: checkForLeaks) ifTrue:
  		[(gcModes anyMask: GCModeFull)
  			ifTrue: [coInterpreter reverseDisplayFrom: 0 to: 7]
  			ifFalse: [coInterpreter reverseDisplayFrom: 8 to: 15].
  		 self clearLeakMapAndMapAccessibleObjects.
  		 self asserta: (self checkHeapIntegrity: excludeUnmarkedObjs classIndicesShouldBeValid: classIndicesShouldBeValid).
  		 self asserta: coInterpreter checkInterpreterIntegrity = 0.
  		 self asserta: coInterpreter checkStackIntegrity.
  		 self asserta: (coInterpreter checkCodeIntegrity: gcModes).
+ 		 (gcModes anyMask: GCCheckFreeSpace) ifTrue:
- 		 (gcModes anyMask: GCModeFreeSpace) ifTrue:
  			[self clearLeakMapAndMapAccessibleFreeSpace.
  			 self asserta: self checkHeapFreeSpaceIntegrity]]!

Item was changed:
  ----- Method: SpurMemoryManager>>initializeOldSpaceFirstFree: (in category 'free space') -----
  initializeOldSpaceFirstFree: startOfFreeOldSpace
  	<var: 'startOfFreeOldSpace' type: #usqInt>
  	| limit freeOldStart freeChunk |
  	<var: 'limit' type: #usqInt>
  	<var: 'freeOldStart' type: #usqInt>
  	limit := endOfMemory - self bridgeSize.
  	limit > startOfFreeOldSpace ifTrue:
  		[totalFreeOldSpace := totalFreeOldSpace + (limit - startOfFreeOldSpace).
  		 freeOldStart := startOfFreeOldSpace.
  		 self wordSize > 4 ifTrue:
  			[[limit - freeOldStart >= (1 << 32)] whileTrue:
  				[freeChunk := self freeChunkWithBytes: (1 << 32) at: freeOldStart.
  				 freeOldStart := freeOldStart + (1 << 32).
  				 self assert: freeOldStart = (self addressAfter: freeChunk)]].
  		freeOldStart < limit ifTrue:
  			[freeChunk := self freeChunkWithBytes: limit - freeOldStart at: freeOldStart.
  			 self assert: (self addressAfter: freeChunk) = limit]].
  	endOfMemory := endOfMemory - self bridgeSize.
  	freeOldSpaceStart := endOfMemory.
+ 	self checkFreeSpace: GCCheckFreeSpace!
- 	self checkFreeSpace: GCModeFreeSpace!

Item was changed:
  ----- Method: SpurMemoryManager>>leakCheckBecome (in category 'debug support') -----
  leakCheckBecome
  	<api>
+ 	^checkForLeaks anyMask: GCModeBecome!
- 	^(checkForLeaks bitAnd: GCModeBecome) ~= 0!

Item was changed:
  ----- Method: SpurMemoryManager>>leakCheckFullGC (in category 'debug support') -----
  leakCheckFullGC
  	<api>
+ 	^checkForLeaks anyMask: GCModeFull!
- 	^(checkForLeaks bitAnd: GCModeFull) ~= 0!

Item was changed:
  ----- Method: SpurMemoryManager>>leakCheckImageSegments (in category 'debug support') -----
  leakCheckImageSegments
+ 	^checkForLeaks anyMask: GCCheckImageSegment!
- 	^(checkForLeaks bitAnd: GCModeImageSegment) ~= 0!

Item was changed:
  ----- Method: SpurMemoryManager>>leakCheckIncremental (in category 'debug support') -----
  leakCheckIncremental
  	<api>
+ 	^checkForLeaks anyMask: GCModeIncremental!
- 	^(checkForLeaks bitAnd: GCModeIncremental) ~= 0!

Item was changed:
  ----- Method: SpurMemoryManager>>leakCheckNewSpaceGC (in category 'debug support') -----
  leakCheckNewSpaceGC
  	<api>
+ 	^checkForLeaks anyMask: GCModeNewSpace!
- 	^(checkForLeaks bitAnd: GCModeNewSpace) ~= 0!

Item was changed:
  ----- Method: SpurMemoryManager>>leakCheckRuntimeCalls (in category 'debug support') -----
  leakCheckRuntimeCalls
  	<doNotGenerate>
+ 	^checkForLeaks anyMask: GCCheckPrimCall!
- 	^(checkForLeaks bitAnd: 32) ~= 0!

Item was added:
+ ----- Method: SpurMemoryManager>>leakCheckShorten (in category 'debug support') -----
+ leakCheckShorten
+ 	^checkForLeaks anyMask: GCCheckShorten!

Item was changed:
  ----- Method: SpurMemoryManager>>loadImageSegmentFrom:outPointers: (in category 'image segment in/out') -----
  loadImageSegmentFrom: segmentWordArray outPointers: outPointerArray
  	"This primitive is called from Smalltalk 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 segmentWordArray will become an
  	 array of the loaded objects.  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?
  
  	 The primitive, if it succeeds, also becomes the segmentWordArray into the array of loaded objects.
  	 This allows fixing up of loaded objects directly, without nextObject, which Spur doesn't support."
  
  	<inline: #never>
  	| segmentLimit segmentStart segVersion errorCode numLoadedObjects loadedObjectsArray |
  
  	segmentLimit := self numSlotsOf: segmentWordArray.
  	(self objectBytesForSlots: segmentLimit) < (self allocationUnit "version info" + self baseHeaderSize "one object header") ifTrue:
  		[^PrimErrBadArgument halt].
  
  	"Verify format.  If the format is wrong, word-swap (since ImageSegment data are 32-bit longs).
  	 If it is still wrong, undo the damage and fail."
  	segVersion := self longAt: segmentWordArray + self baseHeaderSize.
  	(coInterpreter readableFormat: (segVersion bitAnd: 16rFFFFFF "low 3 bytes")) ifFalse:
  		[self reverseBytesIn32BitWordsIn: segmentWordArray.
  		 segVersion := self longAt: segmentWordArray + self baseHeaderSize.
  		 (coInterpreter readableFormat: (segVersion bitAnd: 16rFFFFFF "low 3 bytes")) ifFalse:
  			[self reverseBytesIn32BitWordsIn: segmentWordArray.
  			 ^PrimErrBadArgument halt]].
  
  	segmentStart := segmentWordArray + self baseHeaderSize + self allocationUnit.
  	segmentLimit := segmentLimit * self bytesPerOop + segmentWordArray + self baseHeaderSize.
  
  	"Notionally 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.  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 endianness is wrong."
  	self flag: #endianness.
  	(segVersion >> 24 bitAnd: 16rFF) ~= (self imageSegmentVersion >> 24 bitAnd: 16rFF) ifTrue:
  		"Reverse the byte-type objects once"
  		[true
  			ifTrue: [^PrimErrBadArgument halt]
  			ifFalse:
  				[self byteSwapByteObjectsFrom: (self objectStartingAt: segmentStart)
  					to: segmentLimit
  					flipFloatsIf: false]].
  
  	"Avoid having to remember by arranging that there are no young outPointers if segment is in old space."
  	(self isOldObject: segmentWordArray) ifTrue:
  		[errorCode := self ensureNoNewObjectsIn: outPointerArray.
  		 errorCode ~= 0 ifTrue:
  			[^errorCode]].
  
  	"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."
  	errorCode := self mapOopsAndValidateClassRefsFrom: segmentStart to: segmentLimit outPointers: outPointerArray.
  	errorCode > 0 ifTrue:
  		[^errorCode].
  	numLoadedObjects := errorCode negated.
  	loadedObjectsArray := self allocateSlots: numLoadedObjects format: self arrayFormat classIndex: ClassArrayCompactIndex.
  	loadedObjectsArray ifNil:
  		[^PrimErrNoMemory halt].
  
  	"Scan for classes contained in the segment, entering them into the class table.
  	 Classes are at the front, after the root array and have the remembered bit set."
  	errorCode := self enterClassesIntoClassTableFrom: segmentStart to: segmentLimit.
  	errorCode ~= 0 ifTrue:
  		[^errorCode].
  
  	"Make a final pass, assigning class indices and/or pinning pinned objects and collecting the loaded objects in loadedObjectsArray"
  	self assignClassIndicesAndPinFrom: segmentStart to: segmentLimit outPointers: outPointerArray filling: loadedObjectsArray.
  
  	"Evaporate the container, leaving the newly loaded objects in place."
  	(self hasOverflowHeader: segmentWordArray)
  		ifTrue: [self rawOverflowSlotsOf: segmentWordArray put: self allocationUnit / self bytesPerOop]
  		ifFalse: [self rawNumSlotsOf: segmentWordArray put: self allocationUnit / self bytesPerOop].
  
  	"Finally forward the segmentWordArray to the loadedObjectsArray"
  	self forward: segmentWordArray to: loadedObjectsArray.
  	
+ 	self runLeakCheckerFor: GCCheckImageSegment.
- 	self runLeakCheckerFor: GCModeImageSegment.
  
  	^self objectStartingAt: segmentStart!

Item was changed:
  ----- Method: SpurMemoryManager>>memcpy:_:_: (in category 'simulation') -----
  memcpy: destAddress _: sourceAddress _: bytes
  	"For SpurGenerationScavenger>>copyToFutureSpace:bytes:. N.B. If ranges overlap, must use memmove."
  	<doNotGenerate>
+ 	| nToCopy offset |
+ 	(destAddress isInteger and: [sourceAddress isInteger]) ifFalse: "CogMethodProxies..."
+ 		[sourceAddress isCollection ifTrue: "CArray, String, etc..."
+ 			[^super memcpy: destAddress _: sourceAddress _: bytes].
+ 		 ^self memcpy: destAddress asInteger _: sourceAddress asInteger _: bytes].
+ 	self deny: ((destAddress <= sourceAddress and: [destAddress + bytes > sourceAddress])
+ 				or: [sourceAddress <= destAddress and: [sourceAddress + bytes > destAddress]]).
+ 	self assert: (destAddress \\ 8) + (sourceAddress \\ 8) = 0. "for now..."
+ 	nToCopy := bytes.
+ 	offset := 0.
+ 	memory bytesPerElement = 8 ifTrue:
+ 		[0 to: nToCopy - 8 by: 8 do:
+ 			[:i| self long64At: destAddress + i put: (self long64At: sourceAddress + i)].
+ 		 offset := nToCopy - (nToCopy \\ 8).
+ 		 nToCopy := nToCopy \\ 8].
+ 	nToCopy >= 4 ifTrue:
+ 		[0 to: nToCopy - 4 by: 4 do:
+ 			[:i| self long32At: destAddress + i + offset put: (self long32At: sourceAddress + i + offset)].
+ 		 offset := offset + nToCopy - (nToCopy \\ 4).
+ 		 nToCopy := nToCopy \\ 4].
+ 	0 to: nToCopy - 1 do:
+ 		[:i| self byteAt: destAddress + i + offset put: (self byteAt: sourceAddress + i + offset)].
+ 	^destAddress!
- 	sourceAddress isCollection ifTrue:
- 		[^super memcpy: destAddress _: sourceAddress _: bytes].
- 	self deny: ((destAddress <= sourceAddress and: [destAddress asInteger + bytes > sourceAddress])
- 				or: [sourceAddress <= destAddress and: [sourceAddress asInteger + bytes > destAddress]]).
- 	^self memmove: destAddress _: sourceAddress _: bytes!

Item was added:
+ ----- Method: SpurMemoryManager>>numBytesOfBits:format: (in category 'object access') -----
+ numBytesOfBits: objOop format: format
+ 	"Answer the number of indexable bytes in the given non-immediate pure bits object with format."
+ 	| numBytes |
+ 	<inline: true>
+ 	self assert: ((self isPureBitsFormat: format) and: [(self formatOf: objOop) = format]).
+ 	numBytes := self numSlotsOf: objOop.
+ 	numBytes := numBytes << self shiftForWord.
+ 	format < self firstShortFormat ifTrue:
+ 		[^format <= self sixtyFourBitIndexableFormat
+ 			ifTrue: [numBytes]
+ 			ifFalse: [numBytes - ((format bitAnd: 1) << 2)]].
+ 	^format < self firstByteFormat
+ 		ifTrue: [numBytes - ((format bitAnd: 3) << 1)]
+ 		ifFalse: [numBytes - (format bitAnd: 7)]!

Item was changed:
  ----- Method: SpurMemoryManager>>objectsReachableFromRoots: (in category 'image segment in/out') -----
  objectsReachableFromRoots: arrayOfRoots
  	"This is part of storeImageSegmentInto:outPointers:roots:.
  	 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 |
  	<var: #freeChunk type: #usqInt> "& hence start & ptr are too; limit is also because of addressAfter:"
  	<inline: #never>
  	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 markObjectsIn: arrayOfRoots.
  	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.
  
  	"Now unmark the roots before collecting the transitive closure of unmarked objects accessible from the roots."
  	self unmarkObjectsIn: arrayOfRoots.
  
  	"Use the largest free chunk to answer the result."
  	freeChunk := self allocateLargestFreeChunk. "N.B. Does /not/ update totalFreeOldSpace"
  	totalFreeOldSpace := totalFreeOldSpace - (self bytesInObject: freeChunk). "but must update so that growth in the markStack does not cause assert fails."
  	ptr := start := freeChunk + self baseHeaderSize.
  	limit := self addressAfter: freeChunk.
  	count := 0.
  
  	"First put the arrayOfRoots; order is important."
  	self noCheckPush: arrayOfRoots onObjStack: markStack.
  
  	"Now collect the roots and the transitive closure of unmarked objects from them."
  	[self isEmptyObjStack: markStack] whileFalse:
  		[objOop := self popObjStack: markStack.
  		 self assert: (self isMarked: objOop).
  		 count := count + 1.
  		 ptr < limit ifTrue:
  			[self longAt: ptr put: objOop.
  			 ptr := ptr + self bytesPerOop].
  		 oop := self fetchClassOfNonImm: objOop.
  		 (self isMarked: oop) ifFalse:
  			[self setIsMarkedOf: oop to: true.
  			 self noCheckPush: oop onObjStack: markStack].
  		 ((self isContextNonImm: objOop)
  		  and: [coInterpreter isStillMarriedContext: objOop]) "widow now, before the copy loop"
  			ifTrue:
  				[0 to: (coInterpreter numSlotsOfMarriedContext: objOop) - 1 do:
  					[:i|
  					 oop := coInterpreter fetchPointer: i ofMarriedContext: objOop.
  					 ((self isImmediate: oop)
  					  or: [self isMarked: oop]) ifFalse:
  						[self setIsMarkedOf: oop to: true.
  						 self noCheckPush: oop onObjStack: markStack]]]
  			ifFalse:
  				[0 to: (self numPointerSlotsOf: objOop) - 1 do:
  					[:i|
  					 oop := self fetchPointer: i ofObject: objOop.
  					 ((self isImmediate: oop)
  					  or: [self isMarked: oop]) ifFalse:
  						[self setIsMarkedOf: oop to: true.
  						 self noCheckPush: oop onObjStack: markStack]]]].
  
  	self unmarkAllObjects.
  
  	"Now try and allocate the result"
  	(count > (ptr - start / self bytesPerOop) "not enough room"
  	 or: [limit ~= ptr and: [limit - ptr <= self allocationUnit]]) ifTrue: "can't split a single word"
  		[self freeObject: freeChunk.
+ 		 self checkFreeSpace: GCCheckImageSegment.
- 		 self checkFreeSpace: GCModeImageSegment.
  		 ^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 isForwarded: freeChunk) ifTrue:
  		[freeChunk := self followForwarded: freeChunk].
  	self possibleRootStoreInto: freeChunk.
+ 	self checkFreeSpace: GCCheckImageSegment.
+ 	self runLeakCheckerFor: GCCheckImageSegment.
- 	self checkFreeSpace: GCModeImageSegment.
- 	self runLeakCheckerFor: GCModeImageSegment.
  	^freeChunk!

Item was changed:
  ----- Method: SpurMemoryManager>>return:restoringObjectsIn:savedFirstFields:and:savedHashes: (in category 'image segment in/out') -----
  return: errCode restoringObjectsIn: firstArray savedFirstFields: savedFirstFields and: secondArray savedHashes: savedHashes
  	<inline: false>
  	"This is part of storeImageSegmentInto:outPointers:roots:."
  	self cCode: [] inSmalltalk: [errCode ~= 0 ifTrue: [self halt]].
  	self restoreObjectsIn: firstArray upTo: -1 savedFirstFields: savedFirstFields.
  	self restoreObjectsIn: secondArray savedHashes: savedHashes.
+ 	self runLeakCheckerFor: GCCheckImageSegment.
- 	self runLeakCheckerFor: GCModeImageSegment.
  	self assert: self allObjectsUnmarked.
  	^errCode!

Item was changed:
  ----- Method: SpurMemoryManager>>return:restoringObjectsIn:upTo:savedFirstFields: (in category 'image segment in/out') -----
  return: errCode restoringObjectsIn: firstArray upTo: limitOrTag savedFirstFields: savedFirstFields
  	<inline: false>
  	"This is part of storeImageSegmentInto:outPointers:roots:."
  	self cCode: [] inSmalltalk: [errCode ~= 0 ifTrue: [self halt]].
  	self restoreObjectsIn: firstArray upTo: limitOrTag savedFirstFields: savedFirstFields.
+ 	self runLeakCheckerFor: GCCheckImageSegment.
- 	self runLeakCheckerFor: GCModeImageSegment.
  	self assert: self allObjectsUnmarked.
  	^errCode!

Item was changed:
  ----- Method: SpurMemoryManager>>runLeakCheckerForFreeSpace:ignoring: (in category 'debug support') -----
  runLeakCheckerForFreeSpace: gcModes ignoring: anOopOrNil
  	"Check free space integrity by setting bits in the map corresponding to all free space objects
  	 and checking tat no pointer field refers to a free object.  anOopOrNil is provided to filter-out
  	 the as-yet-to-be initialized object in primitiveShallowCopy/primitiveClone."
  	<inline: false>
+ 	(gcModes anyMask: GCCheckFreeSpace) ifTrue:
- 	(gcModes anyMask: GCModeFreeSpace) ifTrue:
  		[coInterpreter reverseDisplayFrom: 16 to: 19.
  		 self clearLeakMapAndMapAccessibleFreeSpace.
  		 freeSpaceCheckOopToIgnore := anOopOrNil.
  		 self asserta: self checkHeapFreeSpaceIntegrity.
  		 freeSpaceCheckOopToIgnore := nil]!

Item was changed:
  ----- Method: SpurMemoryManager>>setCheckForLeaks: (in category 'spur bootstrap') -----
  setCheckForLeaks: integerFlags
  	" 0 = do nothing.
  	  1 = check for leaks on fullGC (GCModeFull).
  	  2 = check for leaks on scavenger (GCModeNewSpace).
  	  4 = check for leaks on incremental (GCModeIncremental)
  	  8 = check for leaks on become (GCModeBecome)
+ 	 16 = check for leaks on image segments (GCCheckImageSegment)
+ 	 32 = check for leaks in free space (GCCheckFreeSpace)
+ 	 64 = check for leaks on object shortening (GCCheckShorten)
+ 	 128 = check for leaks on simulated run-time call (GCCheckPrimCall)"
- 	 16 = check for leaks on image segments (GCModeImageSegment)
- 	 32 = check for leaks on simulated run-time call."
  	checkForLeaks := integerFlags!

Item was changed:
+ ----- Method: SpurMemoryManager>>shorten:toIndexableSize: (in category 'indexing primitive support') -----
- ----- Method: SpurMemoryManager>>shorten:toIndexableSize: (in category 'allocation') -----
  shorten: objOop toIndexableSize: indexableSize
+ 	"Reduce the number of indexable fields in objOop, an arrayFormat or longFormat object, to nSlots.
+ 	 Convert the unused residual to a free chunk (if in oldSpace).
+ 	 Answer the number of bytes returned to free memory, which may be zero."
+ 	| delta |
+ 	self assert: (indexableSize >= 0 and: [indexableSize < (self lengthOf: objOop)]).
+ 	false ifTrue: [self runLeakCheckerFor: GCCheckShorten]. "assume no leaks before hand..."
+ 	delta := self doShorten: objOop toIndexableSize: indexableSize.
+ 	self assert: (self lengthOf: (self followMaybeForwarded: objOop)) = indexableSize.
+ 	self cCode: [] inSmalltalk:
+ 		[(checkForLeaks anyMask: GCCheckShorten) ifTrue:
+ 			[coInterpreter cr; print: 'leak checking shorten...'; flush]].
+ 	self runLeakCheckerFor: GCCheckShorten.
+ 	^delta
+ 
+ 	"coInterpreter printOop: objOop"
+ 	"{ objOop. self objectAfter: objOop } collect: [:ea| ea hex]"
+ 	"coInterpreter printOop: (self objectAfter: objOop)"!
- 	"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.
- 	 Answer the number of bytes returned to free memory, which may be zero if no change was possible."
- 	self subclassResponsibility!

Item was changed:
  ----- Method: SpurMemoryManager>>storeImageSegmentInto:outPointers:roots: (in category 'image segment in/out') -----
  storeImageSegmentInto: segmentWordArrayArg outPointers: outPointerArrayArg roots: arrayOfRootsArg
  	"This primitive is called from Squeak as...
  		<imageSegment> storeSegmentFor: arrayOfRoots into: aWordArray outPointers: anArray.
  
  	 This primitive will store a binary image segment (in the same format as objects 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 8), but with the high bit set.
  
  	 Since Spur has a class table the load primitive must insert classes that have instances into the
  	 class table.  This primitive marks such classes using the isRemembered bit, which isn't meaningful
  	 as a remembered bit in the segment.
  
  	 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.
  
  	 The primitive can fail for the following reasons with the specified failure codes:
  		PrimErrGenericError:		the segmentWordArray is too small for the version stamp
  		PrimErrWritePastObject:	the segmentWordArray is too small to contain the reachable objects
  		PrimErrBadIndex:			the outPointerArray is too small
  		PrimErrNoMemory:			additional allocations failed
  		PrimErrLimitExceeded:		there is no room in the hash field to store out pointer indices or class references."
  	<inline: false>
  	| segmentWordArray outPointerArray arrayOfRoots
  	  arrayOfObjects savedFirstFields savedOutHashes segStart segAddr endSeg outIndex numClassesInSegment |
  	<var: 'segAddr' type: #usqInt>
  	((self isObjImmutable: segmentWordArrayArg)
  	 or: [self isObjImmutable: outPointerArrayArg]) ifTrue:
  		[^PrimErrNoModification].
  	"Since segmentWordArrayArg & outPointerArrayArg may get shortened, they can't be pinned."
  	((self isPinned: segmentWordArrayArg)
  	 or: [self isPinned: outPointerArrayArg]) ifTrue:
  		[^PrimErrObjectIsPinned].
  	(self numSlotsOf: outPointerArrayArg) > self maxIdentityHash ifTrue:
  		[^PrimErrLimitExceeded].
  
+ 	self runLeakCheckerFor: GCCheckImageSegment.
- 	self runLeakCheckerFor: GCModeImageSegment.
  
  	"First scavenge to collect any new space garbage that refers to the graph."
  	self scavengingGC.
  	segmentWordArray := self updatePostScavenge: segmentWordArrayArg.
  	outPointerArray := self updatePostScavenge: outPointerArrayArg.
  	arrayOfRoots := self updatePostScavenge: arrayOfRootsArg.
  	self deny: (self forwardersIn: outPointerArray).
  	self deny: (self forwardersIn: arrayOfRoots).
  	
  	"Now compute the transitive closure, collecting the sequence of objects to be stored in the arrayOfObjects array.
  	 Included in arrayOfObjects are the arrayOfRoots and all its contents.  All objects have been unmarked."
  	arrayOfObjects := self objectsReachableFromRoots: arrayOfRoots.
  	arrayOfObjects ifNil:
  		[^PrimErrNoMemory].
  	"If objectsReachableFromRoots: answers an integer there is not enough continuous free space in which to allocate the
  	 reachable objects.  If there is sufficient free space then answer an error code to prompt a compacting GC and a retry."
  	(self isIntegerObject: arrayOfObjects) ifTrue:
  		[totalFreeOldSpace - self allocationUnit >= (self integerValueOf: arrayOfObjects) ifTrue:
  			[^PrimErrNeedCompaction].
  		 ^PrimErrNoMemory].
  
  	self assert: self allObjectsUnmarked. "work to be done when the incremental GC is written"
  	self deny: (self forwardersIn: arrayOfObjects).
  
  	"Both to expand the max size of segment and to reduce the length of the
  	 load-time pass that adds classes to the class table, move classes to the
  	 front of arrayOfObjects, leaving the root array as the first element."
  	numClassesInSegment := self moveClassesForwardsIn: arrayOfObjects.
  
  	"The scheme is to copy the objects into segmentWordArray, and then map the oops in segmentWordArray.
  	 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 segmentWordArray or outPointerArray
  	 is too small.  The mapping is done by having the objects to be stored in arrayOfObjects refer to their mapped
  	 locations through their first field, just like a forwarding pointer, but without becoming a forwarder, saving their
  	 first field in savedFirstFields, and the objects in outPointerArray pointing to their locations in the outPointerArray
  	 through their identityHashes, saved in savedOutHashes.
  	 Since arrayOfObjects and its savedFirstFields, and outPointerArray and its saved hashes, can be enumerated
  	 side-by-side, the hashes can be restored to the originals.  So the first field of the heap object corresponding to
  	 an object in arrayOfObjects is set to its location in segmentWordArray, and the hash of an object in outPointerArray
  	 is set to its index in outPointerArray plus the top hash bit.  Classes in arrayOfObjects have their marked bit set.
  	 Oops in objects in segmentWordArray are therefore mapped by accessing the original oop, and following its first
  	 field. Class indices in segmentWordArray are mapped by fetching the original class, and testing its marked bit.
  	 If marked, the first field is followed to access the class copy in the segment.  Out pointers (objects and classes,
  	 which are unmarked), the object's identityHash is set (eek!!!!) to its index in the outPointerArray. So savedOutHashes
  	 parallels the outPointerArray. The saved hash array is initialized with an out-of-range hash value so that the first
  	 unused entry can be identified."
  
  	savedFirstFields := self allocateSlots: (self numSlotsOf: arrayOfObjects)
  							format: self wordIndexableFormat
  							classIndex: self wordSizeClassIndexPun.
  	savedOutHashes := self allocateSlots: (self numSlotsForBytes: (self numSlotsOf: outPointerArray) * 4)
  							format: self firstLongFormat
  							classIndex: self thirtyTwoBitLongsClassIndexPun.
  	(savedFirstFields isNil or: [savedOutHashes isNil]) ifTrue:
  		[self freeObject: arrayOfObjects.
  		 (savedFirstFields notNil and: [self isInOldSpace: savedFirstFields]) ifTrue:
  			[self freeObject: savedFirstFields].
  		 (savedOutHashes notNil and: [self isInOldSpace: savedOutHashes]) ifTrue:
  			[self freeObject: savedOutHashes].
  		 ^PrimErrNoMemory].
  
  	self fillObj: savedFirstFields numSlots: (self numSlotsOf: savedFirstFields) with: 0.
  	self fillObj: savedOutHashes numSlots: (self numSlotsOf: savedOutHashes) with: self savedOutHashFillValue.
  
  	segAddr := segmentWordArray + self baseHeaderSize.
  	endSeg := 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.
  
  	self assert: arrayOfRoots = (self fetchPointer: 0 ofObject: arrayOfObjects).
  
  	"Copy all reachable objects to the segment, setting the marked bit for all objects (clones) in the segment,
  	 and the remembered bit for all classes (clones) in the segment."
  	0 to: (self numSlotsOf: arrayOfObjects) - 1 do:
  		[:i| | newSegAddrOrError objOop |
  		"Check that classes in the segment are addressable.  Since the top bit of the hash field is used to tag
  		 classes external to the segment, the segment offset must not inadvertently set this bit.  This limit still
  		 allows for a million or more classes."
  		(i = numClassesInSegment
  		 and: [segAddr - segStart / self allocationUnit + self lastClassIndexPun >= TopHashBit]) ifTrue:
  			[^self return: PrimErrLimitExceeded
  					restoringObjectsIn: arrayOfObjects upTo: i savedFirstFields: savedFirstFields].
  		objOop := self fetchPointer: i ofObject: arrayOfObjects.
  		self deny: ((self isImmediate: objOop) or: [self isForwarded: objOop]).
  		newSegAddrOrError := self copyObj: objOop
  									toAddr: segAddr
  									stopAt: endSeg
  									savedFirstFields: savedFirstFields
  									index: i.
  		(self oop: newSegAddrOrError isLessThan: segStart) ifTrue:
  			[^self return: newSegAddrOrError
  					restoringObjectsIn: arrayOfObjects upTo: i savedFirstFields: savedFirstFields].
  		 segAddr := newSegAddrOrError].
  
  	"Check that it can be safely shortened."
  	(endSeg ~= segAddr
  	 and: [endSeg - segAddr < (self baseHeaderSize + self bytesPerOop)]) ifTrue:
  		[^self return: PrimErrWritePastObject
  				restoringObjectsIn: arrayOfObjects upTo: -1 savedFirstFields: savedFirstFields].
  
  	"Now scan, adding out pointers to the outPointersArray; all objects in arrayOfObjects
  	 have their first field pointing to the corresponding copy in segmentWordArray."
  	(outIndex := self mapOopsFrom: segStart
  					to: segAddr
  					outPointers: outPointerArray
  					outHashes: savedOutHashes) < 0 ifTrue: "no room in outPointers; fail"
  		[^self return: PrimErrBadIndex
  				restoringObjectsIn: arrayOfObjects savedFirstFields: savedFirstFields
  				and: outPointerArray savedHashes: savedOutHashes].
  
  	"We're done.  Shorten the results, restore hashes and return."
  	self shorten: segmentWordArray toIndexableSize: segAddr - (segmentWordArray + self baseHeaderSize) / 4.
  	self shorten: outPointerArray toIndexableSize: outIndex.
  	^self return: PrimNoErr
  		restoringObjectsIn: arrayOfObjects savedFirstFields: savedFirstFields
  		and: outPointerArray savedHashes: savedOutHashes!

Item was changed:
  ----- Method: SpurPlanningCompactorTests>>checkForLeaksIn: (in category 'private') -----
  checkForLeaksIn: om
+ 	om setCheckForLeaks: GCCheckFreeSpace + GCModeFull;
- 	om setCheckForLeaks: GCModeFreeSpace + GCModeFull;
  		runLeakCheckerFor: GCModeFull;
  		checkFreeSpace: GCModeFull!

Item was changed:
  ----- Method: SpurSegmentManager>>shrinkObjectMemory: (in category 'growing/shrinking memory') -----
  shrinkObjectMemory: delta
  	"Answer if any shrinkage was achieved."
  	<inline: false>
  	<var: #delta type: #usqInt>
  	| shrinkage emptySeg |
  	<var: #shrinkage type: #usqInt>
  	<var: #emptySeg type: #'SpurSegmentInfo *'>
+ 	manager checkFreeSpace: GCCheckFreeSpace.
- 	manager checkFreeSpace: GCModeFreeSpace.
  	shrinkage := delta.
  	[emptySeg := self findEmptySegNearestInSizeTo: shrinkage.
  	 (emptySeg isNil
  	  or: [emptySeg segSize > shrinkage]) ifTrue:
+ 		[manager checkFreeSpace: GCCheckFreeSpace.
- 		[manager checkFreeSpace: GCModeFreeSpace.
  		 ^shrinkage < delta].
  	 shrinkage := shrinkage - emptySeg segSize.
  	 manager detachFreeObject: (manager objectStartingAt: emptySeg segStart).
  	 self removeSegment: emptySeg] repeat!

Item was changed:
  ----- Method: SpurSelectiveCompactorSimulator>>compact (in category 'api') -----
  compact
  	self talk: '~~ Start selective compaction ~~'.
  	self tellMeNumSegmentAndTotalFreeSpace.
  	self tellMeWhichSegmentsAreBeingCompacted.
  	super compact.
  	self tellMeNumSegmentAndTotalFreeSpace.
  	self tellMeWhichSegmentsAreBeingCompacted.
+ 	manager runLeakCheckerForFreeSpace: GCCheckFreeSpace ignoring: nil.
- 	manager runLeakCheckerForFreeSpace: GCModeFreeSpace ignoring: nil.
  	self talk: '~~ Finished selective compaction ~~'.
  	!

Item was changed:
  ----- Method: StackInterpreter class>>initializeMiscConstants (in category 'initialization') -----
  initializeMiscConstants
  
  	super initializeMiscConstants.
  	STACKVM := true.
  
+ 	"These flags identify a GC operation (& hence a reason to leak check),
+ 	 or just operations the leak checker can be run for."
- 	"These flags function to identify a GC operation, or
- 	 to specify what operations the leak checker should be run for."
  	GCModeFull := 1.				"stop-the-world global GC"
  	GCModeNewSpace := 2.		"Spur's scavenge, or V3's incremental"
  	GCModeIncremental := 4.		"incremental global gc (Dijkstra tri-colour marking); as yet unimplemented"
  	GCModeBecome := 8.			"v3 post-become sweeping/Spur forwarding"
+ 	GCCheckImageSegment := 16.	"just a flag for leak checking image segments"
+ 	GCCheckFreeSpace := 32.		"just a flag for leak checking free space; Spur only"
+ 	GCCheckShorten := 64.		"just a flag for leak checking object shortening operations; Spur only"
+ 	GCCheckPrimCall := 128.		"just a flag for leak checking external primitive calls"
- 	GCModeImageSegment := 16.	"just a flag for leak checking image segments"
- 	GCModeFreeSpace := 32.		"just a flag for leak checking free space; Spur only"
- 	GCCheckPrimCall := 64.		"just a flag for leak checking external primitive calls"
  
  	StackPageTraceInvalid := -1.
  	StackPageUnreached := 0.
  	StackPageReachedButUntraced := 1.
  	StackPageTraced := 2.
  
  	DumpStackOnLowSpace := 0.
  	MillisecondClockMask := 16r1FFFFFFF.
  	"Note: The external primitive table should actually be dynamically sized but for the sake of inferior platforms (e.g., Mac :-) who cannot allocate memory in any reasonable way, we keep it static (and cross our fingers...)"
  	MaxExternalPrimitiveTableSize := 4096. "entries"
  
  	MaxJumpBuf := 32. "max. callback depth"
  	FailImbalancedPrimitives := InitializationOptions at: #FailImbalancedPrimitives ifAbsentPut: [true].
  	EnforceAccessControl := InitializationOptions at: #EnforceAccessControl ifAbsent: [true].
  
  	ReturnToInterpreter := 1. "setjmp/longjmp code."
  
  	"Because of a hack with callbacks in the non-threaded VM they must not conflct with the VM's tag bits."
  	DisownVMForFFICall := 16.
  	DisownVMForThreading := 32
  !

Item was changed:
  ----- Method: StackInterpreterSimulator>>cloneSimulation (in category 'debug support') -----
  cloneSimulation
  	| savedAtEachStepBlock savedDisplayView savedDisplayForm savedQuitBlock savedTranscript |
  	savedAtEachStepBlock := atEachStepBlock. atEachStepBlock := nil.
  	savedDisplayView := displayView. displayView := nil.
  	savedDisplayForm := displayForm. displayForm = nil.
  	savedQuitBlock := quitBlock. quitBlock := nil.
  	savedTranscript := transcript. transcript := nil.
  
  	^[| theClone |
+ 	 self changed: #byteCountText.
  	 Smalltalk garbageCollect.
  	 theClone := self veryDeepCopy.
  	 theClone parent: self; transcript: Transcript.
  	 theClone objectMemory parent: objectMemory.
  	 theClone]
  		ensure:
  			[atEachStepBlock := savedAtEachStepBlock.
  			 displayView := savedDisplayView.
  			 displayForm = savedDisplayForm.
  			 quitBlock := savedQuitBlock.
  			 transcript := savedTranscript]!

Item was changed:
  SharedPool subclass: #VMBasicConstants
  	instanceVariableNames: ''
+ 	classVariableNames: 'BaseHeaderSize BytecodeSetHasExtensions BytesPerOop BytesPerWord COGMTVM COGVM CloneOnGC CloneOnScavenge DisownVMForFFICall DisownVMForThreading DoAssertionChecks DoExpensiveAssertionChecks GCCheckFreeSpace GCCheckImageSegment GCCheckPrimCall GCCheckShorten GCModeBecome GCModeFull GCModeIncremental GCModeNewSpace HashMultiplyConstant HashMultiplyMask IMMUTABILITY LowcodeVM MULTIPLEBYTECODESETS NewspeakVM PharoVM PrimErrBadArgument PrimErrBadIndex PrimErrBadMethod PrimErrBadNumArgs PrimErrBadReceiver PrimErrCallbackError PrimErrFFIException PrimErrGenericFailure PrimErrInappropriate PrimErrInternalError PrimErrLimitExceeded PrimErrNamedInternal PrimErrNeedCompaction PrimErrNoCMemory PrimErrNoMemory PrimErrNoModification PrimErrNotFound PrimErrOSError PrimErrObjectIsPinned PrimErrObjectMayMove PrimErrObjectMoved PrimErrObjectNotPinned PrimErrOperationFailed PrimErrUninitialized PrimErrUnsupported PrimErrWritePastObject PrimNoErr PrimNumberHandlerMarker PrimNumbe
 rNoContextSwitchMarker PrimNumberUnwindMarker SPURVM STACKVM SistaVM TempVectReadBarrier VMBIGENDIAN'
- 	classVariableNames: 'BaseHeaderSize BytecodeSetHasExtensions BytesPerOop BytesPerWord COGMTVM COGVM CloneOnGC CloneOnScavenge DisownVMForFFICall DisownVMForThreading DoAssertionChecks DoExpensiveAssertionChecks GCCheckPrimCall GCModeBecome GCModeFreeSpace GCModeFull GCModeImageSegment GCModeIncremental GCModeNewSpace HashMultiplyConstant HashMultiplyMask IMMUTABILITY LowcodeVM MULTIPLEBYTECODESETS NewspeakVM PharoVM PrimErrBadArgument PrimErrBadIndex PrimErrBadMethod PrimErrBadNumArgs PrimErrBadReceiver PrimErrCallbackError PrimErrFFIException PrimErrGenericFailure PrimErrInappropriate PrimErrInternalError PrimErrLimitExceeded PrimErrNamedInternal PrimErrNeedCompaction PrimErrNoCMemory PrimErrNoMemory PrimErrNoModification PrimErrNotFound PrimErrOSError PrimErrObjectIsPinned PrimErrObjectMayMove PrimErrObjectMoved PrimErrObjectNotPinned PrimErrOperationFailed PrimErrUninitialized PrimErrUnsupported PrimErrWritePastObject PrimNoErr PrimNumberHandlerMarker PrimNumberNoContextSwitchM
 arker PrimNumberUnwindMarker SPURVM STACKVM SistaVM TempVectReadBarrier VMBIGENDIAN'
  	poolDictionaries: ''
  	category: 'VMMaker-Interpreter'!
  
  !VMBasicConstants commentStamp: '<historical>' prior: 0!
  I am a shared pool for basic constants upon which the VM as a whole depends.
  
  self ensureClassPool.
  self classPool declare: #BytesPerWord from: VMSqueakV3ObjectRepresentationConstants classPool.
  self classPool declare: #BaseHeaderSize from: VMSqueakV3ObjectRepresentationConstants classPool
  (ObjectMemory classPool keys select: [:k| k beginsWith: 'Byte']) do:
  	[:k| self classPool declare: k from: ObjectMemory classPool]!

Item was changed:
  ----- Method: VMBasicConstants class>>namesDefinedAtCompileTime (in category 'C translation') -----
  namesDefinedAtCompileTime
  	"Answer the set of names for variables that should be defined at compile time.
  	 Some of these get default values during simulation, and hence get defaulted in
  	 the various initializeMiscConstants methods.  But that they have values should
  	 /not/ cause the code generator to do dead code elimination based on their
  	 default values.  In particular, methods marked with <option: ANameDefinedAtCompileTime>
  	 will be emitted within #if defined(ANameDefinedAtCompileTime)...#endif.
  
  	And of course this is backwards.  We'd like to define names that are defined at translation time."
  	^#(VMBIGENDIAN
  		IMMUTABILITY
  		STACKVM COGVM COGMTVM SPURVM
  		PharoVM								"Pharo vs Squeak"
  		TerfVM VM_TICKER						"Terf vs Squeak & Qwaq/Teleplace/Terf high-priority thread support"
  		EnforceAccessControl					"Newspeak"
  		CheckRememberedInTrampoline		"IMMUTABILITY"
  		BIT_IDENTICAL_FLOATING_POINT PLATFORM_SPECIFIC_FLOATING_POINT	"Alternatives for using fdlibm for floating-point"
+ 		TestingPrimitives
  		OBSOLETE_ALIEN_PRIMITIVES			"Ancient crap in the IA32ABI plugin"
  		LLDB									"As of lldb-370.0.42 Swift-3.1, passing function parameters to printOopsSuchThat fails with Internal error [IRForTarget]: Couldn't rewrite one of the arguments of a function call.  Turning off link time optimization with -fno-lto has no effect.  hence we define some debugging functions as being <option: LLDB>"
  
  		"processor related"
  		__ARM_ARCH__ __arm__ __arm32__ ARM32 __arm64__ ARM64
  		_M_I386 _X86_ i386 i486 i586 i686 __i386__ __386__ X86 I386
  		x86_64 __amd64 __x86_64 __amd64__ __x86_64__ _M_AMD64 _M_X64
  		__mips__ __mips
  		__powerpc __powerpc__ __powerpc64__ __POWERPC__
  		__ppc__ __ppc64__ __PPC__ __PPC64__
  		__sparc__ __sparc __sparc_v8__ __sparc_v9__ __sparcv8 __sparcv9
  
  		"Compiler brand related"
  		__ACK__
  		__CC_ARM
  		__clang__
  		__GNUC__
  		_MSC_VER
  		__ICC
  		__SUNPRO_C
  		
  		"os related"
  		ACORN
  		_AIX
  		__ANDROID__
  		__BEOS__
  		__linux__
  		__MINGW32__
  		__FreeBSD__ __NetBSD__ __OpenBSD__
  		__osf__
  		EPLAN9
  		__unix__ __unix UNIX
  		WIN32 _WIN32 _WIN32_WCE
  		WIN64 _WIN64 _WIN64_WCE)!

Item was added:
+ ----- Method: VMClass>>assertf: (in category 'simulation support') -----
+ assertf: aString
+ 	<doNotGenerate>
+ 	AssertionFailure signal: 'Assertion failed: ', aString!



More information about the Vm-dev mailing list