Merge pull request OpenSmalltalk#561 from pharo-project/fix/ephemeron-compaction

Fix ephemeron compaction

Author: guillep

smalltalksrc/VMMaker/Spur64BitMMLESimulator.class.st

@@ -127,18 +127,6 @@ Spur64BitMMLESimulator >> freeLists [
 	^freeLists
 ]
 
-{ #category : #'gc - global' }
-Spur64BitMMLESimulator >> globalGarbageCollect [
-	"If we're /not/ a clone, clone the VM and push it over the cliff.
-	 If it survives, destroy the clone and continue.  We should be OK until next time."
-	parent ifNil:
-		[coInterpreter cr; print: 'GC number '; print: statFullGCs; tab; flush.
-		 CloneOnGC ifTrue:
-			[coInterpreter cloneSimulation objectMemory globalGarbageCollect.
-			 Smalltalk garbageCollect]].
-	^super globalGarbageCollect
-]
-
 { #category : #'growing/shrinking memory' }
 Spur64BitMMLESimulator >> growOldSpaceByAtLeast: minAmmount [
 	"Attempt to grow memory by at least minAmmount.

smalltalksrc/VMMaker/SpurMemoryManager.class.st

@@ -10642,7 +10642,6 @@ SpurMemoryManager >> relocateObjStackForPlanningCompactor: objStack [
 					to: ObjStackNextx + (self rawHashBitsOf: stackOrNil).
 	 stackOrNil = objStack ifTrue:
 		[result := relocated].
-	 self setHashBitsOf: stackOrNil to: 0.
 	 next ~= 0]
 		whileTrue:
 			[stackOrNil := next].

smalltalksrc/VMMaker/SpurPlanningCompactor.class.st

@@ -60,7 +60,8 @@ Class {
 		'mobileStart',
 		'objectAfterLastMobileObject',
 		'savedFirstFieldsSpace',
-		'savedFirstFieldsSpaceNotInOldSpace'
+		'savedFirstFieldsSpaceNotInOldSpace',
+		'savedFirstFieldSpaceMaxSlots'
 	],
 	#pools : [
 		'VMBytecodeConstants'
@@ -162,6 +163,23 @@ SpurPlanningCompactor >> compact [
 	self endCompaction
 ]
 
+{ #category : #'space management' }
+SpurPlanningCompactor >> configureSavedFirstFieldsSpaceStart: theStart limit: theLimit isOldSpace: isOldSpace [
+	"Use teden to hold the savedFirstFieldsSpace."
+
+	<inline: true>
+	| limit |
+	limit := theLimit.
+	savedFirstFieldSpaceMaxSlots ifNotNil: [
+		limit := limit min:
+			(theStart + (savedFirstFieldSpaceMaxSlots * manager bytesPerOop)) ].
+
+	savedFirstFieldsSpace
+		start: theStart;
+		limit: limit.
+	savedFirstFieldsSpaceNotInOldSpace := isOldSpace not
+]
+
 { #category : #compaction }
 SpurPlanningCompactor >> copyAndUnmark: firstPass [
 	"Sweep the heap, unmarking all objects and moving mobile objects to their correct positions,
@@ -351,11 +369,12 @@ SpurPlanningCompactor >> freeFrom: initialToFinger upTo: limit nextObject: nextO
 		[manager addFreeChunkWithBytes: limit - toFinger at: toFinger]
 ]
 
-{ #category : #'instance initialization' }
+{ #category : #initialization }
 SpurPlanningCompactor >> initialize [
 	biasForGC := true.
 	savedFirstFieldsSpace := SpurContiguousObjStack new.
-	savedFirstFieldsSpaceNotInOldSpace := true
+	savedFirstFieldsSpaceNotInOldSpace := true.
+	savedFirstFieldSpaceMaxSlots := nil.
 ]
 
 { #category : #compaction }
@@ -463,6 +482,7 @@ SpurPlanningCompactor >> planCompactSavingForwarders [
 	toFinger := manager startOfObject: firstFreeObject.
 	top := savedFirstFieldsSpace start.
 	startOfPreviousPin := 0.
+	lastMobileObject := nil.
 	manager allOldSpaceEntitiesFrom: firstFreeObject do:
 		[:o|
 		 self check: o.
@@ -508,6 +528,7 @@ SpurPlanningCompactor >> planCompactSavingForwarders [
 						[savedFirstFieldsSpace top: top - manager bytesPerOop.
 						 objectAfterLastMobileObject := manager oldSpaceObjectAfter: lastMobileObject.
 						 ^false]]]].
+
 	"If the heap is already fully compacted there will be no lastMobileObject..."
 	lastMobileObject ifNotNil:
 		[savedFirstFieldsSpace top: top - manager bytesPerOop.
@@ -595,6 +616,12 @@ SpurPlanningCompactor >> repinRememberedSet [
 	scavenger relocateRememberedSet
 ]
 
+{ #category : #'space management' }
+SpurPlanningCompactor >> savedFirstFieldSpaceMaxSlots: aNumber [
+
+	savedFirstFieldSpaceMaxSlots := aNumber
+]
+
 { #category : #'space management' }
 SpurPlanningCompactor >> savedFirstFieldsSpaceInFreeChunk [
 	<inline: true>
@@ -947,11 +974,12 @@ SpurPlanningCompactor >> updateSavedFirstFieldsSpaceIfNecessary [
 { #category : #'space management' }
 SpurPlanningCompactor >> useEdenForSavedFirstFieldsSpace [
 	"Use teden to hold the savedFirstFieldsSpace."
+
 	<inline: true>
-	savedFirstFieldsSpace
-		start: scavenger eden start;
-		limit: scavenger eden limit.
-	savedFirstFieldsSpaceNotInOldSpace := true.
+	self
+		configureSavedFirstFieldsSpaceStart: scavenger eden start
+		limit: scavenger eden limit
+		isOldSpace: false.
 	self deny: self savedFirstFieldsSpaceWasAllocated
 ]
 
@@ -960,35 +988,39 @@ SpurPlanningCompactor >> useFreeChunkForSavedFirstFieldsSpace: highestSuitableFr
 	"Use the supplied free chunk to hold the savedFirstFieldsSpace. Invoked when
 	 eden is found not to be big enough for the job. Avoid the first few fields so as
 	 not to destroy the free chunk and there by confuse object enumeration."
+
 	<inline: true>
 	self assert: (manager validFreeTreeChunk: highestSuitableFreeBlock).
-	savedFirstFieldsSpace
-		start: highestSuitableFreeBlock + (manager freeChunkLargerIndex * manager bytesPerOop);
-		limit: (manager addressAfter: highestSuitableFreeBlock).
-	savedFirstFieldsSpaceNotInOldSpace := false.
+	self
+		configureSavedFirstFieldsSpaceStart: highestSuitableFreeBlock
+			+ (manager freeChunkLargerIndex * manager bytesPerOop)
+		limit: (manager addressAfter: highestSuitableFreeBlock)
+		isOldSpace: false.
 	self deny: self savedFirstFieldsSpaceWasAllocated
 ]
 
 { #category : #'space management' }
 SpurPlanningCompactor >> useSegmentForSavedFirstFieldsSpace: spaceEstimate [
 	"Attempt to allocate a memory segment large enough to hold the savedFirstFieldsSpace.
 	 Invoked when neither eden nor a large free chunk are found to be big enough for the job."
-	| roundedSize allocatedSize |
+
 	<var: #segAddress type: #'void *'>
+	| roundedSize allocatedSize |
 	roundedSize := spaceEstimate + 1023 // 1024 * 1024.
-	(manager "sent to the manager so that the simulator can increase memory to simulate a new segment"
-		sqAllocateMemorySegmentOfSize: roundedSize
-		Above: (manager segmentManager firstGapOfSizeAtLeast: roundedSize)
-		AllocatedSizeInto: (self cCode: [self addressOf: allocatedSize]
-								inSmalltalk: [[:sz| allocatedSize := sz]])) ifNotNil:
-		[:segAddress|
-		 savedFirstFieldsSpace
-			start: segAddress asUnsignedIntegerPtr;
-			limit: segAddress asUnsignedIntegerPtr + allocatedSize.
-		 savedFirstFieldsSpaceNotInOldSpace := true.
-		 self assert: self savedFirstFieldsSpaceWasAllocated.
-		 ^true].
-	^false
+	(manager
+		 sqAllocateMemorySegmentOfSize: roundedSize
+		 Above: (manager segmentManager firstGapOfSizeAtLeast: roundedSize)
+		 AllocatedSizeInto: (self
+				  cCode: [ self addressOf: allocatedSize ]
+				  inSmalltalk: [ [ :sz | allocatedSize := sz ] ])) ifNotNil: [ :segAddress |
+		self
+			configureSavedFirstFieldsSpaceStart:
+			segAddress asUnsignedIntegerPtr
+			limit: segAddress asUnsignedIntegerPtr + allocatedSize
+			isOldSpace: true.
+		self assert: self savedFirstFieldsSpaceWasAllocated.
+		^ true ]. "sent to the manager so that the simulator can increase memory to simulate a new segment"
+	^ false
 ]
 
 { #category : #private }

smalltalksrc/VMMakerTests/VMSpurOldSpaceGarbageCollectorTest.class.st

@@ -220,6 +220,58 @@ VMSpurOldSpaceGarbageCollectorTest >> testAnOldObjectReferencedFromVMVariableSho
 	self assertHashOf: self keptObjectInVMVariable1 equals: hash
 ]
 
+{ #category : #ephemerons }
+VMSpurOldSpaceGarbageCollectorTest >> testCompactEphemeronQueuePass1 [
+
+	| ephemeron |
+
+	"Hole, then mourn queue"
+	self newOldSpaceObjectWithSlots: 0.
+	memory initializeMournQueue.
+
+	"Hole, then ephemeron. Does not really need to be an ephemeron for this tests, any object does it"
+	self newOldSpaceObjectWithSlots: 0.	
+	ephemeron := self newOldSpaceObjectWithSlots: 0.
+	self keepObjectInVMVariable1: ephemeron.
+	memory push: ephemeron onObjStack: memory mournQueue.
+
+	"Compact in one pass"
+	memory garbageCollectForSnapshot.
+	
+	self assert: (memory sizeOfObjStack: memory mournQueue) equals: 1.
+	self assert: memory dequeueMourner equals: self keptObjectInVMVariable1.
+]
+
+{ #category : #ephemerons }
+VMSpurOldSpaceGarbageCollectorTest >> testCompactEphemeronQueuePass2 [
+
+	| ephemeron |
+
+	"For first compaction pass"
+	"Hole, then mourn queue"
+	self newOldSpaceObjectWithSlots: 0.
+	memory initializeMournQueue.
+
+	"For second compaction pass"
+	"Hole, then ephemeron. Does not really need to be an ephemeron for this tests, any object does it"
+	self newOldSpaceObjectWithSlots: 0.	
+	ephemeron := self newOldSpaceObjectWithSlots: 0.
+	self keepObjectInVMVariable1: ephemeron.
+	memory push: ephemeron onObjStack: memory mournQueue.
+
+	"Set the number of objects to compact per compact Phase.
+	We set N=1 to make two compaction phases.
+	The first phase will compact the mourn queue.
+	The second phase will compact the ephemeron."
+	memory compactor savedFirstFieldSpaceMaxSlots: 1.
+	
+	"Compact"
+	memory garbageCollectForSnapshot.
+	
+	self assert: (memory sizeOfObjStack: memory mournQueue) equals: 1.
+	self assert: memory dequeueMourner equals: self keptObjectInVMVariable1.
+]
+
 { #category : #'tests-OldSpaceSize' }
 VMSpurOldSpaceGarbageCollectorTest >> testDoNotCollectRoots [