Quantcast

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

Previous Topic Next Topic
 
classic Classic list List threaded Threaded
1 message Options
Reply | Threaded
Open this post in threaded view
|  
Report Content as Inappropriate

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

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

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

Name: VMMaker.oscogSPC-eem.2120
Author: eem
Time: 3 February 2017, 5:15:09.757345 pm
UUID: aacf677d-aa1a-46a0-8aeb-eba4d634c8ac
Ancestors: VMMaker.oscogSPC-eem.2119

SpurPlanningCompactor:

Add tests for multi-pass.  Get the transition from first to subsequent passes correct (scan starts at firstMobileObject; previous pass must initialize, but not free the memory at toFinger, and set firstFreeObject to this; all objects from firstFreeObject to lastMobileObject must be unmarked to avoid copying them twice).

Optimize the three mobile passes to cache startOfPreviousPin since if there are pins, most of the moves will occur under a pin.

Rename onePass to finalPass in them because this is what it really means.

Simulation:
Use simulatorClass throghout SpurMemoryManager in deriving the support classes (scavenger, compactor et al).

Move the simulation-obly behaviour down from SpurPlanningCompactor to SpurPlanningCompactorSimulator.

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

Item was added:
+ ----- Method: SpurGenerationScavenger class>>simulatorClass (in category 'simulation') -----
+ simulatorClass
+ ^SpurGenerationScavengerSimulator!

Item was changed:
  ----- Method: SpurMemoryManager>>allocateMemoryOfSize:newSpaceSize:stackSize:codeSize: (in category 'spur bootstrap') -----
  allocateMemoryOfSize: memoryBytes newSpaceSize: newSpaceBytes stackSize: stackBytes codeSize: codeBytes
  "Intialize the receiver for bootsraping an image.
  Set up a large oldSpace and an empty newSpace and set-up freeStart and scavengeThreshold
  to allocate in oldSpace.  Later on (in initializePostBootstrap) freeStart and scavengeThreshold
  will be set to sane values."
  <doNotGenerate>
  self assert: (memoryBytes \\ self allocationUnit = 0
  and: [newSpaceBytes \\ self allocationUnit = 0
  and: [codeBytes \\ self allocationUnit = 0]]).
  self allocateMemoryOfSize: memoryBytes + newSpaceBytes + codeBytes + stackBytes.
  newSpaceStart := codeBytes + stackBytes.
  endOfMemory := freeOldSpaceStart := memoryBytes + newSpaceBytes + codeBytes + stackBytes.
  "leave newSpace empty for the bootstrap"
  freeStart := newSpaceBytes + newSpaceStart.
  oldSpaceStart := newSpaceLimit := newSpaceBytes + newSpaceStart.
  scavengeThreshold := memory size * memory bytesPerElement. "i.e. /don't/ scavenge."
+ scavenger := SpurGenerationScavenger simulatorClass new.
- scavenger := SpurGenerationScavengerSimulator new.
  scavenger manager: self.
  scavenger newSpaceStart: newSpaceStart
  newSpaceBytes: newSpaceBytes
  survivorBytes: newSpaceBytes // self scavengerDenominator.
+ compactor := self class compactorClass simulatorClass new manager: self; yourself!
- compactor := self class compactorClass new manager: self; yourself.!

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 := 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.
- scavenger := SpurGenerationScavengerSimulator new manager: self; yourself.
- segmentManager := SpurSegmentManager new manager: self; yourself.
- compactor := self class compactorClass 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 changed:
  CogClass subclass: #SpurPlanningCompactor
+ instanceVariableNames: 'manager scavenger coInterpreter biasForGC firstFreeObject mobileStart firstMobileObject lastMobileObject savedFirstFieldsSpace savedFirstFieldsSpaceNotInOldSpace firstFieldOfRememberedSet anomaly objectAfterLastMobileObject'
- instanceVariableNames: 'manager scavenger coInterpreter biasForGC firstFreeObject mobileStart firstMobileObject lastMobileObject savedFirstFieldsSpace savedFirstFieldsSpaceNotInOldSpace firstFieldOfRememberedSet interestingObj anomaly objectAfterLastMobileObject relocationMap'
  classVariableNames: ''
  poolDictionaries: 'SpurMemoryManagementConstants VMBasicConstants VMBytecodeConstants VMSpurObjectRepresentationConstants'
  category: 'VMMaker-SpurMemoryManager'!
 
  !SpurPlanningCompactor commentStamp: 'eem 12/23/2016 17:50' prior: 0!
  SpurPlanningCompactor implements the classic planning compaction algorithm for Spur.  It makes at least three passes through the heap.  The first pass plans where live movable objects will go, copying their forwarding field to the next slot in savedFirstFieldsSpace, and setting their forwarding pointer to point to their eventual location.  The second pass updates all pointers in live pointer objects to point to objects' final destinations.  The third pass moves objects to their final positions, unmarking objects as it does so.  If the forwarding fields of live objects in the to-be-moved portion of the entire heap won't fit in savedFirstFieldsSpace, then additional passes are made until the entire heap has been compacted.
 
  Instance Variables
  biasForGC <Boolean>
  coInterpreter: <StackInterpreter>
  firstFieldOfRememberedSet <Oop>
  firstFreeObject <Oop>
  firstMobileObject <Oop>
  lastMobileObject <Oop>
  manager: <SpurMemoryManager>
  savedFirstFieldsSpace <SpurContiguousObjStack>
  savedFirstFieldsSpaceWasAllocated <Boolean>
  scavenger: <SpurGenerationScavenger>
 
  biasForGC
  - true if compacting for GC, in which case do only one pass, or false if compacting for snapshot, in which case do as many passes as necessary to compact the entire heap.
 
  firstFieldOfRememberedSet
  - the saved first field of the rememberedSet.  The rememberedSet must be relocated specially because it is not a pointer object.  And hence the first field needs to be extracted for proper relocation.
 
  firstFreeObject
  - the first free object in a compaction pass.
 
  firstMobileObject
  - the first mobile object in a compaction.  Unpinned objects from the firstMobileObject through to the lastMobileObject are implicitly forwarded.
 
  lastMobileObject
  - the last mobile object in a compaction.  Unpinned objects from the firstMobileObject through to the lastMobileObject are implicitly forwarded.
 
  savedFirstFieldsSpace
  - the space holding the saved first fields, each overwritten by a forwarding pointer, for the objects from firstMobileObject through to lastMobileObject.
 
  savedFirstFieldsSpaceWasAllocated
  - if true, the memory for savedFirstFieldsSpace was obtained via a call of sqAllocateMemorySegmentOfSize:Above:AllocatedSizeInto:!

Item was changed:
  ----- Method: SpurPlanningCompactor class>>declareCVarsIn: (in category 'translation') -----
  declareCVarsIn: aCCodeGenerator
  self declareCAsOop: (self instVarNames select: [:iv| iv endsWith: 'Object']) in: aCCodeGenerator.
  aCCodeGenerator
+ var: 'savedFirstFieldsSpace' type: #SpurContiguousObjStack!
- var: 'savedFirstFieldsSpace' type: #SpurContiguousObjStack;
- removeVariable: 'interestingObj';
- removeVariable: 'relocationMap'!

Item was added:
+ ----- Method: SpurPlanningCompactor class>>simulatorClass (in category 'simulation') -----
+ simulatorClass
+ ^SpurPlanningCompactorSimulator!

Item was changed:
  ----- Method: SpurPlanningCompactor>>check: (in category 'private') -----
  check: obj
+ "No-op in the real class."
+ <inline: true>!
- <inline: true>
- self cCode: '' inSmalltalk: [obj = interestingObj ifTrue: [self halt]].
- "this debugged the misuse of the largest free chunk:"
- "(manager checkForLeaks bitAnd: GCModeFull+GCModeFreeSpace) = GCModeFull ifTrue:
- [self deny: ((manager isEnumerableObject: obj) and: [(manager heapMapAtWord: obj) = 0])]"!

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 |
- | onePass firstPass |
  <inline: #never> "for profiling"
  self initializeScanCheckingForFullyCompactedHeap ifTrue:
  [^self unmarkObjectsInFullyCompactedHeap].
  self initializeCompaction.
  firstPass := true.
+ [finalPass := self planCompactSavingForwarders.
+ self assert: (self validRelocationPlanInPass: finalPass) = 0.
- [onePass := self planCompactSavingForwarders.
- self assert: (self validRelocationPlanInPass: onePass) = 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:
- onePass or: [biasForGC]] whileFalse:
  [firstPass := false.
+ self reinitializeScanFrom: firstFreeObject;
- self reinitializeScanFrom: objectAfterLastMobileObject;
  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 |
- | onePass |
  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.
+ (finalPass not and: [biasForGC]) ifTrue: "only ever one pass if biasForGC is true."
- onePass := self copyAndUnmarkMobileObjects.
- (onePass 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 |
- | toFinger top previousPin |
  <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 do:
  [:o :n|
  self check: o.
  self assert: (previousPin
  ifNil: [toFinger <= (manager startOfObject: o)]
+ ifNotNil: [(manager isMarked: previousPin) and: [toFinger <= startOfPreviousPin]]).
- 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. startOfPreviousPin := manager startOfObject: o]]
- [previousPin := o]]
  ifFalse:
  [| availableSpace bytes |
  bytes := manager bytesInObject: o.
+ [toFinger <= startOfPreviousPin
+  and: [bytes ~= (availableSpace := startOfPreviousPin - toFinger)
+  and: [bytes + (2 * manager allocationUnit) > availableSpace]]] whileTrue:
- [previousPin notNil
-  and: [availableSpace := (manager startOfObject: previousPin) - toFinger.
- 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."
  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]].
- previousPin >= o ifTrue:
- [previousPin := nil]].
  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].
- self freeFrom: toFinger upTo: (manager startOfObject: n) nextObject: (previousPin ifNil: [n]).
  ^false]]]].
  self freeFrom: toFinger upTo: manager endOfMemory nextObject: (previousPin ifNil: [objectAfterLastMobileObject]).
  self coalesceFrom: toFinger.
  ^true!

Item was changed:
  ----- Method: SpurPlanningCompactor>>forwardMobileObject:to:savedFirstFieldPtr: (in category 'private') -----
  forwardMobileObject: o to: toFinger savedFirstFieldPtr: savedFirstFieldPtr
  "Forward a mobile object to some new location, saving its first field through savedFirstFieldPtr.
  Don't use forward:to:; we dont want to alter the object in any way other than by setting the forwarding pointer."
  <inline: true>
  lastMobileObject := o.
  manager
  longAt: savedFirstFieldPtr
  put: (manager fetchPointer: 0 ofObject: o);
  storePointerUnchecked: 0
  ofObject: o
  withValue: ((manager hasOverflowHeader: o)
  ifTrue: [toFinger + manager baseHeaderSize]
  ifFalse: [toFinger]).
+ self recordMovementOf: o to: toFinger savedFirstFieldPtr: savedFirstFieldPtr!
- self cCode: '' inSmalltalk: [relocationMap ifNotNil: [:rm| rm at: o put: savedFirstFieldPtr]]!

Item was changed:
  ----- Method: SpurPlanningCompactor>>initializeScanCheckingForFullyCompactedHeap (in category 'compaction') -----
  initializeScanCheckingForFullyCompactedHeap
  "Scan for firstFreeObject and firstMobileObject from the start of memory.
  Answer if the heap is already fully compacted."
+ firstMobileObject := lastMobileObject := objectAfterLastMobileObject := nil.
  self reinitializeScanFrom: manager hiddenRootsObject.
  firstFreeObject ifNil:
  [self error: 'uncompactable heap; no unmarked objects found'].
  ^firstMobileObject >= manager endOfMemory!

Item was removed:
- ----- Method: SpurPlanningCompactor>>interestingObj: (in category 'instance initialization') -----
- interestingObj: obj
- interestingObj := obj!

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 |
- | toFinger top previousPin |
  <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]]).
- 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. startOfPreviousPin := manager startOfObject: o]]
- [previousPin := o]]
  ifFalse:
  [| availableSpace bytes |
  bytes := manager bytesInObject: o.
+ [toFinger <= startOfPreviousPin
+  and: [bytes ~= (availableSpace := startOfPreviousPin - toFinger)
+  and: [bytes + (2 * manager allocationUnit) > availableSpace]]] whileTrue:
- [previousPin notNil
-  and: [availableSpace := (manager startOfObject: previousPin) - toFinger.
- 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 oldSpaceObjectAfter: previousPin].
+ previousPin >= o
+ ifTrue: [previousPin := nil. startOfPreviousPin := 0]
+ ifFalse: [startOfPreviousPin := manager startOfObject: previousPin]].
- previousPin >= o ifTrue:
- [previousPin := nil]].
  self forwardMobileObject: o to: toFinger savedFirstFieldPtr: top.
  toFinger := toFinger + bytes.
  (top := top + manager bytesPerOop) >= savedFirstFieldsSpace limit ifTrue:
  [savedFirstFieldsSpace top: top - manager bytesPerOop.
  ^false]]]].
  savedFirstFieldsSpace top: top - manager bytesPerOop.
  ^true!

Item was added:
+ ----- Method: SpurPlanningCompactor>>recordMovementOf:to:savedFirstFieldPtr: (in category 'private') -----
+ recordMovementOf: o to: toFinger savedFirstFieldPtr: savedFirstFieldPtr
+ "No-op in the real class."
+ <inline: true>!

Item was removed:
- ----- Method: SpurPlanningCompactor>>recordMovements (in category 'compaction') -----
- recordMovements
- relocationMap := Dictionary new!

Item was changed:
  ----- Method: SpurPlanningCompactor>>reinitializeScanFrom: (in category 'compaction') -----
  reinitializeScanFrom: initialObject
  "Search for firstFreeObject and firstMobileObject from initialObject, which is the
  hiddenRootsObject on the first pass, and the objectAfterLastMobileObject on
  subsequent passes)."
  firstMobileObject := manager endOfMemory.
  firstFreeObject := self scanForFirstFreeAndFirstMobileObjectFrom: initialObject.
  firstFreeObject ifNotNil:
+ [mobileStart := manager startOfObject: firstFreeObject].
+ objectAfterLastMobileObject ifNotNil:
+ [manager allOldSpaceEntitiesFrom: firstFreeObject to: objectAfterLastMobileObject do:
+ [:o|
+ ((manager isPinned: o)
+  or: [(manager isMarked: o) not
+  or: [objectAfterLastMobileObject = o]]) ifFalse:
+ [manager setIsMarkedOf: o to: false]].
+ firstMobileObject := objectAfterLastMobileObject]!
- [mobileStart := manager startOfObject: firstFreeObject]!

Item was changed:
  ----- Method: SpurPlanningCompactor>>updatePointersInInitialImmobileObjects (in category 'compaction') -----
  updatePointersInInitialImmobileObjects
  "Sweep the initial immobile heap, updating all references to mobile objects to their eventual locations."
  manager allOldSpaceObjectsFrom: manager firstObject do:
  [:o|
  self check: o.
  (self oop: o isGreaterThanOrEqualTo: firstFreeObject) ifTrue:
  [^self].
+ "would like to assert this, but it isn't true if more than one pass: self assert: (manager isMarked: o)."
- self assert: (manager isMarked: o).
  self updatePointersIn: o]!

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)."
+ | toFinger top previousPin startOfPreviousPin |
- | toFinger top previousPin |
  <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 allOldSpaceEntitiesFrom: firstFreeObject do:
  [:o|
  self check: o.
  self assert: (previousPin
  ifNil: [toFinger <= (manager startOfObject: o)]
+ ifNotNil: [(manager isMarked: previousPin) and: [toFinger <= startOfPreviousPin]]).
- ifNotNil: [(manager isMarked: previousPin) and: [toFinger <= (manager startOfObject: previousPin)]]).
  (manager isMarked: o) ifTrue:
  [(manager isPinned: o)
  ifTrue:
  [previousPin ifNil:
+ [previousPin := o. startOfPreviousPin := manager startOfObject: o].
- [previousPin := o].
  self updatePointersIn: o]
  ifFalse:
  [| availableSpace bytes |
  bytes := manager bytesInObject: o.
+ [toFinger <= startOfPreviousPin
+  and: [bytes ~= (availableSpace := startOfPreviousPin - toFinger)
+  and: [bytes + (2 * manager allocationUnit) > availableSpace]]] whileTrue:
- [previousPin notNil
-  and: [availableSpace := (manager startOfObject: previousPin) - toFinger.
- 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 oldSpaceObjectAfter: previousPin].
+ previousPin >= o
+ ifTrue: [previousPin := nil. startOfPreviousPin := 0]
+ ifFalse: [startOfPreviousPin := manager startOfObject: previousPin]].
- previousPin >= o ifTrue:
- [previousPin := nil]].
  self updatePointersIn: o savedFirstFieldPointer: top.
  toFinger := toFinger + bytes.
  (top := top + manager bytesPerOop) >= savedFirstFieldsSpace limit ifTrue:
  [self assert: savedFirstFieldsSpace top = (top - manager bytesPerOop).
  ^false]]]].
  self assert: savedFirstFieldsSpace top = (top - manager bytesPerOop).
  ^true!

Item was added:
+ SpurPlanningCompactor subclass: #SpurPlanningCompactorSimulator
+ instanceVariableNames: 'interestingObj relocationMap sffsMode'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'VMMaker-SpurMemoryManagerSimulation'!

Item was added:
+ ----- Method: SpurPlanningCompactorSimulator>>check: (in category 'private') -----
+ check: obj
+ <inline: true>
+ sffsMode ifNotNil: [self deny: ((manager isGrey: obj) or: [(manager isImmutable: obj)  or: [manager isRemembered: obj]])].
+ obj = interestingObj ifTrue: [self halt].
+ "this debugged the misuse of the largest free chunk:"
+ "(manager checkForLeaks bitAnd: GCModeFull+GCModeFreeSpace) = GCModeFull ifTrue:
+ [self deny: ((manager isEnumerableObject: obj) and: [(manager heapMapAtWord: obj) = 0])]"!

Item was added:
+ ----- Method: SpurPlanningCompactorSimulator>>forceMultiPass (in category 'accessing') -----
+ forceMultiPass
+ sffsMode := #multiPass!

Item was added:
+ ----- Method: SpurPlanningCompactorSimulator>>interestingObj: (in category 'accessing') -----
+ interestingObj: obj
+ interestingObj := obj!

Item was added:
+ ----- Method: SpurPlanningCompactorSimulator>>recordMovementOf:to:savedFirstFieldPtr: (in category 'private') -----
+ recordMovementOf: o to: toFinger savedFirstFieldPtr: savedFirstFieldPtr
+ relocationMap ifNotNil: [:rm| rm at: o put: savedFirstFieldPtr]!

Item was added:
+ ----- Method: SpurPlanningCompactorSimulator>>recordMovements (in category 'accessing') -----
+ recordMovements
+ relocationMap := Dictionary new!

Item was added:
+ ----- Method: SpurPlanningCompactorSimulator>>selectSavedFirstFieldsSpace (in category 'space management') -----
+ selectSavedFirstFieldsSpace
+ "Override to make savedFirstFieldsSpace small enough for multi-pass compaction, if desired (for testing)."
+ super selectSavedFirstFieldsSpace.
+ "testRandomAssortment: et al create 1000 objects, aboput 5% pnned and about 33% reclaimable.  Sp 512 objects should force multi-pass."
+ sffsMode == #multiPass ifTrue:
+ [savedFirstFieldsSpace limit: savedFirstFieldsSpace start + (512 * manager bytesPerOop).
+ biasForGC := false]!

Item was added:
+ ----- Method: SpurPlanningCompactorTests>>testMultiPassRandomAssortments (in category 'tests') -----
+ testMultiPassRandomAssortments
+ "Test that the compactor can handle multi-pass compaction of some
+ number of random assortments of live, pinned, dead, and free chunks."
+ <timeout: 60>
+ | random |
+ random := Random new.
+ 10 timesRepeat:
+ [| theVM |
+ theVM := self initializedVM.
+ theVM objectMemory compactor forceMultiPass.
+ self testRandomAssortment: (random next: 3000) readStream
+ with: theVM]!

Item was added:
+ ----- Method: SpurPlanningCompactorTests>>testMultiPassRandomAssortmentsWithNewSegment (in category 'tests') -----
+ testMultiPassRandomAssortmentsWithNewSegment
+ "Test that the compactor can handle multi-pass compaction of some number of
+ random assortments of live, pinned, dead, and free chunks allocated in a new segment."
+ <timeout: 60>
+ | random |
+ random := Random new.
+ 10 timesRepeat:
+ [| theVM |
+ theVM := self initializedVM.
+ theVM objectMemory compactor forceMultiPass.
+ self testRandomAssortmentWithNewSegment: (random next: 5000) readStream
+ with: theVM]!

Item was removed:
- ----- Method: SpurPlanningCompactorTests>>testRandomAssortment: (in category 'private') -----
- testRandomAssortment: random
- "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 := self initializedVM 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: 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]].
-
- 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]].
-
- "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))!

Item was added:
+ ----- 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: 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))!

Item was removed:
- ----- Method: SpurPlanningCompactorTests>>testRandomAssortmentWithNewSegment: (in category 'private') -----
- testRandomAssortmentWithNewSegment: random
- "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 := self initializedVM 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: 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: 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: 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]].
-
- 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]].
-
- "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!

Item was added:
+ ----- 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: 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: 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: 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!

Item was changed:
  ----- Method: SpurPlanningCompactorTests>>testRandomAssortments (in category 'tests') -----
  testRandomAssortments
  "Test that the compactor can handle some number of random assortments of live, pinned, dead, and free chunks."
  <timeout: 60>
  | random |
  random := Random new.
+ 10 timesRepeat:
+ [self testRandomAssortment: (random next: 3000) readStream
+ with: self initializedVM]!
- 10 timesRepeat: [self testRandomAssortment: (random next: 3000) readStream]!

Item was changed:
  ----- Method: SpurPlanningCompactorTests>>testRandomAssortmentsWithNewSegment (in category 'tests') -----
  testRandomAssortmentsWithNewSegment
  "Test that the compactor can handle some number of random assortments of live, pinned, dead, and free chunks
  allocated in a new segment."
  <timeout: 60>
  | random |
  random := Random new.
+ 10 timesRepeat:
+ [self testRandomAssortmentWithNewSegment: (random next: 6000) readStream
+ with: self initializedVM]!
- 10 timesRepeat: [self testRandomAssortmentWithNewSegment: (random next: 6000) readStream]!

Item was added:
+ ----- Method: VMClass class>>simulatorClass (in category 'simulation') -----
+ simulatorClass
+ "For running from Smalltalk - answer a class that can be used to simulate the receiver."
+
+ ^self!

Loading...