VM Maker: VMMaker.oscogSPC-eem.2122.mcz

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

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

Name: VMMaker.oscogSPC-eem.2122
Author: eem
Time: 6 February 2017, 12:50:07.26467 pm
UUID: a8c5aec3-0d43-42c4-911a-2d8c8cb6edef
Ancestors: VMMaker.oscogSPC-eem.2121

SpurPlanningCompactor:
Fix compaction with a fully compacted heap (lastMobileObject may be nil).

SpurMemoryManager:
add a VM parameter to collect the time spent in compaction (a subset of the time spent in fullGC).


The system now holds up while rnning the Squeak test suite.

=============== Diff against VMMaker.oscogSPC-eem.2121 ===============

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

Item was changed:
  ----- Method: SpurMemoryManager>>fullGC (in category 'gc - global') -----
  fullGC
  "Perform a full lazy compacting GC.  Answer the size of the largest free chunk."
  <returnTypeC: #usqLong>
  <inline: #never> "for profiling"
  needGCFlag := false.
+ gcStartUsecs := coInterpreter ioUTCMicrosecondsNow.
- gcStartUsecs := self ioUTCMicrosecondsNow.
  statMarkCount := 0.
  coInterpreter preGCAction: GCModeFull.
  self globalGarbageCollect.
  coInterpreter postGCAction: GCModeFull.
  statFullGCs := statFullGCs + 1.
+ statGCEndUsecs := coInterpreter ioUTCMicrosecondsNow.
- statGCEndUsecs := self ioUTCMicrosecondsNow.
  statFullGCUsecs := statFullGCUsecs + (statGCEndUsecs - gcStartUsecs).
+ statCompactionUsecs := statCompactionUsecs + (statGCEndUsecs - compactionStartUsecs).
  ^(freeLists at: 0) ~= 0
  ifTrue: [self bytesInObject: self findLargestFreeChunk]
  ifFalse: [0]!

Item was changed:
  ----- Method: SpurMemoryManager>>globalGarbageCollect (in category 'gc - global') -----
  globalGarbageCollect
  <inline: true> "inline into fullGC"
  self assert: self validObjStacks.
  self assert: (self isEmptyObjStack: markStack).
  self assert: (self isEmptyObjStack: weaklingStack).
 
  "Mark objects /before/ scavenging, to empty the rememberedTable of unmarked roots."
  self markObjects: true.
 
  scavenger forgetUnmarkedRememberedObjects.
  self doScavenge: MarkOnTenure.
 
  "Mid-way the leak check must be more lenient.  Unmarked classes will have been
  expunged from the table, but unmarked instances will not yet have been reclaimed."
  self runLeakCheckerFor: GCModeFull
  excludeUnmarkedObjs: true
  classIndicesShouldBeValid: true.
 
+ compactionStartUsecs := coInterpreter ioUTCMicrosecondsNow.
  segmentManager prepareForGlobalSweep. "for notePinned:"
  compactor compact.
  self attemptToShrink.
  self setHeapSizeAtPreviousGC.
 
  self assert: self validObjStacks.
  self assert: (self isEmptyObjStack: markStack).
  self assert: (self isEmptyObjStack: weaklingStack).
  self assert: self allObjectsUnmarked.
  self runLeakCheckerFor: GCModeFull!

Item was changed:
  ----- Method: SpurMemoryManager>>initialize (in category 'initialization') -----
  initialize
  "We can put all initializations that set something to 0 or to false here.
  In C all global variables are initialized to 0, and 0 is false."
  remapBuffer := Array new: RemapBufferSize.
  remapBufferCount := extraRootCount := 0. "see below"
  freeListsMask := totalFreeOldSpace := lowSpaceThreshold := 0.
  checkForLeaks := 0.
  needGCFlag := signalLowSpace := marking := false.
  becomeEffectsFlags := gcPhaseInProgress := 0.
  statScavenges := statIncrGCs := statFullGCs := 0.
+ statScavengeGCUsecs := statIncrGCUsecs := statFullGCUsecs := statCompactionUsecs := statGCEndUsecs := 0.
- statScavengeGCUsecs := statIncrGCUsecs := statFullGCUsecs := statGCEndUsecs := 0.
  statSGCDeltaUsecs := statIGCDeltaUsecs := statFGCDeltaUsecs := 0.
  statGrowMemory := statShrinkMemory := statRootTableCount := 0.
  statRootTableOverflows := statMarkCount := statCompactPassCount := statCoalesces := 0.
 
  "We can initialize things that are allocated but are lazily initialized."
  unscannedEphemerons := SpurContiguousObjStack new.
 
  "we can initialize things that are virtual in C."
  scavenger := SpurGenerationScavenger simulatorClass new manager: self; yourself.
  segmentManager := SpurSegmentManager simulatorClass new manager: self; yourself.
  compactor := self class compactorClass simulatorClass new manager: self; yourself.
 
  "We can also initialize here anything that is only for simulation."
  heapMap := CogCheck32BitHeapMap new.
 
  "N.B. We *don't* initialize extraRoots because we don't simulate it."
  maxOldSpaceSize := self class initializationOptions
  ifNotNil: [:initOpts| initOpts at: #maxOldSpaceSize ifAbsent: [0]]
  ifNil: [0]!

Item was added:
+ ----- Method: SpurMemoryManager>>statCompactionUsecs (in category 'accessing') -----
+ statCompactionUsecs
+ ^statCompactionUsecs!

Item was changed:
  ----- Method: SpurPlanningCompactor>>compact (in category 'compaction - api') -----
  compact
  "Sweep all of old space, sliding unpinned marked objects down over free and unmarked objects.
  Let the segmentManager mark which segments contain pinned objects via notePinned:."
  | finalPass firstPass |
  <inline: #never> "for profiling"
  self initializeScanCheckingForFullyCompactedHeap ifTrue:
  [^self unmarkObjectsInFullyCompactedHeap].
  self initializeCompaction.
  firstPass := true.
  [finalPass := self planCompactSavingForwarders.
  self assert: (self validRelocationPlanInPass: finalPass) = 0.
- objectAfterLastMobileObject := manager oldSpaceObjectAfter: lastMobileObject.
  self updatePointers.
  self copyAndUnmark: firstPass.
  "Would like to check here, but can't if multi-pass."
  false ifTrue: [manager checkFreeSpace: GCModeFull].
  "Currently we do only a single pass if a normal GC, assuming that a pass will
   always compact plenty of space. But we should perhaps check this assumption
   by looking at the large free tree and seeing that the ratio of the largest free
   chunk to the total ammount of free space is high."
  finalPass or: [biasForGC]] whileFalse:
  [firstPass := false.
  self reinitializeScanFrom: firstFreeObject;
  updateSavedFirstFieldsSpaceIfNecessary].
  manager checkFreeSpace: GCModeFull.
  self endCompaction!

Item was changed:
  ----- Method: SpurPlanningCompactor>>copyAndUnmark: (in category 'compaction') -----
  copyAndUnmark: firstPass
  "Sweep the heap, unmarking all objects and moving mobile objects to their correct positions,
  restoring their savedFirstFields."
  <inline: #never>
  | finalPass |
  self logPhase: 'copying and unmarking...'.
  firstPass ifTrue:
  [self unmarkInitialImmobileObjects].
- "If savedFirstFieldsSpace is empty there is nothing to move, and no second pass."
- savedFirstFieldsSpace top < savedFirstFieldsSpace start ifTrue:
- [self assert: ((self oop: firstMobileObject isGreaterThanOrEqualTo: manager endOfMemory)
- or: [lastMobileObject < firstMobileObject]).
- ^self].
  finalPass := self copyAndUnmarkMobileObjects.
+ (self thereAreObjectsToMove
+ and: [finalPass not
+ and: [biasForGC]]) ifTrue: "only ever one pass if biasForGC is true."
- (finalPass not and: [biasForGC]) ifTrue: "only ever one pass if biasForGC is true."
  [self unmarkObjectsAfterLastMobileObject]!

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)."
  <inline: #never>
  | toFinger top previousPin startOfPreviousPin |
  <var: 'o' type: #usqInt>
  <var: 'top' type: #usqInt>
  <var: 'toFinger' type: #usqInt>
  <var: 'previousPin' type: #usqInt>
  <var: 'startOfPreviousPin' type: #usqInt>
  self deny: (manager isMarked: firstFreeObject).
  toFinger := manager startOfObject: firstFreeObject.
  top := savedFirstFieldsSpace start.
  startOfPreviousPin := 0.
+ manager allOldSpaceEntitiesForCompactingFrom: firstFreeObject to: (lastMobileObject ifNil: manager nilObject) do:
- manager allOldSpaceEntitiesForCompactingFrom: firstFreeObject to: lastMobileObject do:
  [:o :n|
  self check: o.
  self assert: (previousPin
  ifNil: [toFinger <= (manager startOfObject: o)]
  ifNotNil: [(manager isMarked: previousPin) and: [toFinger <= startOfPreviousPin]]).
  self assert: (savedFirstFieldsSpaceNotInOldSpace or: [toFinger < top]).
  (manager isMarked: o) ifTrue:
  [(manager isPinned: o)
  ifTrue:
  [previousPin ifNil:
  [previousPin := o. startOfPreviousPin := manager startOfObject: o]]
  ifFalse:
  [| availableSpace bytes |
  bytes := manager bytesInObject: o.
  [toFinger <= startOfPreviousPin
   and: [bytes ~= (availableSpace := startOfPreviousPin - toFinger)
   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."
  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 oldSpaceObjectAfter: previousPin].
  previousPin >= o
  ifTrue: [previousPin := nil. startOfPreviousPin := 0]
  ifFalse: [startOfPreviousPin := manager startOfObject: previousPin]].
  self copyAndUnmarkObject: o to: toFinger bytes: bytes firstField: (manager longAt: top).
  toFinger := toFinger + bytes.
  (top := top + manager bytesPerOop) >= savedFirstFieldsSpace limit ifTrue:
  [self assert: savedFirstFieldsSpace top = (top - manager bytesPerOop).
  self assert: n = objectAfterLastMobileObject.
  previousPin ifNil: [previousPin := n. startOfPreviousPin := manager startOfObject: n].
  "Create a free object for firstFreeObject to be set to on the next pass, but
    do not link it into the free tree as it will be written over in that next pass."
  toFinger < startOfPreviousPin
  ifTrue:
  [firstFreeObject := manager initFreeChunkWithBytes: startOfPreviousPin - toFinger at: toFinger]
  ifFalse:
  [firstFreeObject := previousPin].
  ^false]]]].
+ self freeFrom: toFinger upTo: manager endOfMemory nextObject: (previousPin ifNil: [objectAfterLastMobileObject ifNil: [manager objectAfter: firstFreeObject]]).
- self freeFrom: toFinger upTo: manager endOfMemory nextObject: (previousPin ifNil: [objectAfterLastMobileObject]).
  self coalesceFrom: toFinger.
  ^true!

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)."
  <inline: #never>
  | toFinger top previousPin startOfPreviousPin |
  <var: 'o' type: #usqInt>
  <var: 'top' type: #usqInt>
  <var: 'toFinger' type: #usqInt>
  <var: 'previousPin' type: #usqInt>
  <var: 'startOfPreviousPin' type: #usqInt>
  savedFirstFieldsSpace top < savedFirstFieldsSpace start ifTrue:
  [self logPhase: 'planning...'].
  self deny: (manager isMarked: firstFreeObject).
  toFinger := manager startOfObject: firstFreeObject.
  top := savedFirstFieldsSpace start.
  startOfPreviousPin := 0.
  manager allOldSpaceEntitiesFrom: firstFreeObject do:
  [:o|
  self check: o.
  self assert: (previousPin
  ifNil: [toFinger <= (manager startOfObject: o)]
  ifNotNil: [(manager isMarked: previousPin) and: [toFinger <= startOfPreviousPin]]).
  self assert: (savedFirstFieldsSpaceNotInOldSpace or: [toFinger < top]).
  (manager isMarked: o) ifTrue:
  [(manager isPinned: o)
  ifTrue:
  [previousPin ifNil:
  [previousPin := o. startOfPreviousPin := manager startOfObject: o]]
  ifFalse:
  [| availableSpace bytes |
  bytes := manager bytesInObject: o.
  [toFinger <= startOfPreviousPin
   and: [bytes ~= (availableSpace := startOfPreviousPin - toFinger)
   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 oldSpaceObjectAfter: previousPin].
  previousPin >= o
  ifTrue: [previousPin := nil. startOfPreviousPin := 0]
  ifFalse: [startOfPreviousPin := manager startOfObject: previousPin]].
  self forwardMobileObject: o to: toFinger savedFirstFieldPtr: top.
  toFinger := toFinger + bytes.
  (top := top + manager bytesPerOop) >= savedFirstFieldsSpace limit ifTrue:
  [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.
+ objectAfterLastMobileObject := manager oldSpaceObjectAfter: lastMobileObject].
- savedFirstFieldsSpace top: top - manager bytesPerOop.
  ^true!

Item was added:
+ ----- Method: SpurPlanningCompactor>>thereAreObjectsToMove (in category 'private') -----
+ thereAreObjectsToMove
+ <inline: true>
+ ^lastMobileObject notNil!

Item was changed:
  ----- Method: SpurPlanningCompactor>>updatePointers (in category 'compaction') -----
  updatePointers
  "Sweep the heap, updating all objects to their eventual locations.
  Remember to update the savedFirstFields of pointer objects, as these have been forwarded."
  <inline: #never>
  | onePass |
  self logPhase: 'updating pointers...'.
+ self thereAreObjectsToMove ifFalse:
- "If savedFirstFieldsSpace is empty there is nothing to do."
- savedFirstFieldsSpace top < savedFirstFieldsSpace start ifTrue:
  [^self].
  self assert: (manager startOfObject: firstFreeObject) = mobileStart.
  coInterpreter mapInterpreterOops.
  manager mapExtraRoots.
  self updatePointersInManagerHeapEntities.
  self updatePointersInSurvivingObjects.
  self updatePointersInInitialImmobileObjects.
  onePass := self updatePointersInMobileObjects.
  onePass ifFalse:
  [self updatePointersInObjectsOverflowingSavedFirstFieldsSpace]!

Item was changed:
+ LongTestCase subclass: #SpurPlanningCompactorTests
- TestCase subclass: #SpurPlanningCompactorTests
  instanceVariableNames: ''
  classVariableNames: ''
+ poolDictionaries: 'VMBasicConstants VMSqueakClassIndices'
- poolDictionaries: 'VMSqueakClassIndices'
  category: 'VMMaker-Tests'!

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

Item was added:
+ ----- Method: SpurPlanningCompactorTests>>expectedFailures (in category 'failures') -----
+ expectedFailures
+ ^(FileDirectory default fileExists: self class imageNameForTests)
+ ifTrue: [#()]
+ ifFalse: [self testSelectors]!

Item was changed:
  ----- Method: SpurPlanningCompactorTests>>testCompactedHeap (in category 'tests') -----
  testCompactedHeap
  "First test for valid compactibility of an already compacted heap via fullGC"
  | freeSpace om |
  om := self initializedVM objectMemory.
  freeSpace := om bytesLeftInOldSpace.
  om fullGC.
+ self assert: freeSpace equals: om bytesLeftInOldSpace.
+ self checkForLeaksIn: om.
+ om fullGC.
+ self assert: freeSpace equals: om bytesLeftInOldSpace.
+ self checkForLeaksIn: om!
- self assert: freeSpace equals: om bytesLeftInOldSpace!

Item was added:
+ ----- Method: SpurPlanningCompactorTests>>testInitializedVM (in category 'tests') -----
+ testInitializedVM
+ self checkForLeaksIn: self initializedVM objectMemory!

Item was changed:
  ----- Method: SpurPlanningCompactorTests>>testRandomAssortment:with: (in category 'private') -----
  testRandomAssortment: random with: theVM
  "Test that the compactor can handle a random assortment of live, pinned, dead, and free chunks."
  | om lastObj obj expectedFreeSpace liveFill pinFill liveCount pinCount totalLive totalPinned pinned |
  random reset. "random is a read stream on 3000 random numbers; for repeatability"
  om := theVM objectMemory.
  om allOldSpaceObjectsDo: [:o| om setIsMarkedOf: o to: true. lastObj := o].
  pinFill := 16r99999900.
  liveFill := 16r55AA0000.
  liveCount := pinCount := expectedFreeSpace := 0.
  pinned := Set new.
  1000 timesRepeat:
  [| nSlots next newObj |
  nSlots := (random next * 300) rounded. "Make sure we stray into overflow size field territory."
+ newObj := om allocateSlotsInOldSpace: nSlots format: om firstLongFormat classIndex: ClassByteArrayCompactIndex.
- newObj := om allocateSlotsInOldSpace: nSlots format: om firstLongFormat classIndex: ClassBitmapCompactIndex.
  (next := random next) > 0.95
  ifTrue: "pinned"
  [om
  fillObj: newObj numSlots: nSlots with: pinFill + (pinCount := pinCount + 1);
  setIsPinnedOf: newObj to: true]
  ifFalse: "mobile"
  [om
  fillObj: newObj numSlots: nSlots with: liveFill + (liveCount := liveCount + 1)].
  (next := random next) >= 0.333
  ifTrue:
  [om setIsMarkedOf: newObj to: true.
  (om isPinned: newObj) ifTrue:
  [pinned add: newObj]]
  ifFalse: "dead or free"
  [expectedFreeSpace := expectedFreeSpace + (om bytesInObject: newObj).
  (om isPinned: newObj) "Must check /before/ setObjectFree: which clears all bits"
  ifTrue: [pinCount := pinCount - 1]
  ifFalse: [liveCount := liveCount - 1].
  next >= 0.2
  ifTrue: [om setIsMarkedOf: newObj to: false]
  ifFalse: [om setObjectFree: newObj]]].
  totalPinned := pinCount.
  totalLive := liveCount.
  self assert: totalPinned < (totalPinned + totalLive / 10). "should average 5%"
 
  "useful pre-compaction printing:"
  false ifTrue:
  [liveCount := pinCount := 0.
  om allOldSpaceEntitiesFrom: (om objectAfter: lastObj) to: (om objectBefore: om endOfMemory) do:
  [:o|
  om coInterpreter print:
  ((om isMarked: o)
  ifTrue: [(((om isPinned: o)
  ifTrue: [pinCount := pinCount + 1]
  ifFalse: [liveCount := liveCount + 1])
  printPaddedWith: Character space to: 3 base: 10), ' ']
  ifFalse: ['     ']).
  om printEntity: o].
  om allOldSpaceEntitiesFrom: (om objectAfter: lastObj) to: (om objectBefore: om endOfMemory) do:
  [:o|
  ((om isMarked: o) and: [om isPinned: o]) ifTrue:
  [om printEntity: o]]].
 
  expectedFreeSpace := expectedFreeSpace + om bytesLeftInOldSpace.
  om compactor compact.
  self assert: expectedFreeSpace equals: om bytesLeftInOldSpace.
  self assert: om allObjectsUnmarked.
 
  "useful post-compaction printing:"
  false ifTrue:
  [liveCount := pinCount := 0.
  om allOldSpaceEntitiesFrom: (om objectAfter: lastObj) to: (om objectBefore: om endOfMemory) do:
  [:o|
  om coInterpreter print:
  ((om isFreeObject: o)
  ifFalse: [(((om isPinned: o)
  ifTrue: [pinCount := pinCount + 1]
  ifFalse: [liveCount := liveCount + 1])
  printPaddedWith: Character space to: 3 base: 10), ' ']
  ifTrue: ['     ']).
  om printEntity: o].
  om allOldSpaceEntitiesFrom: (om objectAfter: lastObj) to: (om objectBefore: om endOfMemory) do:
  [:o|
  (om isPinned: o) ifTrue:
  [om printEntity: o]]].
 
  "First check and/or count populations..."
  liveCount := pinCount := 0.
  om allOldSpaceObjectsFrom: (om objectAfter: lastObj) do:
  [:o|
  (om isPinned: o)
  ifTrue:
  [pinCount := pinCount + 1.
  self assert: (pinned includes: o)]
  ifFalse: [liveCount := liveCount + 1]].
  self assert: totalPinned equals: pinCount.
  self assert: totalLive equals: liveCount.
 
  "Now check fills, which also tests update of first field on move..."
  liveCount := pinCount := 0.
  obj := lastObj.
  1 to: totalLive + totalPinned do:
  [:n| | expectedFill actualFill |
  [obj := om objectAfter: obj. (om isEnumerableObject: obj) or: [obj >= om endOfMemory]] whileFalse.
  expectedFill := (om isPinned: obj)
  ifTrue: [pinFill + (pinCount := pinCount + 1)]
  ifFalse: [liveFill + (liveCount := liveCount + 1)].
  1 to: (om numSlotsOf: obj) do:
  [:i| self assert: expectedFill equals: (actualFill := om fetchPointer: i - 1 ofObject: obj)]].
  "They should be the last objects..."
  self assert: (om isFreeObject: (om objectAfter: obj)).
+ self assert: om endOfMemory equals: (om addressAfter: (om objectAfter: obj)).
+ self checkForLeaksIn: om!
- self assert: om endOfMemory equals: (om addressAfter: (om objectAfter: obj))!

Item was changed:
  ----- Method: SpurPlanningCompactorTests>>testRandomAssortmentWithNewSegment:with: (in category 'private') -----
  testRandomAssortmentWithNewSegment: random with: theVM
  "Test that the compactor can handle a random assortment of live, pinned, dead, and free chunks,
  with some allocation in a new segment.  No live pinned objects are created in the new segment
  to obtain the situation that the last segment is entirely empty after compaction.  This tests shrinkage."
  | om pig lastObj obj expectedFreeSpace liveFill pinFill liveCount pinCount totalLive totalPinned pinned |
  random reset. "random is a read stream on 3000 random numbers; for repeatability"
  om := theVM objectMemory.
  om allOldSpaceObjectsDo: [:o| om setIsMarkedOf: o to: true. lastObj := o].
 
  pinFill := 16r99999900.
  liveFill := 16r55AA0000.
  liveCount := pinCount := expectedFreeSpace := 0.
  pinned := Set new.
 
  1000 timesRepeat:
  [| nSlots next newObj |
  nSlots := (random next * 300) rounded. "Make sure we stray into overflow size field territory."
+ newObj := om allocateSlotsInOldSpace: nSlots format: om firstLongFormat classIndex: ClassByteArrayCompactIndex.
- newObj := om allocateSlotsInOldSpace: nSlots format: om firstLongFormat classIndex: ClassBitmapCompactIndex.
  (next := random next) > 0.95
  ifTrue: "pinned"
  [om
  fillObj: newObj numSlots: nSlots with: pinFill + (pinCount := pinCount + 1);
  setIsPinnedOf: newObj to: true]
  ifFalse: "mobile"
  [om
  fillObj: newObj numSlots: nSlots with: liveFill + (liveCount := liveCount + 1)].
  (next := random next) >= 0.333
  ifTrue:
  [om setIsMarkedOf: newObj to: true.
  (om isPinned: newObj) ifTrue:
  [pinned add: newObj]]
  ifFalse: "dead or free"
  [expectedFreeSpace := expectedFreeSpace + (om bytesInObject: newObj).
  (om isPinned: newObj) "Must check /before/ setObjectFree: which clears all bits"
  ifTrue: [pinCount := pinCount - 1]
  ifFalse: [liveCount := liveCount - 1].
  next >= 0.2
  ifTrue: [om setIsMarkedOf: newObj to: false]
  ifFalse: [om setObjectFree: newObj]]].
 
+ pig := om allocateSlotsInOldSpace: (om numSlotsOfAny: om findLargestFreeChunk) format: om firstLongFormat classIndex: ClassByteArrayCompactIndex.
- pig := om allocateSlotsInOldSpace: (om numSlotsOfAny: om findLargestFreeChunk) format: om firstLongFormat classIndex: ClassBitmapCompactIndex.
  self deny: pig isNil.
  self assert: 0 equals: om bytesLeftInOldSpace.
  om growOldSpaceByAtLeast: om growHeadroom // 2.
  self assert: om growHeadroom equals: om bytesLeftInOldSpace + om bridgeSize.
  expectedFreeSpace := expectedFreeSpace + (om bytesInObject: pig).
 
  1000 timesRepeat:
  [| nSlots next newObj |
  nSlots := (random next * 300) rounded. "Make sure we stray into overflow size field territory."
+ newObj := om allocateSlotsInOldSpace: nSlots format: om firstLongFormat classIndex: ClassByteArrayCompactIndex.
- newObj := om allocateSlotsInOldSpace: nSlots format: om firstLongFormat classIndex: ClassBitmapCompactIndex.
  "No pinned objects in second segment."
  om fillObj: newObj numSlots: nSlots with: liveFill + (liveCount := liveCount + 1).
  (next := random next) >= 0.333
  ifTrue:
  [om setIsMarkedOf: newObj to: true.
  (om isPinned: newObj) ifTrue:
  [pinned add: newObj]]
  ifFalse: "dead or free"
  [expectedFreeSpace := expectedFreeSpace + (om bytesInObject: newObj).
  liveCount := liveCount - 1.
  next >= 0.2
  ifTrue: [om setIsMarkedOf: newObj to: false]
  ifFalse: [om setObjectFree: newObj]]].
 
  totalPinned := pinCount.
  totalLive := liveCount.
  self assert: totalPinned < (totalPinned + totalLive / 20). "should average 2.5%"
 
  "useful pre-compaction printing:"
  false ifTrue:
  [liveCount := pinCount := 0.
  om allOldSpaceEntitiesFrom: (om objectAfter: lastObj) to: (om objectBefore: om endOfMemory) do:
  [:o|
  om coInterpreter print:
  ((om isMarked: o)
  ifTrue: [(((om isPinned: o)
  ifTrue: [pinCount := pinCount + 1]
  ifFalse: [liveCount := liveCount + 1])
  printPaddedWith: Character space to: 3 base: 10), ' ']
  ifFalse: ['     ']).
  om printEntity: o].
  om allOldSpaceEntitiesFrom: (om objectAfter: lastObj) to: (om objectBefore: om endOfMemory) do:
  [:o|
  ((om isMarked: o) and: [om isPinned: o]) ifTrue:
  [om printEntity: o]]].
 
  expectedFreeSpace := expectedFreeSpace + om bytesLeftInOldSpace.
  om compactor compact.
  self assert: expectedFreeSpace equals: om bytesLeftInOldSpace.
  self assert: om allObjectsUnmarked.
 
  "useful post-compaction printing:"
  false ifTrue:
  [liveCount := pinCount := 0.
  om allOldSpaceEntitiesFrom: (om objectAfter: lastObj) to: (om objectBefore: om endOfMemory) do:
  [:o|
  om coInterpreter print:
  ((om isFreeObject: o)
  ifFalse: [(((om isPinned: o)
  ifTrue: [pinCount := pinCount + 1]
  ifFalse: [liveCount := liveCount + 1])
  printPaddedWith: Character space to: 3 base: 10), ' ']
  ifTrue: ['     ']).
  om printEntity: o].
  om allOldSpaceEntitiesFrom: (om objectAfter: lastObj) to: (om objectBefore: om endOfMemory) do:
  [:o|
  (om isPinned: o) ifTrue:
  [om printEntity: o]]].
 
  "First check and/or count populations..."
  liveCount := pinCount := 0.
  om allOldSpaceObjectsFrom: (om objectAfter: lastObj) do:
  [:o|
  (om isPinned: o)
  ifTrue:
  [pinCount := pinCount + 1.
  self assert: (pinned includes: o)]
  ifFalse: [liveCount := liveCount + 1]].
  self assert: totalPinned equals: pinCount.
  self assert: totalLive equals: liveCount.
 
  "Now check fills, which also tests update of first field on move..."
  liveCount := pinCount := 0.
  obj := lastObj.
  1 to: totalLive + totalPinned do:
  [:n| | expectedFill actualFill |
  [obj := om objectAfter: obj. (om isEnumerableObject: obj) or: [obj >= om endOfMemory]] whileFalse.
  expectedFill := (om isPinned: obj)
  ifTrue: [pinFill + (pinCount := pinCount + 1)]
  ifFalse: [liveFill + (liveCount := liveCount + 1)].
  1 to: (om numSlotsOf: obj) do:
  [:i| self assert: expectedFill equals: (actualFill := om fetchPointer: i - 1 ofObject: obj)]].
  "the Last segment should be empty"
  self assert: (om segmentManager isEmptySegment: (om segmentManager segments at: 1)).
  "They should be the last objects, followed by a free object to the end fo the first segment, a bridge, then an empty segment with a single free object in it."
  self assert: (om isFreeObject: (om objectAfter: obj)).
  self assert: (om isSegmentBridge: (om objectAfter: (om objectAfter: obj))).
  self assert: (om isFreeObject: (om objectAfter: (om objectAfter: (om objectAfter: obj)))).
  self assert: om endOfMemory equals: (om addressAfter: (om objectAfter: (om objectAfter: (om objectAfter: obj)))).
 
  "And the memory should shrink if the shrinkThreshold is low enough"
  om shrinkThreshold: om growHeadroom.
  om attemptToShrink.
+ self assert: om segmentManager numSegments = 1.
+ self checkForLeaksIn: om!
- self assert: om segmentManager numSegments = 1!

Item was added:
+ ----- Method: SpurPlanningCompactorTestsImageResource>>reset (in category 'accessing') -----
+ reset
+ "self current reset"
+ emptyVM := nil!

Item was changed:
  ----- Method: StackInterpreterPrimitives>>primitiveVMParameter (in category 'system control primitives') -----
(excessive size, no diff calculated)