[Vm-dev] VM Maker: VMMaker.oscog-eem.2085.mcz
commits at source.squeak.org
commits at source.squeak.org
Thu Jan 12 18:49:06 UTC 2017
Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.2085.mcz
==================== Summary ====================
Name: VMMaker.oscog-eem.2085
Author: eem
Time: 12 January 2017, 10:48:18.48524 am
UUID: c0c88f3b-8509-4fa7-a8d0-783efb9ff771
Ancestors: VMMaker.oscog-eem.2084
SpurPlanningCompactor:
Add tests for pinned objects over which, and/or within which live objects are moved.
Move the emptyVM into SpurPlanningCompactorTestsImageResource as SUnit intends.
Fix the compaction enumeration. The previousPin must not be reset until the enumeration is unable to find room for the current mobile object below previousPin. So previousPin is only updated when a mobile object that won't fit beneath it is in hand. Since this means that the size of the object in hand will potentially be tested multiple times, pull it out of the loop over pinned object from previousPin up, and hence refactor copyAndUnmarkObject:to:firstField: to copyAndUnmarkObject:to:bytes:firstField:, and have all the enumerations update toFinger explicitly.
Makew sure that pinned objects above the lastMobileObject are unmarked. Pull this code into its own method.
=============== Diff against VMMaker.oscog-eem.2084 ===============
Item was changed:
----- Method: SpurPlanningCompactor>>copyAndUnmarkMobileObjects (in category 'compaction') -----
copyAndUnmarkMobileObjects
"Sweep the mobile portion of the heap, moving objects to their eventual locations, and clearing their marked bits.
Remember to update the savedFirstFields of pointer objects, as these have been forwarded.
Answer if the end of the heap was reached (savedFirstFieldsSpace has not overflowed).
+ The enumerations in planCompactSavingForwarders, updatePointersInMobileObjects and copyAndUnmarkMobileObjects
+ match. We could implement them as a single enumeration method taking several block arguments, but arguably that
+ would make understanding an already tricky algorithm more difficult. Instead we tolerate the duplication and encourage
+ the reader to diff the three methods to see where they diverge (e.g. via Cmd-shift-C)."
- This enumeration matches those in planCompactSavingForwarders and updatePointersInMobileObjects."
<inline: #never>
| toFinger top previousPin |
<var: 'top' type: #usqInt>
<var: 'toFinger' type: #usqInt>
self deny: (manager isMarked: firstFreeObject).
toFinger := manager startOfObject: firstFreeObject.
top := savedFirstFieldsSpace start.
manager allOldSpaceEntitiesForCompactingFrom: firstFreeObject do:
[:o :n|
self check: o.
self assert: (previousPin
ifNil: [toFinger <= (manager startOfObject: o)]
ifNotNil: [(manager isMarked: previousPin) and: [toFinger <= (manager startOfObject: previousPin)]]).
self assert: (savedFirstFieldsSpaceNotInOldSpace or: [toFinger < top]).
(manager isMarked: o) ifTrue:
[(manager isPinned: o)
ifTrue:
+ [previousPin ifNil:
+ [previousPin := o]]
- [(manager isSegmentBridge: o) ifFalse:
- [manager setIsMarkedOf: o to: false.
- manager segmentManager notePinned: o].
- [previousPin notNil and: [previousPin ~= o]] whileTrue:
- [| limit |
- limit := manager startOfObject: previousPin.
- self assert: (limit - toFinger >= (manager allocationUnit * 2) or: [limit = toFinger]).
- limit > toFinger ifTrue:
- [manager addFreeChunkWithBytes: limit - toFinger at: toFinger.].
- toFinger := manager addressAfter: previousPin.
- previousPin := manager objectStartingAt: toFinger.
- ((manager isPinned: previousPin) and: [manager isMarked: previousPin]) ifFalse:
- [previousPin := nil].
- self assert: toFinger <= (manager startOfObject: o)].
- previousPin := o]
ifFalse:
+ [| availableSpace bytes |
+ bytes := manager bytesInObject: o.
- [| availableSpace bytes next |
[previousPin notNil
and: [availableSpace := (manager startOfObject: previousPin) - toFinger.
- bytes := manager bytesInObject: o.
bytes ~= availableSpace
and: [bytes + (2 * manager allocationUnit) > availableSpace]]] whileTrue:
["The object does not fit in the space between toFinger and previousPin.
+ Move toFinger up to point at the first unmarked or mobile object after
+ previousPin, or, if previousPin is contiguous with o, to the start of this
+ object. Update previousPin to be the next pinned object above toFInger
+ and below this object, or nil if no such pinned object exists.
+ Any unfillable gaps between adjacent pinned objects will be freed."
- Move toFinger beyond previousPin and update previousPin appropriately."
availableSpace > 0 ifTrue:
[manager addFreeChunkWithBytes: availableSpace at: toFinger].
+ [self assert: ((manager isMarked: previousPin) and: [manager isPinned: previousPin]).
+ self unmarkPinned: previousPin.
+ toFinger := manager addressAfter: previousPin.
+ previousPin := manager objectStartingAt: toFinger.
+ (manager isMarked: previousPin)
+ and: [(manager isPinned: previousPin)
+ and: [previousPin < o]]]
+ whileTrue.
+ "Now previousPin is either equal to o or mobile.
+ Move it to the next pinned object below o"
+ [previousPin >= o
+ or: [(manager isMarked: previousPin)
+ and: [manager isPinned: previousPin]]] whileFalse:
+ [previousPin := manager objectAfter: previousPin].
+ previousPin >= o ifTrue:
+ [previousPin := nil]].
+ self copyAndUnmarkObject: o to: toFinger bytes: bytes firstField: (manager longAt: top).
+ toFinger := toFinger + bytes.
- toFinger := manager addressAfter: previousPin.
- next := manager objectStartingAt: toFinger.
- previousPin := ((manager isMarked: next) and: [manager isPinned: next]) ifTrue: [next]].
- toFinger := self copyAndUnmarkObject: o to: toFinger firstField: (manager longAt: top).
(top := top + manager bytesPerOop) >= savedFirstFieldsSpace limit ifTrue:
[| done |
self assert: savedFirstFieldsSpace top = (top - manager bytesPerOop).
done := self noMobileObjectsAfter: n.
done
ifTrue: [self freeAllUnpinnedObjectsFromObject: (previousPin ifNil: [n]) toFinger: toFinger]
ifFalse: [self freeFrom: toFinger upTo: (manager startOfObject: n) previousPin: previousPin].
^done]]]].
self freeFrom: toFinger upTo: manager endOfMemory previousPin: previousPin.
^true!
Item was added:
+ ----- Method: SpurPlanningCompactor>>copyAndUnmarkObject:to:bytes:firstField: (in category 'compaction') -----
+ copyAndUnmarkObject: o to: toFinger bytes: bytes firstField: firstField
+ "Copy the object to toFinger, clearing its mark bit and restoring its firstField, which was overwritten with a forwarding pointer.
+ Answer the number of bytes in the object, including overflow header."
+ <inline: true>
+ | numSlots destObj start |
+ numSlots := manager rawNumSlotsOf: o.
+ destObj := (manager objectWithRawSlotsHasOverflowHeader: numSlots)
+ ifTrue: [toFinger + manager baseHeaderSize]
+ ifFalse: [toFinger].
+ start := manager startOfObject: o given: numSlots.
+ manager
+ mem: toFinger asVoidPointer cp: start asVoidPointer y: bytes;
+ setIsMarkedOf: destObj to: false;
+ storePointerUnchecked: 0 ofObject: destObj withValue: firstField!
Item was removed:
- ----- Method: SpurPlanningCompactor>>copyAndUnmarkObject:to:firstField: (in category 'compaction') -----
- copyAndUnmarkObject: o to: toFinger firstField: firstField
- "Copy the object to toFinger, clearing its mark bit and restoring its firstField, which was overwritten with a forwarding pointer.
- Answer the number of bytes in the object, including overflow header."
- <inline: true>
- | bytes numSlots destObj start |
- numSlots := manager rawNumSlotsOf: o.
- destObj := (manager objectWithRawSlotsHasOverflowHeader: numSlots)
- ifTrue: [toFinger + manager baseHeaderSize]
- ifFalse: [toFinger].
- bytes := manager bytesInObject: o given: numSlots.
- start := manager startOfObject: o given: numSlots.
- manager
- mem: toFinger asVoidPointer cp: start asVoidPointer y: bytes;
- setIsMarkedOf: destObj to: false;
- storePointerUnchecked: 0 ofObject: destObj withValue: firstField.
- ^toFinger + bytes!
Item was removed:
- ----- Method: SpurPlanningCompactor>>firstUnpinnedObjectFollowing: (in category 'private') -----
- firstUnpinnedObjectFollowing: pinnedObj
- | nextObj |
- self assert: (manager isPinned: pinnedObj).
- nextObj := pinnedObj.
- [nextObj := manager objectAfter: nextObj limit: manager endOfMemory.
- nextObj >= manager endOfMemory ifTrue:
- [^manager endOfMemory].
- manager isPinned: nextObj] whileTrue.
- ^nextObj!
Item was changed:
----- Method: SpurPlanningCompactor>>freeAllUnpinnedObjectsFromObject:toFinger: (in category 'private') -----
freeAllUnpinnedObjectsFromObject: nextObj toFinger: initialToFinger
+ "Free all space from toFinger up, preserving only marked pinned objects, clearning their marked bits."
- "Free all space from toFinger up, preserving only marked pinned objects."
| toFinger nextPinnedObj |
<var: 'toFinger' type: #usqInt>
<var: 'nextPinnedObj' type: #usqInt>
toFinger := initialToFinger.
nextPinnedObj := nextObj.
[[nextPinnedObj >= manager endOfMemory
or: [(manager isMarked: nextPinnedObj)
+ and: [manager isPinned: nextPinnedObj]]] whileFalse:
- and: [(manager isPinned: nextPinnedObj)]]] whileFalse:
[nextPinnedObj := manager objectAfter: nextPinnedObj].
nextPinnedObj < manager endOfMemory] whileTrue:
[toFinger < (manager startOfObject: nextPinnedObj) ifTrue:
[manager addFreeChunkWithBytes: (manager startOfObject: nextPinnedObj) - toFinger at: toFinger].
+ self unmarkPinned: nextPinnedObj.
toFinger := manager addressAfter: nextPinnedObj.
nextPinnedObj := manager objectAfter: nextPinnedObj].
toFinger < manager endOfMemory ifTrue:
[manager addFreeChunkWithBytes: manager endOfMemory - toFinger at: toFinger]!
Item was changed:
----- Method: SpurPlanningCompactor>>freeFrom:upTo:previousPin: (in category 'private') -----
freeFrom: toFinger upTo: limit previousPin: previousPinOrNil
"Free from toFinger up to limit, dealing with a possible intervening run of pinned objects starting at previousPinOrNil."
| effectiveToFinger firstUnpinned |
self cCode: [] inSmalltalk:
[coInterpreter cr; cr; print: 'freeing at '; printHexnp: toFinger; print: ' up to '; printHexnp: limit; print: ' pin '; printHexnp: previousPinOrNil; cr].
effectiveToFinger := toFinger.
previousPinOrNil ifNotNil:
[manager addFreeChunkWithBytes: (manager startOfObject: previousPinOrNil) - toFinger at: toFinger.
+ firstUnpinned := self unmarkPinnedObjectsAndFindFirstUnpinnedObjectFollowing: previousPinOrNil.
- firstUnpinned := self firstUnpinnedObjectFollowing: previousPinOrNil.
firstUnpinned >= limit ifTrue:
[^self].
effectiveToFinger := manager startOfObject: firstUnpinned].
manager addFreeChunkWithBytes: limit - effectiveToFinger at: effectiveToFinger!
Item was changed:
----- Method: SpurPlanningCompactor>>planCompactSavingForwarders (in category 'compaction') -----
planCompactSavingForwarders
"Sweep the heap from firstFreeObject forwarding marked objects to where they
can be moved to, saving their forwarding pointer in savedFirstFieldsSpace.
Continue until either the end of the heap is reached or savedFirstFieldsSpace is full.
Answer if the end of the heap was reached (savedFirstFieldsSpace has not overflowed).
+ The enumerations in planCompactSavingForwarders, updatePointersInMobileObjects and copyAndUnmarkMobileObjects
+ match. We could implement them as a single enumeration method taking several block arguments, but arguably that
+ would make understanding an already tricky algorithm more difficult. Instead we tolerate the duplication and encourage
+ the reader to diff the three methods to see where they diverge (e.g. via Cmd-shift-C)."
- This enumeration matches those in updatePointersInMobileObjects and copyAndUnmarkMobileObjects."
<inline: #never>
| toFinger top previousPin |
<var: 'top' type: #usqInt>
<var: 'toFinger' type: #usqInt>
savedFirstFieldsSpace top < savedFirstFieldsSpace start ifTrue:
[self logPhase: 'planning...'].
self deny: (manager isMarked: firstFreeObject).
toFinger := manager startOfObject: firstFreeObject.
top := savedFirstFieldsSpace start.
manager allOldSpaceEntitiesFrom: firstFreeObject do:
[:o|
self check: o.
self assert: (previousPin
ifNil: [toFinger <= (manager startOfObject: o)]
ifNotNil: [(manager isMarked: previousPin) and: [toFinger <= (manager startOfObject: previousPin)]]).
self assert: (savedFirstFieldsSpaceNotInOldSpace or: [toFinger < top]).
(manager isMarked: o) ifTrue:
[(manager isPinned: o)
+ ifTrue:
+ [previousPin ifNil:
+ [previousPin := o]]
- ifTrue: "The empty gaps between two adjacent pinned objects (when not filled below) are freed."
- [[previousPin notNil and: [previousPin ~= o]] whileTrue:
- [self assert: ((manager startOfObject: previousPin) - toFinger >= (manager allocationUnit * 2)
- or: [(manager startOfObject: previousPin) = toFinger]).
- toFinger := manager addressAfter: previousPin.
- previousPin := manager objectStartingAt: toFinger.
- ((manager isPinned: previousPin) and: [manager isMarked: previousPin])
- ifTrue: [toFinger := manager addressAfter: previousPin]
- ifFalse: [previousPin := nil]].
- previousPin := o]
ifFalse:
+ [| availableSpace bytes |
+ bytes := manager bytesInObject: o.
- [| availableSpace bytes next |
[previousPin notNil
and: [availableSpace := (manager startOfObject: previousPin) - toFinger.
- bytes := manager bytesInObject: o.
bytes ~= availableSpace
and: [bytes + (2 * manager allocationUnit) > availableSpace]]] whileTrue:
["The object does not fit in the space between toFinger and previousPin.
+ Move toFinger up to point at the first unmarked or mobile object after
+ previousPin, or, if previousPin is contiguous with o, to the start of this
+ object. Update previousPin to be the next pinned object above toFInger
+ and below this object, or nil if no such pinned object exists.
+ Any unfillable gaps between adjacent pinned objects will be freed."
+ [toFinger := manager addressAfter: previousPin.
+ previousPin := manager objectStartingAt: toFinger.
+ (manager isMarked: previousPin)
+ and: [(manager isPinned: previousPin)
+ and: [previousPin < o]]]
+ whileTrue.
+ "Now previousPin is either equal to o or mobile.
+ Move it to the next pinned object below o"
+ [previousPin >= o
+ or: [(manager isMarked: previousPin)
+ and: [manager isPinned: previousPin]]] whileFalse:
+ [previousPin := manager objectAfter: previousPin].
+ previousPin >= o ifTrue:
+ [previousPin := nil]].
+ self forwardMobileObject: o to: toFinger savedFirstFieldPtr: top.
+ toFinger := toFinger + bytes.
- Move toFinger beyond previousPin and update previousPin appropriately."
- toFinger := manager addressAfter: previousPin.
- next := manager objectStartingAt: toFinger.
- previousPin := ((manager isMarked: next) and: [manager isPinned: next]) ifTrue: [next]].
- toFinger := self forwardMobileObject: o to: toFinger savedFirstFieldPtr: top.
(top := top + manager bytesPerOop) >= savedFirstFieldsSpace limit ifTrue:
[savedFirstFieldsSpace top: top - manager bytesPerOop.
^self noMobileObjectsAfter: o]]]].
savedFirstFieldsSpace top: top - manager bytesPerOop.
^true!
Item was added:
+ ----- Method: SpurPlanningCompactor>>unmarkPinned: (in category 'private') -----
+ unmarkPinned: pinnedObj
+ <inline: true>
+ (manager isSegmentBridge: pinnedObj) ifFalse:
+ [manager setIsMarkedOf: pinnedObj to: false.
+ manager segmentManager notePinned: pinnedObj]!
Item was added:
+ ----- Method: SpurPlanningCompactor>>unmarkPinnedObjectsAndFindFirstUnpinnedObjectFollowing: (in category 'private') -----
+ unmarkPinnedObjectsAndFindFirstUnpinnedObjectFollowing: pinnedObj
+ | nextObj |
+ self assert: (manager isPinned: pinnedObj).
+ nextObj := pinnedObj.
+ [self unmarkPinned: nextObj.
+ nextObj := manager objectAfter: nextObj limit: manager endOfMemory.
+ nextObj >= manager endOfMemory ifTrue:
+ [^manager endOfMemory].
+ manager isPinned: nextObj] whileTrue.
+ ^nextObj!
Item was changed:
----- Method: SpurPlanningCompactor>>updatePointersInMobileObjects (in category 'compaction') -----
updatePointersInMobileObjects
"Sweep the mobile portion of the heap, updating all references to objects to their eventual locations.
Remember to update the savedFirstFields of pointer objects, as these have been forwarded.
Answer if the end of the heap was reached (savedFirstFieldsSpace has not overflowed).
+ The enumerations in planCompactSavingForwarders, updatePointersInMobileObjects and copyAndUnmarkMobileObjects
+ match. We could implement them as a single enumeration method taking several block arguments, but arguably that
+ would make understanding an already tricky algorithm more difficult. Instead we tolerate the duplication and encourage
+ the reader to diff the three methods to see where they diverge (e.g. via Cmd-shift-C)."
- This enumeration matches that in planCompactSavingForwarders and copyAndUnmarkMobileObjects."
| toFinger top previousPin |
<var: 'top' type: #usqInt>
<var: 'toFinger' type: #usqInt>
self deny: (manager isMarked: firstFreeObject).
toFinger := manager startOfObject: firstFreeObject.
top := savedFirstFieldsSpace start.
manager allOldSpaceEntitiesFrom: firstFreeObject do:
[:o|
self check: o.
self assert: (previousPin
ifNil: [toFinger <= (manager startOfObject: o)]
ifNotNil: [(manager isMarked: previousPin) and: [toFinger <= (manager startOfObject: previousPin)]]).
(manager isMarked: o) ifTrue:
[(manager isPinned: o)
+ ifTrue:
+ [previousPin ifNil:
+ [previousPin := o].
+ self updatePointersIn: o]
- ifTrue: "The empty gaps between two adjacent pinned objects (when not filled below) are freed."
- [self updatePointersIn: o.
- [previousPin notNil and: [previousPin ~= o]] whileTrue:
- [self assert: ((manager startOfObject: previousPin) - toFinger >= (manager allocationUnit * 2)
- or: [(manager startOfObject: previousPin) = toFinger]).
- toFinger := manager addressAfter: previousPin.
- previousPin := manager objectStartingAt: toFinger.
- ((manager isPinned: previousPin) and: [manager isMarked: previousPin]) ifFalse:
- [previousPin := nil].
- self assert: toFinger <= (manager startOfObject: o)].
- previousPin := o]
ifFalse:
+ [| availableSpace bytes |
+ bytes := manager bytesInObject: o.
- [| availableSpace bytes next |
[previousPin notNil
and: [availableSpace := (manager startOfObject: previousPin) - toFinger.
- bytes := manager bytesInObject: o.
bytes ~= availableSpace
and: [bytes + (2 * manager allocationUnit) > availableSpace]]] whileTrue:
["The object does not fit in the space between toFinger and previousPin.
+ Move toFinger up to point at the first unmarked or mobile object after
+ previousPin, or, if previousPin is contiguous with o, to the start of this
+ object. Update previousPin to be the next pinned object above toFInger
+ and below this object, or nil if no such pinned object exists.
+ Any unfillable gaps between adjacent pinned objects will be freed."
+ [toFinger := manager addressAfter: previousPin.
+ previousPin := manager objectStartingAt: toFinger.
+ (manager isMarked: previousPin)
+ and: [(manager isPinned: previousPin)
+ and: [previousPin < o]]]
+ whileTrue.
+ "Now previousPin is either equal to o or mobile.
+ Move it to the next pinned object below o"
+ [previousPin >= o
+ or: [(manager isMarked: previousPin)
+ and: [manager isPinned: previousPin]]] whileFalse:
+ [previousPin := manager objectAfter: previousPin].
+ previousPin >= o ifTrue:
+ [previousPin := nil]].
- Move toFinger beyond previousPin and update previousPin appropriately."
- toFinger := manager addressAfter: previousPin.
- next := manager objectStartingAt: toFinger.
- previousPin := ((manager isMarked: next) and: [manager isPinned: next]) ifTrue: [next]].
self updatePointersIn: o savedFirstFieldPointer: top.
+ toFinger := toFinger + bytes.
- toFinger := toFinger + (manager bytesInObject: o).
(top := top + manager bytesPerOop) >= savedFirstFieldsSpace limit ifTrue:
[self assert: savedFirstFieldsSpace top = (top - manager bytesPerOop).
^self noMobileObjectsAfter: o]]]].
self assert: savedFirstFieldsSpace top = (top - manager bytesPerOop).
^true!
Item was changed:
TestCase subclass: #SpurPlanningCompactorTests
+ instanceVariableNames: ''
- instanceVariableNames: 'emptyVM'
classVariableNames: ''
poolDictionaries: 'VMSqueakClassIndices'
category: 'VMMaker-Tests'!
Item was added:
+ ----- Method: SpurPlanningCompactorTests class>>resources (in category 'accessing') -----
+ resources
+ ^{SpurPlanningCompactorTestsImageResource}!
Item was removed:
- ----- Method: SpurPlanningCompactorTests>>initialize (in category 'initialize-release') -----
- initialize
- emptyVM := StackInterpreterSimulator newWithOptions: #(ObjectMemory Spur32BitMemoryManager
- compactorClass SpurPlanningCompactor)!
Item was changed:
----- Method: SpurPlanningCompactorTests>>initializedVM (in category 'private') -----
initializedVM
| newVM |
+ newVM := self resources anyOne current emptyVM cloneSimulation.
- newVM := emptyVM cloneSimulation.
newVM
openOn: self class imageNameForTests extraMemory: 0;
initStackPages.
newVM objectMemory
initializeMarkStack; "The Pharo bootstrap has no mark or weakling stacks :-)"
initializeWeaklingStack.
^newVM!
Item was changed:
----- Method: SpurPlanningCompactorTests>>testRunOfContiguousPinnedObjects (in category 'tests') -----
testRunOfContiguousPinnedObjects
"Test that the compactor can handle a long run of adjacent pinned objects across which it can and must move some unpinned objects."
| om expectedFreeSpace firstPinnedObj gapObj obj |
om := self initializedVM objectMemory.
om allOldSpaceObjectsDo: [:o| om setIsMarkedOf: o to: true].
"First create a gap"
gapObj := om allocateSlotsInOldSpace: 100 format: om firstLongFormat classIndex: ClassArrayCompactIndex.
om fillObj: gapObj numSlots: 100 with: om falseObject.
+ self deny: (om isMarked: gapObj).
"Now a long run of pinned objects."
+ 20 timesRepeat:
- 50 timesRepeat:
[obj := om allocateSlotsInOldSpace: 4 format: om firstLongFormat classIndex: ClassBitmapCompactIndex.
om
fillObj: obj numSlots: 4 with: 16r99999999;
setIsPinnedOf: obj to: true;
setIsMarkedOf: obj to: true.
firstPinnedObj ifNil:
[firstPinnedObj := obj]].
"Now something to move around it."
obj := om allocateSlotsInOldSpace: 100 format: om firstLongFormat classIndex: ClassBitmapCompactIndex.
om fillObj: obj numSlots: 100 with: 16r55AA55AA;
setIsMarkedOf: obj to: true.
"And something to move to the end of it."
obj := om allocateSlotsInOldSpace: 100 format: om firstLongFormat classIndex: ClassBitmapCompactIndex.
om fillObj: obj numSlots: 100 with: 16rAA55AA55;
setIsMarkedOf: obj to: true.
+ "useful debugging:""om printOopsFrom: gapObj to: om endOfMemory"
-
expectedFreeSpace := om bytesLeftInOldSpace + (om bytesInObject: gapObj).
om compactor compact.
self assert: expectedFreeSpace equals: om bytesLeftInOldSpace.
+ self assert: om allObjectsUnmarked.
- om allOldSpaceObjectsDo: [:o| self deny: (om isMarked: o)].
"The first mobile object past the pinned objects should have moved."
self assert: ClassBitmapCompactIndex equals: (om classIndexOf: gapObj).
self deny: (om isPinned: gapObj).
0 to: 99 do: [:i| self assert: 16r55AA55AA equals: (om fetchPointer: i ofObject: gapObj)].
"The pinned objects should not have moved."
obj := firstPinnedObj.
+ 20 timesRepeat:
- 50 timesRepeat:
[self assert: ClassBitmapCompactIndex equals: (om classIndexOf: obj).
0 to: 3 do: [:i| self assert: 16r99999999 equals: (om fetchPointer: i ofObject: obj)].
obj := om objectAfter: obj].
"The last object should have moved down."
self assert: ClassBitmapCompactIndex equals: (om classIndexOf: obj).
self deny: (om isPinned: obj).
0 to: 99 do: [:i| self assert: 16rAA55AA55 equals: (om fetchPointer: i ofObject: obj)].
"It should be the last object..."
self assert: (om isFreeObject: (om objectAfter: obj)).
self assert: om endOfMemory equals: (om addressAfter: (om objectAfter: obj))
!
Item was added:
+ ----- Method: SpurPlanningCompactorTests>>testRunOfNonContiguousPinnedObjects (in category 'tests') -----
+ testRunOfNonContiguousPinnedObjects
+ "Test that the compactor can handle a long run of adjacent pinned objects separated by small ammounts of free space, across which it can and must move some unpinned objects."
+ | om expectedFreeSpace firstPinnedObj gapObj obj numPins |
+ om := self initializedVM objectMemory.
+ om allOldSpaceObjectsDo: [:o| om setIsMarkedOf: o to: true].
+ "First create a gap"
+ gapObj := om allocateSlotsInOldSpace: 100 format: om firstLongFormat classIndex: ClassArrayCompactIndex.
+ om fillObj: gapObj numSlots: 100 with: om falseObject.
+ self deny: (om isMarked: gapObj).
+ "Now a long run of pinned objects."
+ (numPins := 20) timesRepeat:
+ [obj := om allocateSlotsInOldSpace: 4 format: om firstLongFormat classIndex: ClassBitmapCompactIndex.
+ om
+ fillObj: obj numSlots: 4 with: 16r99999999;
+ setIsPinnedOf: obj to: true;
+ setIsMarkedOf: obj to: true.
+ firstPinnedObj ifNil:
+ [firstPinnedObj := obj].
+ om allocateSlotsInOldSpace: 4 format: om firstLongFormat classIndex: ClassArrayCompactIndex].
+ "Now something to move around it."
+ obj := om allocateSlotsInOldSpace: 100 format: om firstLongFormat classIndex: ClassBitmapCompactIndex.
+ om fillObj: obj numSlots: 100 with: 16r55AA55AA;
+ setIsMarkedOf: obj to: true.
+ "And something to move to the end of it."
+ obj := om allocateSlotsInOldSpace: 100 format: om firstLongFormat classIndex: ClassBitmapCompactIndex.
+ om fillObj: obj numSlots: 100 with: 16rAA55AA55;
+ setIsMarkedOf: obj to: true.
+
+ "useful debugging:""om printOopsFrom: gapObj to: om endOfMemory"
+ expectedFreeSpace := om bytesLeftInOldSpace + (om bytesInObject: gapObj) + ((om bytesInObject: firstPinnedObj) * numPins).
+ om compactor compact.
+ self assert: expectedFreeSpace equals: om bytesLeftInOldSpace.
+ self assert: om allObjectsUnmarked.
+
+ "The first mobile object past the pinned objects should have moved."
+ self assert: ClassBitmapCompactIndex equals: (om classIndexOf: gapObj).
+ self deny: (om isPinned: gapObj).
+ 0 to: 99 do: [:i| self assert: 16r55AA55AA equals: (om fetchPointer: i ofObject: gapObj)].
+ "The pinned objects should not have moved."
+ obj := firstPinnedObj.
+ 1 to: numPins do:
+ [:n|
+ self assert: ClassBitmapCompactIndex equals: (om classIndexOf: obj).
+ 0 to: 3 do: [:i| self assert: 16r99999999 equals: (om fetchPointer: i ofObject: obj)].
+ obj := om objectAfter: obj.
+ n < numPins ifTrue:
+ [self assert: (om isFreeObject: obj).
+ obj := om objectAfter: obj]].
+ "The last object should have moved down."
+ self assert: ClassBitmapCompactIndex equals: (om classIndexOf: obj).
+ self deny: (om isPinned: obj).
+ 0 to: 99 do: [:i| self assert: 16rAA55AA55 equals: (om fetchPointer: i ofObject: obj)].
+ "It should be the last object..."
+ self assert: (om isFreeObject: (om objectAfter: obj)).
+ self assert: om endOfMemory equals: (om addressAfter: (om objectAfter: obj))
+ !
Item was added:
+ ----- Method: SpurPlanningCompactorTests>>testRunOfNonContiguousPinnedObjectsWithSpaceInBetween (in category 'tests') -----
+ testRunOfNonContiguousPinnedObjectsWithSpaceInBetween
+ "Test that the compactor can handle a long run of adjacent pinned objects separated by large ammounts of free space, into which it can and must move some unpinned objects."
+ | om expectedFreeSpace firstPinnedObj gapObj obj numPins firstFreeObj |
+ om := self initializedVM objectMemory.
+ om allOldSpaceObjectsDo: [:o| om setIsMarkedOf: o to: true].
+ "First create a gap"
+ gapObj := om allocateSlotsInOldSpace: 100 format: om firstLongFormat classIndex: ClassArrayCompactIndex.
+ om fillObj: gapObj numSlots: 100 with: om falseObject.
+ self deny: (om isMarked: gapObj).
+ "Now a long run of pinned objects."
+ (numPins := 10) timesRepeat:
+ [obj := om allocateSlotsInOldSpace: 4 format: om firstLongFormat classIndex: ClassBitmapCompactIndex.
+ om
+ fillObj: obj numSlots: 4 with: 16r99999999;
+ setIsPinnedOf: obj to: true;
+ setIsMarkedOf: obj to: true.
+ firstPinnedObj ifNil:
+ [firstPinnedObj := obj].
+ obj := om allocateSlotsInOldSpace: 104 format: om firstLongFormat classIndex: ClassArrayCompactIndex.
+ firstFreeObj ifNil:
+ [firstFreeObj := obj]].
+ self deny: (om isMarked: firstFreeObj).
+ "Now some objects to move around and into the run of pinned objects."
+ numPins timesRepeat:
+ [obj := om allocateSlotsInOldSpace: 100 format: om firstLongFormat classIndex: ClassBitmapCompactIndex.
+ om fillObj: obj numSlots: 100 with: 16r55AA55AA;
+ setIsMarkedOf: obj to: true.
+ obj := om allocateSlotsInOldSpace: 100 format: om firstLongFormat classIndex: ClassBitmapCompactIndex.
+ om fillObj: obj numSlots: 100 with: 16rAA55AA55;
+ setIsMarkedOf: obj to: true].
+
+ "useful debugging:""om printOopsFrom: gapObj to: om endOfMemory"
+ expectedFreeSpace := om bytesLeftInOldSpace + (om bytesInObject: gapObj) + ((om bytesInObject: firstFreeObj) * numPins).
+ om compactor compact.
+ self assert: expectedFreeSpace equals: om bytesLeftInOldSpace.
+ self assert: om allObjectsUnmarked.
+
+ "The first mobile object past the pinned objects should have moved. The pinned objects should not have moved.
+ We should see moved obj, pinned obj, (moved obj, free obj, pinned obj) +"
+ obj := gapObj.
+ 1 to: numPins do:
+ [:n|
+ self assert: ClassBitmapCompactIndex equals: (om classIndexOf: obj).
+ self deny: (om isPinned: obj).
+ 0 to: 99 do: [:i| self assert: (n odd ifTrue: [16r55AA55AA] ifFalse: [16rAA55AA55]) equals: (om fetchPointer: i ofObject: obj)].
+ obj := om objectAfter: obj.
+ n > 1 ifTrue:
+ [self assert: (om isFreeObject: obj).
+ obj := om objectAfter: obj].
+ self assert: ClassBitmapCompactIndex equals: (om classIndexOf: obj).
+ self assert: (om isPinned: obj).
+ 0 to: 3 do: [:i| self assert: 16r99999999 equals: (om fetchPointer: i ofObject: obj)].
+ obj := om objectAfter: obj].
+ "The last objects should have moved down."
+ 1 to: numPins do:
+ [:n|
+ self assert: ClassBitmapCompactIndex equals: (om classIndexOf: obj).
+ self deny: (om isPinned: obj).
+ 0 to: 99 do: [:i| self assert: (n odd ifTrue: [16r55AA55AA] ifFalse: [16rAA55AA55]) equals: (om fetchPointer: i ofObject: obj)]..
+ obj := om objectAfter: obj].
+ "They should be the last objects..."
+ self assert: (om isFreeObject: obj).
+ self assert: om endOfMemory equals: (om addressAfter: obj)
+ !
Item was added:
+ TestResource subclass: #SpurPlanningCompactorTestsImageResource
+ instanceVariableNames: 'emptyVM'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'VMMaker-Tests'!
Item was added:
+ ----- Method: SpurPlanningCompactorTestsImageResource>>emptyVM (in category 'accessing') -----
+ emptyVM
+ ^emptyVM ifNil:
+ [emptyVM := StackInterpreterSimulator newWithOptions: #(ObjectMemory Spur32BitMemoryManager
+ compactorClass SpurPlanningCompactor)]!
More information about the Vm-dev
mailing list