VM Maker: VMMaker.oscog-eem.2048.mcz

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

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

Name: VMMaker.oscog-eem.2048
Author: eem
Time: 25 December 2016, 12:12:06.85768 pm
UUID: ea2e348f-29b6-493f-8435-48a54725b7f1
Ancestors: VMMaker.oscog-eem.2047

First cut of SpurPlanningCompactor, a traditional two-finger sliding compactor adapted to handle pinned objects.  It appears to work in the simulator with both CoInterpreter and StackInterpreter for a single GC, but does not handle Smalltalk garbageCollect; garbageCollect yet.


Refacor scavengeInProgress into gcPhaseInProgress so that SpurPlanningCompactor can identify sliding compaction.  Refactor shouldRemapObj:/remapObj: to double-dispatch throguh the compactor so that SpurPlanningCompactor can use its implicit forwarding test isMobile: to decide if a forwasrding pointer should be followed.

Move globalGarbageCollect's segmentManager prepareForGlobalSweep send to immediately before compactor compact.

Move nextInSortedFreeListLink:given: to SpurPigCompactor.

Extract the printing in printOopsFrom:to: into printEntity:, which is useful on its own for debugging.

Rename excludeUnmarkedNewSpaceObjs to excludeUnmarkedObjs throughout the leak checker; indeed any unmarked obj should be excluded immediately after the mark phase.

Nuke a couple of unused methods and correct some comment spellings.

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

Item was changed:
  ----- Method: CoInterpreter>>mapStackPages (in category 'object memory support') -----
  mapStackPages
  <inline: #never>
  <var: #thePage type: #'StackPage *'>
  <var: #theSP type: #'char *'>
  <var: #theFP type: #'char *'>
  <var: #frameRcvrOffset type: #'char *'>
  <var: #callerFP type: #'char *'>
  <var: #theIPPtr type: #'char *'>
  | numLivePages |
  numLivePages := 0.
  0 to: numStackPages - 1 do:
  [:i| | thePage theSP theFP frameRcvrOffset callerFP theIPPtr theIP oop |
  thePage := stackPages stackPageAt: i.
  thePage isFree ifFalse:
  [self assert: (self ifCurrentStackPageHasValidHeadPointers: thePage).
  numLivePages := numLivePages + 1.
  theSP := thePage headSP.
  theFP := thePage  headFP.
  "Skip the instruction pointer on top of stack of inactive pages."
  thePage = stackPage
  ifTrue: [theIPPtr := ((self isMachineCodeFrame: theFP)
  or: [(self iframeSavedIP: theFP) = 0])
  ifTrue: [0]
  ifFalse: [theFP + FoxIFSavedIP]]
  ifFalse:
  [theIPPtr := theSP.
  theSP := theSP + objectMemory wordSize].
  [self assert: (thePage addressIsInPage: theFP).
  self assert: (thePage addressIsInPage: theSP).
  self assert: (theIPPtr = 0 or: [thePage addressIsInPage: theIPPtr]).
  frameRcvrOffset := self frameReceiverLocation: theFP.
   [theSP <= frameRcvrOffset] whileTrue:
  [oop := stackPages longAt: theSP.
  (objectMemory shouldRemapOop: oop) ifTrue:
  [stackPages longAt: theSP put: (objectMemory remapObj: oop)].
  theSP := theSP + objectMemory wordSize].
  (self frameHasContext: theFP) ifTrue:
  [(objectMemory shouldRemapObj: (self frameContext: theFP)) ifTrue:
  [stackPages
  longAt: theFP + FoxThisContext
  put: (objectMemory remapObj: (self frameContext: theFP))].
+ "With SqueakV3 objectMemory or SpurPlanningCompactor can't assert since object body is yet to move."
+ (objectMemory hasSpurMemoryManagerAPI
+  and: [objectMemory slidingCompactionInProgress not]) ifTrue:
- "forwarding scheme in SqueakV3 obj rep makes this hard to check."
- objectMemory hasSpurMemoryManagerAPI ifTrue:
  [self assert: ((self isMarriedOrWidowedContext: (self frameContext: theFP))
  and: [(self frameOfMarriedContext: (self frameContext: theFP)) = theFP])]].
  (self isMachineCodeFrame: theFP) ifFalse:
  [(objectMemory shouldRemapObj: (self iframeMethod: theFP)) ifTrue:
  [theIPPtr ~= 0 ifTrue:
  [theIP := stackPages longAt: theIPPtr.
  theIP = cogit ceReturnToInterpreterPC
  ifTrue:
  [self assert: (self iframeSavedIP: theFP) > (self iframeMethod: theFP).
  theIPPtr := theFP + FoxIFSavedIP.
  theIP := stackPages longAt: theIPPtr]
  ifFalse:
  [self assert: theIP > (self iframeMethod: theFP)].
  theIP := theIP - (self iframeMethod: theFP)].
  stackPages
  longAt: theFP + FoxMethod
  put: (objectMemory remapObj: (self iframeMethod: theFP)).
  theIPPtr ~= 0 ifTrue:
  [stackPages longAt: theIPPtr put: theIP + (self iframeMethod: theFP)]]].
  (callerFP := self frameCallerFP: theFP) ~= 0] whileTrue:
  [theSP := (theIPPtr := theFP + FoxCallerSavedIP) + objectMemory wordSize.
  theFP := callerFP].
  theSP := theFP + FoxCallerSavedIP + objectMemory wordSize.
  [theSP <= thePage baseAddress] whileTrue:
  [oop := stackPages longAt: theSP.
  (objectMemory shouldRemapOop: oop) ifTrue:
  [stackPages longAt: theSP put: (objectMemory remapObj: oop)].
  theSP := theSP + objectMemory wordSize]]].
  stackPages recordLivePagesOnMapping: numLivePages!

Item was changed:
  ----- Method: CogVMSimulator>>printHexnp: (in category 'debug printing') -----
  printHexnp: anInteger
 
  traceOn ifTrue:
+ [transcript nextPutAll: ((anInteger ifNil: [0]) asInteger storeStringBase: 16)]!
- [transcript nextPutAll: (anInteger asInteger storeStringBase: 16)]!

Item was added:
+ ----- Method: Spur32BitCoMemoryManager>>methodHeaderFromSavedFirstField: (in category 'compaction') -----
+ methodHeaderFromSavedFirstField: field
+ (self isIntegerObject: field) ifTrue:
+ [^field].
+ self assert: ((self isNonImmediate: field) and: [field < newSpaceStart]).
+ self assert: (coInterpreter cCoerceSimple: field to: #'CogMethod *') objectHeader
+ = self nullHeaderForMachineCodeMethod.
+ ^(coInterpreter cCoerceSimple: field to: #'CogMethod *') methodHeader!

Item was removed:
- ----- Method: Spur32BitMMLECoSimulator>>runLeakCheckerFor:excludeUnmarkedNewSpaceObjs:classIndicesShouldBeValid: (in category 'debug support') -----
- runLeakCheckerFor: gcModes excludeUnmarkedNewSpaceObjs: excludeUnmarkedNewSpaceObjs classIndicesShouldBeValid: classIndicesShouldBeValid
- (coInterpreter displayView isNil
- and: [gcModes anyMask: checkForLeaks]) ifTrue:
- [coInterpreter transcript nextPutAll: 'leak-checking...'; flush].
- ^super
- runLeakCheckerFor: gcModes
- excludeUnmarkedNewSpaceObjs: excludeUnmarkedNewSpaceObjs
- classIndicesShouldBeValid: classIndicesShouldBeValid!

Item was added:
+ ----- Method: Spur32BitMMLECoSimulator>>runLeakCheckerFor:excludeUnmarkedObjs:classIndicesShouldBeValid: (in category 'debug support') -----
+ runLeakCheckerFor: gcModes excludeUnmarkedObjs: excludeUnmarkedObjs classIndicesShouldBeValid: classIndicesShouldBeValid
+ (coInterpreter displayView isNil
+ and: [gcModes anyMask: checkForLeaks]) ifTrue:
+ [coInterpreter transcript nextPutAll: 'leak-checking...'; flush].
+ ^super
+ runLeakCheckerFor: gcModes
+ excludeUnmarkedObjs: excludeUnmarkedObjs
+ classIndicesShouldBeValid: classIndicesShouldBeValid!

Item was removed:
- ----- Method: Spur32BitMMLESimulator>>runLeakCheckerFor:excludeUnmarkedNewSpaceObjs:classIndicesShouldBeValid: (in category 'debug support') -----
- runLeakCheckerFor: gcModes excludeUnmarkedNewSpaceObjs: excludeUnmarkedNewSpaceObjs classIndicesShouldBeValid: classIndicesShouldBeValid
- (coInterpreter displayView isNil
- and: [gcModes anyMask: checkForLeaks]) ifTrue:
- [coInterpreter transcript nextPutAll: 'leak-checking...'; flush].
- ^super
- runLeakCheckerFor: gcModes
- excludeUnmarkedNewSpaceObjs: excludeUnmarkedNewSpaceObjs
- classIndicesShouldBeValid: classIndicesShouldBeValid!

Item was added:
+ ----- Method: Spur32BitMMLESimulator>>runLeakCheckerFor:excludeUnmarkedObjs:classIndicesShouldBeValid: (in category 'debug support') -----
+ runLeakCheckerFor: gcModes excludeUnmarkedObjs: excludeUnmarkedObjs classIndicesShouldBeValid: classIndicesShouldBeValid
+ (coInterpreter displayView isNil
+ and: [gcModes anyMask: checkForLeaks]) ifTrue:
+ [coInterpreter transcript nextPutAll: 'leak-checking...'; flush].
+ ^super
+ runLeakCheckerFor: gcModes
+ excludeUnmarkedObjs: excludeUnmarkedObjs
+ classIndicesShouldBeValid: classIndicesShouldBeValid!

Item was added:
+ ----- Method: Spur32BitMemoryManager>>bytesInObject:given: (in category 'object enumeration') -----
+ bytesInObject: objOop given: rawNumSotsOfObjOop
+ "Answer the total number of bytes in an object including header and possible overflow size header, given the value of the object's numSlots field."
+ <returnTypeC: #usqInt>
+ <inline: true>
+ | numSlots |
+ numSlots := rawNumSotsOfObjOop = self numSlotsMask
+ ifTrue: [self rawOverflowSlotsOf: objOop]
+ ifFalse: [rawNumSotsOfObjOop = 0 ifTrue: [1] ifFalse: [rawNumSotsOfObjOop]].
+ ^numSlots + (numSlots bitAnd: 1) << self shiftForWord
+ + (rawNumSotsOfObjOop = self numSlotsMask
+ ifTrue: [self baseHeaderSize + self baseHeaderSize]
+ ifFalse: [self baseHeaderSize])!

Item was added:
+ ----- Method: Spur64BitCoMemoryManager>>methodHeaderFromSavedFirstField: (in category 'compaction') -----
+ methodHeaderFromSavedFirstField: field
+ (self isIntegerObject: field) ifTrue:
+ [^field].
+ self assert: ((self isNonImmediate: field) and: [field < newSpaceStart]).
+ self assert: (coInterpreter cCoerceSimple: field to: #'CogMethod *') objectHeader
+ = self nullHeaderForMachineCodeMethod.
+ ^(coInterpreter cCoerceSimple: field to: #'CogMethod *') methodHeader!

Item was removed:
- ----- Method: Spur64BitMMLECoSimulator>>runLeakCheckerFor:excludeUnmarkedNewSpaceObjs:classIndicesShouldBeValid: (in category 'debug support') -----
- runLeakCheckerFor: gcModes excludeUnmarkedNewSpaceObjs: excludeUnmarkedNewSpaceObjs classIndicesShouldBeValid: classIndicesShouldBeValid
- (coInterpreter displayView isNil
- and: [gcModes anyMask: checkForLeaks]) ifTrue:
- [coInterpreter transcript nextPutAll: 'leak-checking...'; flush].
- ^super
- runLeakCheckerFor: gcModes
- excludeUnmarkedNewSpaceObjs: excludeUnmarkedNewSpaceObjs
- classIndicesShouldBeValid: classIndicesShouldBeValid!

Item was added:
+ ----- Method: Spur64BitMMLECoSimulator>>runLeakCheckerFor:excludeUnmarkedObjs:classIndicesShouldBeValid: (in category 'debug support') -----
+ runLeakCheckerFor: gcModes excludeUnmarkedObjs: excludeUnmarkedObjs classIndicesShouldBeValid: classIndicesShouldBeValid
+ (coInterpreter displayView isNil
+ and: [gcModes anyMask: checkForLeaks]) ifTrue:
+ [coInterpreter transcript nextPutAll: 'leak-checking...'; flush].
+ ^super
+ runLeakCheckerFor: gcModes
+ excludeUnmarkedObjs: excludeUnmarkedObjs
+ classIndicesShouldBeValid: classIndicesShouldBeValid!

Item was removed:
- ----- Method: Spur64BitMMLESimulator>>runLeakCheckerFor:excludeUnmarkedNewSpaceObjs:classIndicesShouldBeValid: (in category 'debug support') -----
- runLeakCheckerFor: gcModes excludeUnmarkedNewSpaceObjs: excludeUnmarkedNewSpaceObjs classIndicesShouldBeValid: classIndicesShouldBeValid
- (coInterpreter displayView isNil
- and: [gcModes anyMask: checkForLeaks]) ifTrue:
- [coInterpreter transcript nextPutAll: 'leak-checking...'; flush].
- ^super
- runLeakCheckerFor: gcModes
- excludeUnmarkedNewSpaceObjs: excludeUnmarkedNewSpaceObjs
- classIndicesShouldBeValid: classIndicesShouldBeValid!

Item was added:
+ ----- Method: Spur64BitMMLESimulator>>runLeakCheckerFor:excludeUnmarkedObjs:classIndicesShouldBeValid: (in category 'debug support') -----
+ runLeakCheckerFor: gcModes excludeUnmarkedObjs: excludeUnmarkedObjs classIndicesShouldBeValid: classIndicesShouldBeValid
+ (coInterpreter displayView isNil
+ and: [gcModes anyMask: checkForLeaks]) ifTrue:
+ [coInterpreter transcript nextPutAll: 'leak-checking...'; flush].
+ ^super
+ runLeakCheckerFor: gcModes
+ excludeUnmarkedObjs: excludeUnmarkedObjs
+ classIndicesShouldBeValid: classIndicesShouldBeValid!

Item was added:
+ ----- Method: Spur64BitMemoryManager>>bytesInObject:given: (in category 'object enumeration') -----
+ bytesInObject: objOop given: rawNumSotsOfObjOop
+ "Answer the total number of bytes in an object including header and possible overflow size header, given the value of the object's numSlots field."
+ <returnTypeC: #usqInt>
+ <inline: true>
+ | numSlots |
+ numSlots := rawNumSotsOfObjOop = self numSlotsMask
+ ifTrue: [self rawOverflowSlotsOf: objOop]
+ ifFalse: [rawNumSotsOfObjOop = 0 ifTrue: [1] ifFalse: [rawNumSotsOfObjOop]].
+ ^numSlots << self shiftForWord
+ + (rawNumSotsOfObjOop = self numSlotsMask
+ ifTrue: [self baseHeaderSize + self baseHeaderSize]
+ ifFalse: [self baseHeaderSize])!

Item was added:
+ ----- Method: SpurGenerationScavenger>>relocateRememberedSet (in category 'remembered set') -----
+ relocateRememberedSet
+ "For SpurPanningCompactor"
+ rememberedSet := manager firstIndexableField: manager rememberedSetObj!

Item was changed:
  SharedPool subclass: #SpurMemoryManagementConstants
  instanceVariableNames: ''
+ classVariableNames: 'DontTenure MarkOnTenure MaxRTRefCount ScavengeInProgress SlidingCompactionInProgress TenureByAge TenureByClass TenureToShrinkRT'
- classVariableNames: 'DontTenure MarkOnTenure MaxRTRefCount TenureByAge TenureByClass TenureToShrinkRT'
  poolDictionaries: ''
  category: 'VMMaker-SpurMemoryManager'!

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

Item was changed:
  ----- Method: SpurMemoryManager class>>initialize (in category 'class initialization') -----
  initialize
  "SpurMemoryManager initialize"
  BitsPerByte := 8.
 
  "Initialize at least the become constants for the Spur bootstrap where the
  old ObjectMemory simulator is used before a Spur simulator is created.."
  self initializeSpurObjectRepresentationConstants.
 
  "An obj stack is a stack of objects stored in a hidden root slot, such as
  the markStack or the ephemeronQueue.  It is a linked list of segments,
  with the hot end at the head of the list.  It is a word object.  The stack
  pointer is in ObjStackTopx and 0 means empty.  The list goes through
  ObjStackNextx. We don't want to shrink objStacks, since they're used
  in GC and it's good to keep their memory around.  So unused pages
  created by popping emptied pages are kept on the ObjStackFreex list.
  ObjStackNextx must be the last field for swizzleObjStackAt:."
  ObjStackPageSlots := 4092. "+ double header = 16k bytes per page in 32-bits"
  ObjStackTopx := 0.
  ObjStackMyx := 1.
  ObjStackFreex := 2.
  ObjStackNextx := 3.
  ObjStackFixedSlots := 4.
  ObjStackLimit := ObjStackPageSlots - ObjStackFixedSlots.
  "The hiddenHootsObject contains the classTable pages and up to 8 additional objects.
  Currently we use four; the three objStacks, the mark stack, the weaklings and the
  mourn queue, and the rememberedSet."
  MarkStackRootIndex := self basicNew classTableRootSlots.
  WeaklingStackRootIndex := MarkStackRootIndex + 1.
  MournQueueRootIndex := MarkStackRootIndex + 2.
  RememberedSetRootIndex := MarkStackRootIndex + 3.
 
  MarkObjectsForEnumerationPrimitives := false.
 
  "The remap buffer support is for compatibility; Spur doesn't GC during allocation.
  Eventually this should die."
  RemapBufferSize := 25.
 
  "Extra roots are for plugin support."
+ ExtraRootsSize := 2048. "max. # of external roots"
+
+ "gcPhaseInProgress takes these values to identify phases as required."
+ ScavengeInProgress := 1.
+ SlidingCompactionInProgress := 2!
- ExtraRootsSize := 2048 "max. # of external roots"!

Item was changed:
  ----- Method: SpurMemoryManager>>addressCouldBeObj: (in category 'debug support') -----
  addressCouldBeObj: address
  <api>
  <inline: false>
  ^(address bitAnd: self baseHeaderSize - 1) = 0
   and: [(self isInOldSpace: address)
  or: [(self isInEden: address)
  or: [(self isInPastSpace: address)
+ or: [self scavengeInProgress and: [self isInFutureSpace: address]]]]]!
- or: [scavengeInProgress and: [self isInFutureSpace: address]]]]]!

Item was added:
+ ----- Method: SpurMemoryManager>>allOldSpaceEntitiesForCompactingFrom:do: (in category 'object enumeration') -----
+ allOldSpaceEntitiesForCompactingFrom: initialObject do: aBlock
+ <inline: true>
+ | prevObj prevPrevObj objOop nextObj |
+ self assert: (self isOldObject: initialObject).
+ prevPrevObj := prevObj := nil.
+ objOop := initialObject.
+ [self assert: objOop \\ self allocationUnit = 0.
+ self oop: objOop isLessThan: endOfMemory] whileTrue:
+ [self assert: (self long64At: objOop) ~= 0.
+ nextObj := self objectAfter: objOop limit: endOfMemory.
+ aBlock value: objOop.
+ prevPrevObj := prevObj.
+ prevObj := objOop.
+ objOop := nextObj].
+ self touch: prevPrevObj.
+ self touch: prevObj!

Item was removed:
- ----- Method: SpurMemoryManager>>anyMobileObjectsFrom:below: (in category 'compaction') -----
- anyMobileObjectsFrom: initialOop below: limit
- self allOldSpaceEntitiesFrom: initialOop
- do: [:objOop| | isMobile | "this variable is to avoid limitations in Slang's inliner"
- isMobile := self isMobileObject: objOop.
- isMobile ifTrue:
- [^true]].
- ^false!

Item was added:
+ ----- Method: SpurMemoryManager>>beginSlidingCompaction (in category 'gc - scavenge/compact') -----
+ beginSlidingCompaction
+ gcPhaseInProgress := SlidingCompactionInProgress!

Item was changed:
  ----- Method: SpurMemoryManager>>checkHeapIntegrity:classIndicesShouldBeValid: (in category 'debug support') -----
+ checkHeapIntegrity: excludeUnmarkedObjs classIndicesShouldBeValid: classIndicesShouldBeValid
- checkHeapIntegrity: excludeUnmarkedNewSpaceObjs classIndicesShouldBeValid: classIndicesShouldBeValid
  "Perform an integrity/leak check using the heapMap.  Assume clearLeakMapAndMapAccessibleObjects
  has set a bit at each (non-free) object's header.  Scan all objects in the heap checking that every
  pointer points to a header.  Scan the rememberedSet, remapBuffer and extraRootTable checking
  that every entry is a pointer to a header. Check that the number of roots is correct and that all
  rememberedSet entries have their isRemembered: flag set.  Answer if all checks pass."
  | ok numRememberedObjectsInHeap |
  <inline: false>
  ok := true.
  numRememberedObjectsInHeap := 0.
  0 to: self numFreeLists - 1 do:
  [:i|
  (freeLists at: i) ~= 0 ifTrue:
  [(heapMap heapMapAtWord: (self pointerForOop: (freeLists at: i))) ~= 0 ifTrue:
  [coInterpreter print: 'leak in free list '; printNum: i; print: ' to non-free '; printHex: (freeLists at: i); cr.
  self eek.
  ok := false]]].
 
  "Excuse the duplication but performance is at a premium and we avoid
  some tests by splitting the newSpace and oldSpace enumerations."
  self allNewSpaceEntitiesDo:
  [:obj| | fieldOop classIndex classOop |
  (self isFreeObject: obj)
  ifTrue:
  [coInterpreter print: 'young object '; printHex: obj; print: ' is free'; cr.
  self eek.
  ok := false]
  ifFalse:
+ [((self isMarked: obj) not and: [excludeUnmarkedObjs]) ifFalse:
- [((self isMarked: obj) not and: [excludeUnmarkedNewSpaceObjs]) ifFalse:
  [(self isRemembered: obj) ifTrue:
  [coInterpreter print: 'young object '; printHex: obj; print: ' is remembered'; cr.
  self eek.
  ok := false]].
  (self isForwarded: obj)
  ifTrue:
  [fieldOop := self fetchPointer: 0 ofMaybeForwardedObject: obj.
  (heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0 ifTrue:
  [coInterpreter print: 'object leak in forwarder '; printHex: obj; print: ' to unmapped '; printHex: fieldOop; cr.
  self eek.
  ok := false]]
  ifFalse:
  [classOop := self classOrNilAtIndex: (classIndex := self classIndexOf: obj).
  (classIndicesShouldBeValid
   and: [classOop = nilObj
   and: [(self isHiddenObj: obj) not]]) ifTrue:
  [coInterpreter print: 'object leak in '; printHex: obj; print: ' invalid class index '; printHex: classIndex; print: ' -> '; print: (classOop ifNil: ['nil'] ifNotNil: ['nilObj']); cr.
  self eek.
  ok := false].
  0 to: (self numPointerSlotsOf: obj) - 1 do:
  [:fi|
  fieldOop := self fetchPointer: fi ofObject: obj.
  (self isNonImmediate: fieldOop) ifTrue:
  [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0 ifTrue:
  [coInterpreter print: 'object leak in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; cr.
  self eek.
  ok := false]]]]]].
  self allOldSpaceEntitiesDo:
  [:obj| | containsYoung fieldOop classIndex classOop |
  (self isFreeObject: obj)
  ifTrue:
  [(heapMap heapMapAtWord: (self pointerForOop: obj)) ~= 0 ifTrue:
  [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' is mapped?!! '; cr.
  self eek.
  ok := false].
  fieldOop := self fetchPointer: self freeChunkNextIndex ofFreeChunk: obj.
  (fieldOop ~= 0
  and: [(heapMap heapMapAtWord: (self pointerForOop: obj)) ~= 0]) ifTrue:
  [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' @ 0 = '; printHex: fieldOop; print: ' is mapped'; cr.
  self eek.
  ok := false].
  (self isLargeFreeObject: obj) ifTrue:
  [self freeChunkParentIndex to: self freeChunkLargerIndex do:
  [:fi|
  fieldOop := self fetchPointer: fi ofFreeChunk: obj.
  (fieldOop ~= 0
  and: [(heapMap heapMapAtWord: (self pointerForOop: obj)) ~= 0]) ifTrue:
  [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; print: ' is mapped'; cr.
  self eek.
  ok := false].]]]
  ifFalse:
+ [(excludeUnmarkedObjs and: [(self isMarked: obj)not]) ifTrue: [] ifFalse: [
+ containsYoung := false.
- [containsYoung := false.
  (self isRemembered: obj) ifTrue:
  [numRememberedObjectsInHeap := numRememberedObjectsInHeap + 1.
  (scavenger isInRememberedSet: obj) ifFalse:
  [coInterpreter print: 'remembered object '; printHex: obj; print: ' is not in remembered table'; cr.
  self eek.
  ok := false]].
  (self isForwarded: obj)
  ifTrue:
  [fieldOop := self fetchPointer: 0 ofMaybeForwardedObject: obj.
  (heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0 ifTrue:
  [coInterpreter print: 'object leak in forwarder '; printHex: obj; print: ' to unmapped '; printHex: fieldOop; cr.
  self eek.
  ok := false].
  (self isReallyYoung: fieldOop) ifTrue:
  [containsYoung := true]]
  ifFalse:
  [classOop := self classOrNilAtIndex: (classIndex := self classIndexOf: obj).
  (classIndicesShouldBeValid
   and: [classOop = nilObj
   and: [classIndex > self lastClassIndexPun]]) ifTrue:
  [coInterpreter print: 'object leak in '; printHex: obj; print: ' invalid class index '; printHex: classIndex; print: ' -> '; print: (classOop ifNil: ['nil'] ifNotNil: ['nilObj']); cr.
  self eek.
  ok := false].
  0 to: (self numPointerSlotsOf: obj) - 1 do:
  [:fi|
  fieldOop := self fetchPointer: fi ofObject: obj.
  (self isNonImmediate: fieldOop) ifTrue:
+ [(self heapMapAtWord: (self pointerForOop: fieldOop)) = 0 ifTrue:
- [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0 ifTrue:
  [coInterpreter print: 'object leak in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; cr.
  self eek.
  ok := false].
  "don't be misled by CogMethods; they appear to be young, but they're not"
  (self isReallyYoung: fieldOop) ifTrue:
  [containsYoung := true]]]].
  containsYoung ifTrue:
  [(self isRemembered: obj) ifFalse:
  [coInterpreter print: 'unremembered object '; printHex: obj; print: ' contains young oop(s)'; cr.
  self eek.
+ ok := false]]]]].
- ok := false]]]].
  numRememberedObjectsInHeap ~= scavenger rememberedSetSize ifTrue:
  [coInterpreter
  print: 'root count mismatch. #heap roots ';
  printNum: numRememberedObjectsInHeap;
  print: '; #roots ';
  printNum: scavenger rememberedSetSize;
  cr.
  self eek.
  "But the system copes with overflow..."
  self flag: 'no support for remembered set overflow yet'.
  "ok := rootTableOverflowed and: [needGCFlag]"].
  scavenger rememberedSetWithIndexDo:
  [:obj :i|
  (obj bitAnd: self wordSize - 1) ~= 0
  ifTrue:
  [coInterpreter print: 'misaligned oop in remembered set @ '; printNum: i; print: ' = '; printHex: obj; cr.
  self eek.
  ok := false]
  ifFalse:
  [(heapMap heapMapAtWord: (self pointerForOop: obj)) = 0
  ifTrue:
  [coInterpreter print: 'object leak in remembered set @ '; printNum: i; print: ' = '; printHex: obj; cr.
  self eek.
  ok := false]
  ifFalse:
  [(self isYoung: obj) ifTrue:
  [coInterpreter print: 'non-root in remembered set @ '; printNum: i; print: ' = '; printHex: obj; cr.
  self eek.
  ok := false]]]].
  self objStack: mournQueue do:
  [:i :page| | obj |
  obj := self fetchPointer: i ofObject: page.
  (obj bitAnd: self wordSize - 1) ~= 0
  ifTrue:
  [coInterpreter print: 'misaligned oop in mournQueue @ '; printNum: i; print: ' in '; printHex: page; print: ' = '; printHex: obj; cr.
  self eek.
  ok := false]
  ifFalse:
+ [(excludeUnmarkedObjs and: [(self isMarked: obj) not]) ifFalse:
- [(excludeUnmarkedNewSpaceObjs and: [(self isYoung: obj) and: [(self isMarked: obj) not]]) ifFalse:
  [(heapMap heapMapAtWord: (self pointerForOop: obj)) = 0 ifTrue:
  [coInterpreter print: 'object leak in mournQueue @ '; printNum: i; print: ' in '; printHex: page; print: ' = '; printHex: obj; cr.
  self eek.
  ok := false]]]].
  1 to: remapBufferCount do:
  [:ri| | obj |
  obj := remapBuffer at: ri.
  (obj bitAnd: self wordSize - 1) ~= 0
  ifTrue:
  [coInterpreter print: 'misaligned remapRoot @ '; printNum: ri; print: ' = '; printHex: obj; cr.
  self eek.
  ok := false]
  ifFalse:
  [(heapMap heapMapAtWord: (self pointerForOop: obj)) = 0 ifTrue:
  [coInterpreter print: 'object leak in remapRoots @ '; printNum: ri; print: ' = '; printHex: obj; cr.
  self eek.
  ok := false]]].
  1 to: extraRootCount do:
  [:ri| | obj |
  obj := (extraRoots at: ri) at: 0.
  (obj bitAnd: self wordSize - 1) ~= 0
  ifTrue:
  [coInterpreter print: 'misaligned extraRoot @ '; printNum: ri; print: ' => '; printHex: obj; cr.
  self eek.
  ok := false]
  ifFalse:
  [(heapMap heapMapAtWord: (self pointerForOop: obj)) = 0 ifTrue:
  [coInterpreter print: 'object leak in extraRoots @ '; printNum: ri; print: ' => '; printHex: obj; cr.
  self eek.
  ok := false]]].
  ^ok!

Item was removed:
- ----- Method: SpurMemoryManager>>copyAndForward:withBytes:toFreeChunk: (in category 'compaction') -----
- copyAndForward: objOop withBytes: bytes toFreeChunk: freeChunk
- "Copy and forward objOop to freeChunk, the inner operation in compaction."
-
- <inline: true>
- | startOfObj freeObj |
- startOfObj := self startOfObject: objOop.
- self mem: freeChunk asVoidPointer cp: startOfObj asVoidPointer y: bytes.
- freeObj := freeChunk + (objOop - startOfObj).
- "leave it to followRememberedForwarders to remember..."
- "(self isRemembered: objOop) ifTrue:
- [scavenger remember: freeObj]."
- self forward: objOop to: freeObj!

Item was changed:
  ----- Method: SpurMemoryManager>>doScavenge: (in category 'gc - scavenging') -----
  doScavenge: tenuringCriterion
  "The inner shell for scavenge, abstrascted out so globalGarbageCollect can use it."
  <inline: false>
+ gcPhaseInProgress := ScavengeInProgress.
- scavengeInProgress := true.
  pastSpaceStart := scavenger scavenge: tenuringCriterion.
  self assert: (self
  oop: pastSpaceStart
  isGreaterThanOrEqualTo: scavenger pastSpace start
  andLessThanOrEqualTo: scavenger pastSpace limit).
  freeStart := scavenger eden start.
  self initSpaceForAllocationCheck: (self addressOf: scavenger eden) limit: scavengeThreshold.
+ gcPhaseInProgress := 0!
- scavengeInProgress := false!

Item was added:
+ ----- Method: SpurMemoryManager>>endSlidingCompaction (in category 'gc - scavenge/compact') -----
+ endSlidingCompaction
+ gcPhaseInProgress := 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.
- segmentManager prepareForGlobalSweep. "for notePinned:"
 
- compactor freeUnmarkedObjectsAndPrepareFreeSpace.
-
  "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
- excludeUnmarkedNewSpaceObjs: true
  classIndicesShouldBeValid: true.
 
+ segmentManager prepareForGlobalSweep. "for notePinned:"
  compactor compact.
  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 removed:
- ----- Method: SpurMemoryManager>>inLineRunLeakCheckerFor:excludeUnmarkedNewSpaceObjs:classIndicesShouldBeValid: (in category 'debug support') -----
- inLineRunLeakCheckerFor: gcModes excludeUnmarkedNewSpaceObjs: excludeUnmarkedNewSpaceObjs classIndicesShouldBeValid: classIndicesShouldBeValid
- <inline: true>
- (gcModes anyMask: checkForLeaks) ifTrue:
- [(gcModes anyMask: GCModeFull)
- ifTrue: [coInterpreter reverseDisplayFrom: 0 to: 7]
- ifFalse: [coInterpreter reverseDisplayFrom: 8 to: 15].
- self clearLeakMapAndMapAccessibleObjects.
- self asserta: (self checkHeapIntegrity: excludeUnmarkedNewSpaceObjs classIndicesShouldBeValid: classIndicesShouldBeValid).
- self asserta: coInterpreter checkInterpreterIntegrity.
- self asserta: coInterpreter checkStackIntegrity.
- self asserta: (coInterpreter checkCodeIntegrity: gcModes)]!

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

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.
- needGCFlag := signalLowSpace := scavengeInProgress := marking := false.
- becomeEffectsFlags := 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 := 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:
  ----- Method: SpurMemoryManager>>isInMemory: (in category 'plugin support') -----
  isInMemory: address
  "Answer if the given address is in ST object memory."
  (self isInNewSpace: address) ifTrue:
  [^(self isInEden: address)
  or: [(self isInPastSpace: address)
+ or: [self scavengeInProgress and: [self isInFutureSpace: address]]]].
- or: [scavengeInProgress and: [self isInFutureSpace: address]]]].
  ^segmentManager isInSegments: address!

Item was added:
+ ----- Method: SpurMemoryManager>>methodHeaderFromSavedFirstField: (in category 'compaction') -----
+ methodHeaderFromSavedFirstField: oop
+ self assert: (self isIntegerObject: oop).
+ ^oop!

Item was removed:
- ----- Method: SpurMemoryManager>>nextInSortedFreeListLink:given: (in category 'compaction') -----
- nextInSortedFreeListLink: freeChunk given: prevFree
- "Answer the next free free chunk using the xor trick to use only one field, see e.g.
- The Art of Computer Programming, Vol 1, D.E. Knuth, 3rd Ed, Sec 2.2.4 `Circular Lists', exercise. 18
- http://en.wikipedia.org/wiki/XOR_linked_list."
- <api>
- ^((self fetchPointer: self freeChunkNextIndex ofFreeChunk: freeChunk) bitXor: prevFree) asUnsignedInteger!

Item was changed:
  ----- Method: SpurMemoryManager>>objectAfter:limit: (in category 'object enumeration') -----
  objectAfter: objOop limit: limit
  "Object parsing.
  1. all objects have at least a word following the header, for a forwarding pointer.
+ 2. objects with an overflow size have a preceding word with a saturated numSlots.  If the word
- 2. objects with an overflow size have a preceeing word with a saturated numSlots.  If the word
    following an object doesn't have a saturated numSlots field it must be a single-header object.
    If the word following does have a saturated numSlots it must be the overflow size word."
  ^self subclassResponsibility!

Item was added:
+ ----- Method: SpurMemoryManager>>objectWithRawSlotsHasOverflowHeader: (in category 'header access') -----
+ objectWithRawSlotsHasOverflowHeader: rawNumSlots
+ ^rawNumSlots = self numSlotsMask!

Item was added:
+ ----- Method: SpurMemoryManager>>prepareObjStackForPlanningCompactor: (in category 'compaction') -----
+ prepareObjStackForPlanningCompactor: objStack
+ "SpurPlanningCompactor overwrites the first fields of all moved objects, and saves these
+ fields in a data structure from which they can only be retrieved while scanning the heap.
+ The first field of an objStack page is its stack index, and so to know how many fields in an
+ objStack page to update it is necessary to save the ObjStackTopx field somewhere temporarily.
+ We use the hash field."
+
+ | stackOrNil |
+ objStack = nilObj ifTrue:
+ [^self].
+ stackOrNil := objStack.
+ [self assert: (self numSlotsOfAny: stackOrNil) = ObjStackPageSlots.
+ self setHashBitsOf: stackOrNil to: (self fetchPointer: ObjStackTopx ofObject: stackOrNil).
+ (stackOrNil := self fetchPointer: ObjStackNextx ofObject: stackOrNil) ~= 0] whileTrue!

Item was added:
+ ----- Method: SpurMemoryManager>>prepareObjStacksForPlanningCompactor (in category 'compaction') -----
+ prepareObjStacksForPlanningCompactor
+ "SpurPlanningCompactor overwrites the first fields of all moved objects, and saves these
+ fields in a data structure from which they can only be retrieved while scanning the heap.
+ The first field of an objStack page is its stack index, and so to know how many fields in an
+ objStack page to update it is necessary to save the ObjStackTopx field somewhere temporarily.
+ We use the hash field."
+
+ self
+ prepareObjStackForPlanningCompactor: markStack;
+ prepareObjStackForPlanningCompactor: weaklingStack;
+ prepareObjStackForPlanningCompactor: mournQueue!

Item was added:
+ ----- Method: SpurMemoryManager>>printEntity: (in category 'debug printing') -----
+ printEntity: oop
+ coInterpreter
+ printHex: oop; print: '/'; printNum: oop; space;
+ print: ((self isFreeObject: oop) ifTrue: ['free'] ifFalse:
+ [(self isSegmentBridge: oop) ifTrue: ['bridge'] ifFalse:
+ [(self isForwarded: oop) ifTrue: ['forwarder'] ifFalse:
+ ['object']]]);
+ space; printHex: (self bytesInObject: oop); print: '/'; printNum: (self bytesInObject: oop); cr!

Item was changed:
  ----- Method: SpurMemoryManager>>printOopsFrom:to: (in category 'debug printing') -----
  printOopsFrom: startAddress to: endAddress
  <api>
  | oop limit |
  oop := self objectBefore: startAddress.
  limit := endAddress asUnsignedIntegerPtr min: endOfMemory.
  oop := oop
  ifNil: [startAddress]
  ifNotNil: [(self objectAfter: oop) = startAddress
  ifTrue: [startAddress]
  ifFalse: [oop]].
  [self oop: oop isLessThan: limit] whileTrue:
+ [self printEntity: oop.
+ oop := self objectAfter: oop]!
- [coInterpreter
- printHex: oop; print: '/'; printNum: oop; space;
- print: ((self isFreeObject: oop) ifTrue: ['free'] ifFalse:
- [(self isSegmentBridge: oop) ifTrue: ['bridge'] ifFalse:
- [(self isForwarded: oop) ifTrue: ['forwarder'] ifFalse:
- ['object']]]);
- cr.
- oop := self objectAfter: oop]!

Item was added:
+ ----- Method: SpurMemoryManager>>relocateObjStackForPlanningCompactor: (in category 'compaction') -----
+ relocateObjStackForPlanningCompactor: objStack
+ "Relocate all objStack pages that cmprise objStack."
+ | stackOrNil freeList next relocated result |
+ objStack = nilObj ifTrue:
+ [^objStack].
+ stackOrNil := objStack.
+ freeList := self fetchPointer: ObjStackFreex ofObject: objStack.
+ [self assert: (self numSlotsOfAny: stackOrNil) = ObjStackPageSlots.
+ "There are four fixed slots in an obj stack, and a Topx of 0 indicates empty, so
+   if there were 5 slots in an oop stack, full would be 2, and the last 0-rel index is 4.
+   Hence the last index is topx + fixed slots - 1, or topx + ObjStackNextx"
+ next := self fetchPointer: ObjStackNextx ofObject: stackOrNil.
+ relocated := compactor
+ relocateObjectsInHeapEntity: stackOrNil
+ from: ObjStackFreex
+ to: ObjStackNextx + (self rawHashBitsOf: stackOrNil).
+ stackOrNil = objStack ifTrue:
+ [result := relocated].
+ self setHashBitsOf: stackOrNil to: 0.
+ next ~= 0]
+ whileTrue:
+ [stackOrNil := next].
+ [freeList ~= 0] whileTrue:
+ [self assert: (self numSlotsOfAny: freeList) = ObjStackPageSlots.
+ next := self fetchPointer: ObjStackFreex ofObject: freeList.
+ compactor
+ relocateObjectsInHeapEntity: freeList
+ from: ObjStackFreex
+ to: ObjStackFreex.
+ freeList := next].
+ ^relocated!

Item was added:
+ ----- Method: SpurMemoryManager>>relocateObjStacksForPlanningCompactor (in category 'compaction') -----
+ relocateObjStacksForPlanningCompactor
+ "Relocate all non-empty objStack pages, following the objStacks from the roots."
+
+ markStack := self relocateObjStackForPlanningCompactor: markStack.
+ weaklingStack := self relocateObjStackForPlanningCompactor: weaklingStack.
+ mournQueue := self relocateObjStackForPlanningCompactor: mournQueue!

Item was changed:
+ ----- Method: SpurMemoryManager>>remapObj: (in category 'gc - scavenge/compact') -----
- ----- Method: SpurMemoryManager>>remapObj: (in category 'gc - scavenging') -----
  remapObj: objOop
  "Scavenge or simply follow objOop.  Answer the new location of objOop.
  The send should have been guarded by a send of shouldRemapOop:.
+ The method is called remapObj: for compatibility with ObjectMemory.
+ Defer to the compactor to choose the actual method, there being a
+ difference between the vanilla method and that used with a sliding
+ compactor where objects are not marked as forwarded."
+ <doNotGenerate>
+ ^compactor remapObj: objOop!
- The method is called remapObj: for compatibility with ObjectMemory."
- <api>
- <inline: false>
- | resolvedObj |
- self assert: (self shouldRemapOop: objOop).
- (self isForwarded: objOop)
- ifTrue:
- [resolvedObj := self followForwarded: objOop]
- ifFalse:
- [self deny: (self isInFutureSpace: objOop).
- resolvedObj := objOop].
- (scavengeInProgress
- and: [(self isReallyYoung: resolvedObj) "don't scavenge immediate, old, or CogMethod objects."
- and: [(self isInFutureSpace: resolvedObj) not]]) ifTrue:
- [^scavenger copyAndForward: resolvedObj].
- ^resolvedObj!

Item was changed:
  ----- Method: SpurMemoryManager>>runLeakCheckerFor: (in category 'debug support') -----
  runLeakCheckerFor: gcModes
  <inline: false>
  ^self
  inLineRunLeakCheckerFor: gcModes
+ excludeUnmarkedObjs: false
- excludeUnmarkedNewSpaceObjs: false
  classIndicesShouldBeValid: true!

Item was removed:
- ----- Method: SpurMemoryManager>>runLeakCheckerFor:excludeUnmarkedNewSpaceObjs:classIndicesShouldBeValid: (in category 'debug support') -----
- runLeakCheckerFor: gcModes excludeUnmarkedNewSpaceObjs: excludeUnmarkedNewSpaceObjs classIndicesShouldBeValid: classIndicesShouldBeValid
- <inline: false>
- self inLineRunLeakCheckerFor: gcModes
- excludeUnmarkedNewSpaceObjs: excludeUnmarkedNewSpaceObjs
- classIndicesShouldBeValid: classIndicesShouldBeValid!

Item was added:
+ ----- Method: SpurMemoryManager>>runLeakCheckerFor:excludeUnmarkedObjs:classIndicesShouldBeValid: (in category 'debug support') -----
+ runLeakCheckerFor: gcModes excludeUnmarkedObjs: excludeUnmarkedObjs classIndicesShouldBeValid: classIndicesShouldBeValid
+ <inline: false>
+ self inLineRunLeakCheckerFor: gcModes
+ excludeUnmarkedObjs: excludeUnmarkedObjs
+ classIndicesShouldBeValid: classIndicesShouldBeValid!

Item was added:
+ ----- Method: SpurMemoryManager>>scavengeInProgress (in category 'testing') -----
+ scavengeInProgress
+ ^gcPhaseInProgress == ScavengeInProgress!

Item was changed:
  ----- Method: SpurMemoryManager>>shortPrintObjectsFrom:to: (in category 'debug printing') -----
  shortPrintObjectsFrom: startAddress to: endAddress
  <api>
  | oop |
  oop := self objectBefore: startAddress.
  oop := oop
  ifNil: [startAddress]
  ifNotNil: [(self objectAfter: oop) = startAddress
  ifTrue: [startAddress]
  ifFalse: [oop]].
  [self oop: oop isLessThan: endAddress] whileTrue:
  [(self isFreeObject: oop) ifFalse:
+ [coInterpreter shortPrintOop: oop].
- [self shortPrintOop: oop].
  oop := self objectAfter: oop]!

Item was changed:
+ ----- Method: SpurMemoryManager>>shouldRemapObj: (in category 'gc - scavenge/compact') -----
- ----- Method: SpurMemoryManager>>shouldRemapObj: (in category 'gc - scavenging') -----
  shouldRemapObj: objOop
- <api>
  "Answer if the obj should be scavenged (or simply followed). The method is called
+ shouldRemapObj: for compatibility with ObjectMemory.  Defer to the compactor
+ to choose the actual test, there being a difference between the vanilla test and
+ that used with a sliding compactor where objects are not marked as forwarded."
+ <doNotGenerate>
+ ^compactor shouldRemapObj: objOop!
- shouldRemapObj: for compatibility with ObjectMemory.  We test for being already
- scavenged because mapStackPages via mapInterpreterOops may be applied twice
- in the context of a global GC where a scavenge, followed by a scan-mark-free, and
- final compaction passes may result in scvenged fields being visited twice."
- ^(self isForwarded: objOop)
-  or: [(self isReallyYoungObject: objOop)
- and: [(self isInFutureSpace: objOop) not]]!

Item was changed:
+ ----- Method: SpurMemoryManager>>shouldRemapOop: (in category 'gc - scavenge/compact') -----
- ----- Method: SpurMemoryManager>>shouldRemapOop: (in category 'gc - scavenging') -----
  shouldRemapOop: oop
  <api>
  "Answer if the oop should be scavenged.. The method is called
  shouldRemapOop: for compatibility with ObjectMemory."
  <inline: true>
  ^(self isNonImmediate: oop)
    and: [self shouldRemapObj: oop]!

Item was added:
+ ----- Method: SpurMemoryManager>>slidingCompactionInProgress (in category 'testing') -----
+ slidingCompactionInProgress
+ ^gcPhaseInProgress == SlidingCompactionInProgress!

Item was added:
+ ----- Method: SpurMemoryManager>>slidingCompactionRemapObj: (in category 'gc - scavenge/compact') -----
+ slidingCompactionRemapObj: objOop
+ "Scavenge or simply follow objOop.  Answer the new location of objOop.
+ The send should have been guarded by a send of shouldRemapOop:.
+ The method is called remapObj: for compatibility with ObjectMemory."
+ <inline: true>
+ | resolvedObj |
+ self assert: (self shouldRemapOop: objOop).
+ (self isForwarded: objOop)
+ ifTrue:
+ [resolvedObj := self followForwarded: objOop]
+ ifFalse:
+ [self deny: (self isInFutureSpace: objOop).
+ resolvedObj := objOop].
+ gcPhaseInProgress > 0 ifTrue:
+ [self scavengeInProgress
+ ifTrue:
+ [((self isReallyYoung: resolvedObj) "don't scavenge immediate, old, or CogMethod objects."
+  and: [(self isInFutureSpace: resolvedObj) not]) ifTrue:
+ [^scavenger copyAndForward: resolvedObj]]
+ ifFalse:
+ [self assert: self slidingCompactionInProgress.
+ (compactor isMobile: objOop) ifTrue:
+ [^self fetchPointer: 0 ofObject: objOop]]].
+ ^resolvedObj!

Item was added:
+ ----- Method: SpurMemoryManager>>slidingCompactionShouldRemapObj: (in category 'gc - scavenge/compact') -----
+ slidingCompactionShouldRemapObj: objOop
+ <inline: #always>
+ "Answer if the obj should be scavenged, or simply followed. Sent via the compactor
+ from shouldRemapObj:.  We test for being already scavenged because mapStackPages
+ via mapInterpreterOops may be applied twice in the context of a global GC where a
+ scavenge, followed by a scan-mark-free, and final compaction passes may result in
+ scavenged fields being visited twice."
+ ^(self isForwarded: objOop)
+   or: [gcPhaseInProgress > 0 "Hence either scavengeInProgress or slidingCompactionInProgress"
+   and: [self scavengeInProgress
+ ifTrue: [(self isReallyYoungObject: objOop)
+ and: [(self isInFutureSpace: objOop) not]]
+ ifFalse: [compactor isMobile: objOop]]]!

Item was changed:
  ----- Method: SpurMemoryManager>>sqDeallocateMemorySegmentAt:OfSize: (in category 'simulation only') -----
  sqDeallocateMemorySegmentAt: startAddress OfSize: ammount
+ "This is a nop in the simulator, except for SpurPlanningCompactor which may
+ release at the end of memory, allowing the simulator to shrink memory."
+ <doNotGenerate>
+ startAddress >= endOfMemory ifTrue:
+ [self halt]!
- "This is a nop in the simulator."
- <doNotGenerate>!

Item was added:
+ ----- Method: SpurMemoryManager>>startOfObject:given: (in category 'object enumeration') -----
+ startOfObject: objOop given: rawNumSlots
+ "Answer the start of objOop, which is either the address of the overflow
+ size word, or objOop itself, depending on the size of the object.  This may
+ be applied to any kind of object, normal, forwarders or free chunks."
+ ^(self objectWithRawSlotsHasOverflowHeader: rawNumSlots)
+ ifTrue: [objOop - self baseHeaderSize]
+ ifFalse: [objOop]!

Item was added:
+ ----- Method: SpurMemoryManager>>unmarkSurvivingObjectsForCompact (in category 'compaction') -----
+ unmarkSurvivingObjectsForCompact
+ self allPastSpaceObjectsDo:
+ [:objOop|
+ (self isMarked: objOop) ifTrue:
+ [self setIsMarkedOf: objOop to: false]]!

Item was added:
+ ----- Method: SpurMemoryManager>>vanillaRemapObj: (in category 'gc - scavenge/compact') -----
+ vanillaRemapObj: objOop
+ "Scavenge or simply follow objOop.  Answer the new location of objOop.
+ The send should have been guarded by a send of shouldRemapOop:.
+ The method is called remapObj: for compatibility with ObjectMemory."
+ <inline: true>
+ | resolvedObj |
+ self assert: (self shouldRemapOop: objOop).
+ (self isForwarded: objOop)
+ ifTrue:
+ [resolvedObj := self followForwarded: objOop]
+ ifFalse:
+ [self deny: (self isInFutureSpace: objOop).
+ resolvedObj := objOop].
+ (self scavengeInProgress
+ and: [(self isReallyYoung: resolvedObj) "don't scavenge immediate, old, or CogMethod objects."
+ and: [(self isInFutureSpace: resolvedObj) not]]) ifTrue:
+ [^scavenger copyAndForward: resolvedObj].
+ ^resolvedObj!

Item was added:
+ ----- Method: SpurMemoryManager>>vanillaShouldRemapObj: (in category 'gc - scavenge/compact') -----
+ vanillaShouldRemapObj: objOop
+ <inline: #always>
+ "Answer if the obj should be scavenged, or simply followed. Sent via the compactor
+ from shouldRemapObj:.  We test for being already scavenged because mapStackPages
+ via mapInterpreterOops may be applied twice in the context of a global GC where a
+ scavenge, followed by a scan-mark-free, and final compaction passes may result in
+ scavenged fields being visited twice."
+ ^(self isForwarded: objOop)
+  or: [(self isReallyYoungObject: objOop)
+ and: [(self isInFutureSpace: objOop) not]]!

Item was changed:
  ----- Method: SpurPigCompactor>>checkTraversableSortedFreeList (in category 'compaction - asserts') -----
  checkTraversableSortedFreeList
  | prevFree prevPrevFree freeChunk |
  <api>
  <inline: false>
  prevFree := prevPrevFree := 0.
  firstFreeChunk = 0 ifTrue:
  [^lastFreeChunk = 0].
  freeChunk := firstFreeChunk.
  manager allOldSpaceEntitiesDo:
  [:o| | objOop next limit |
  (manager isFreeObject: o) ifTrue:
  [self assert: o = freeChunk.
+ next := self nextInSortedFreeListLink: freeChunk given: prevFree.
- next := manager nextInSortedFreeListLink: freeChunk given: prevFree.
  limit := next = 0 ifTrue: [manager endOfMemory] ifFalse: [next].
  "coInterpreter transcript cr; print: freeChunk; tab; print: o; tab; print: prevFree; nextPutAll: '<->'; print: next; flush."
  objOop := freeChunk.
  [self oop: (objOop := manager objectAfter: objOop) isLessThan: limit] whileTrue:
  [self assert: (manager isFreeObject: objOop) not].
  prevPrevFree := prevFree.
  prevFree := freeChunk.
  freeChunk := next]].
  self assert: prevFree = lastFreeChunk.
+ self assert: (self nextInSortedFreeListLink: lastFreeChunk given: 0) = prevPrevFree.
- self assert: (manager nextInSortedFreeListLink: lastFreeChunk given: 0) = prevPrevFree.
  self assert: freeChunk = 0.
  ^true!

Item was changed:
  ----- Method: SpurPigCompactor>>compact (in category 'compaction - api') -----
  compact
  "We'd like to use exact fit followed by best or first fit, but it doesn't work
  well enough in practice.  So use pig compact.  Fill large free objects starting
  from low memory with objects taken from the end of memory."
  <inline: #never> "for profiling"
+ self freeUnmarkedObjectsAndSortAndCoalesceFreeSpaceForPigCompact.
  manager statCompactPassCount: manager statCompactPassCount + 1.
  self assert: (firstFreeChunk = 0 or: [manager isFreeObject: firstFreeChunk]).
  1 to: numCompactionPasses do:
  [:i|
  self pigCompact.
  self eliminateAndFreeForwardersForPigCompact].
 
  "The free lists are zeroed in freeUnmarkedObjectsAndSortAndCoalesceFreeSpaceForPigCompact.
  They should still be zero here"
  self assert: manager freeListHeadsEmpty.
  self rebuildFreeListsForPigCompact!

Item was changed:
  ----- Method: SpurPigCompactor>>eliminateAndFreeForwardersForPigCompact (in category 'compaction') -----
  eliminateAndFreeForwardersForPigCompact
  "As the final phase of global garbage collect, sweep the heap to follow
  forwarders, then free forwarders, coalescing with free space as we go."
  <inline: false>
  | lowestForwarder |
  <var: #lowestForwarder type: #usqInt>
  self assert: (manager isForwarded: manager nilObject) not.
  self assert: (manager isForwarded: manager falseObject) not.
  self assert: (manager isForwarded: manager trueObject) not.
  self assert: (manager isForwarded: manager freeListsObj) not.
  self assert: (manager isForwarded: manager hiddenRootsObject) not.
  self assert: (manager isForwarded: manager classTableFirstPage) not.
  manager followSpecialObjectsOop.
  manager followForwardedObjStacks.
  coInterpreter mapInterpreterOops.
  scavenger followRememberedForwardersAndForgetFreeObjectsForPigCompact.
+ manager unmarkSurvivingObjectsForCompact.
- self unmarkSurvivingObjectsForPigCompact.
  lowestForwarder := self sweepToFollowForwardersForPigCompact.
  self sweepToCoallesceFreeSpaceForPigCompactFrom: lowestForwarder.
  self assert: manager numberOfForwarders = 0!

Item was removed:
- ----- Method: SpurPigCompactor>>freeUnmarkedObjectsAndPrepareFreeSpace (in category 'compaction - api') -----
- freeUnmarkedObjectsAndPrepareFreeSpace
- <inline: true>
- self freeUnmarkedObjectsAndSortAndCoalesceFreeSpaceForPigCompact!

Item was changed:
  ----- Method: SpurPigCompactor>>moveARunOfObjectsStartingAt:upTo: (in category 'compaction') -----
  moveARunOfObjectsStartingAt: startAddress upTo: limit
  "Move the sequence of movable objects starting at startAddress.  Answer the start
  of the next sequence of movable objects after a possible run of unmovable objects,
  or the limit, if there are no more movable objects, or 0 if no more compaction can be
  done. Compaction is done when the search through the freeList has reached the
  address from which objects are being moved from.
 
  There are two broad cases to be dealt with here.  One is a run of smallish objects
  that can easily be moved into free chunks.  The other is a large object that is unlikely
  to fit in the typical free chunk. This second pig needs careful handling; it needs to be
  moved to the lowest place it will fit and not cause the scan to skip lots of smaller
  free chunks looking in vain for somewhere to put it."
  <var: #startAddress type: #usqInt>
  <var: #limit type: #usqInt>
  <inline: false>
  | here hereObj hereObjHeader prevPrevFreeChunk prevFreeChunk thisFreeChunk maxFreeChunk |
  <var: #here type: #usqInt>
  <var: #there type: #usqInt>
  <var: #nextFree type: #usqInt>
  <var: #endOfFree type: #usqInt>
  <var: #destination type: #usqInt>
  <var: #maxFreeChunk type: #usqInt>
  here := startAddress.
  hereObj := manager objectStartingAt: startAddress.
  hereObjHeader := manager atLeastClassIndexHalfHeader: hereObj.
  prevPrevFreeChunk := prevFreeChunk := 0.
  thisFreeChunk := maxFreeChunk := firstFreeChunk.
  [thisFreeChunk ~= 0] whileTrue:
  [| freeBytes endOfFree nextFree destination there moved |
 
  "skip any initial immobile objects"
  [(manager isMobileObjectHeader: hereObjHeader)] whileFalse:
  [here := manager addressAfter: hereObj.
  here >= limit ifTrue:
  [^maxFreeChunk >= startAddress ifTrue: [0] ifFalse: [limit]].
  hereObj := manager objectStartingAt: here.
  hereObjHeader := manager atLeastClassIndexHalfHeader: hereObj].
 
  "grab a free chunk, and the following one, because we want to overwrite this one."
  self assert: ((manager isFreeObject: firstFreeChunk) and: [manager isFreeObject: thisFreeChunk]).
  freeBytes := manager bytesInObject: thisFreeChunk.
+ nextFree := self nextInSortedFreeListLink: thisFreeChunk given: prevFreeChunk.
- nextFree := manager nextInSortedFreeListLink: thisFreeChunk given: prevFreeChunk.
  destination := manager startOfObject: thisFreeChunk.
  endOfFree := destination + freeBytes.
  moved := false.
  maxFreeChunk := maxFreeChunk max: nextFree.
  self assert: (nextFree = 0 or: [manager isFreeObject: nextFree]).
 
  "move as many objects as will fit in freeBytes..."
  [there := manager addressAfter: hereObj.
   "N.B. *must* add allocationUnit, not subtract, to avoid unsigned arithmetic issues when freeBytes = 0"
   (manager isMobileObjectHeader: hereObjHeader)
   and: [freeBytes > (there - here + manager allocationUnit)
     or: [freeBytes = (there - here)]]] whileTrue:
  [moved := true.
  manager mem: destination asVoidPointer cp: here asVoidPointer y: there - here.
  manager forwardUnchecked: hereObj to: destination + (hereObj - here).
  destination := destination + (there - here).
  freeBytes := freeBytes - (there - here).
  hereObj := manager objectStartingAt: there.
  here := there.
  hereObjHeader := manager atLeastClassIndexHalfHeader: hereObj].
 
  moved
  ifTrue: "we did overwrite it; we need to repair the free list"
  [| nextNextFree |
  nextFree ~= 0 ifTrue:
+ [nextNextFree  := self nextInSortedFreeListLink: nextFree given: thisFreeChunk.
- [nextNextFree  := manager nextInSortedFreeListLink: nextFree given: thisFreeChunk.
  self assert: (manager isFreeObject: nextFree)].
  (destination > thisFreeChunk "if false couldn't move anything"
   and: [destination < endOfFree]) "if false, filled entire free chunk"
  ifTrue:
  [thisFreeChunk := manager initFreeChunkWithBytes: endOfFree - destination at: destination.
  self inSortedFreeListLink: prevFreeChunk to: thisFreeChunk given: prevPrevFreeChunk.
  self inSortedFreeListLink: thisFreeChunk to: nextFree given: prevFreeChunk.
  nextFree ~= 0 ifTrue:
  [self inSortedFreeListLink: nextFree to: nextNextFree given: thisFreeChunk].
  prevPrevFreeChunk := prevFreeChunk.
  prevFreeChunk := thisFreeChunk.
  thisFreeChunk := nextFree]
  ifFalse:
  [self inSortedFreeListLink: prevFreeChunk to: nextFree given: prevPrevFreeChunk.
  nextFree ~= 0 ifTrue:
  [self inSortedFreeListLink: nextFree to: nextNextFree given: prevFreeChunk].
  thisFreeChunk := nextFree]]
  ifFalse: "out of space (or immobile object); move on up the free list..."
  [prevPrevFreeChunk := prevFreeChunk.
  prevFreeChunk := thisFreeChunk.
  thisFreeChunk := nextFree].
 
  (manager isMobileObjectHeader: hereObjHeader) ifFalse:
  [^maxFreeChunk >= startAddress ifTrue: [0] ifFalse: [there]].
 
  "Was the loop stopped by a pig? If so, try and find space for it"
  there - here >= (manager averageObjectSizeInBytes * 8) ifTrue: "256b in 32 bit, 512b in 64 bit"
  [| usedChunk |
  usedChunk := self tryToMovePig: hereObj at: here end: there.
  "if it couldn't be moved we need to advance, so always
  set here to there whether the pig was moved or not."
  hereObj := manager objectStartingAt: there.
  here := there.
  hereObjHeader := manager atLeastClassIndexHalfHeader: hereObj.
  "In general it's a bad idea to reset the enumeration; it leads to N^2 behaviour
   when encountering pigs.  But if the move affected the enumeration this is
   simpler than resetting the list pointers."
  (usedChunk = prevPrevFreeChunk
   or: [usedChunk = prevFreeChunk
   or: [usedChunk = thisFreeChunk]]) ifTrue:
  ["reset the scan for free space back to the start of the list"
  prevPrevFreeChunk := prevFreeChunk := 0.
  thisFreeChunk := firstFreeChunk]].
 
  ((here > startAddress and: [there >= limit])
  or: [maxFreeChunk >= startAddress]) ifTrue:
  [^maxFreeChunk >= startAddress ifTrue: [0] ifFalse: [there]]].
  ^here!

Item was added:
+ ----- Method: SpurPigCompactor>>nextInSortedFreeListLink:given: (in category 'compaction') -----
+ nextInSortedFreeListLink: freeChunk given: prevFree
+ "Answer the next free free chunk using the xor trick to use only one field, see e.g.
+ The Art of Computer Programming, Vol 1, D.E. Knuth, 3rd Ed, Sec 2.2.4 `Circular Lists', exercise. 18
+ http://en.wikipedia.org/wiki/XOR_linked_list."
+ <inline: true>
+ ^((manager fetchPointer: manager freeChunkNextIndex ofFreeChunk: freeChunk) bitXor: prevFree) asUnsignedInteger!

Item was changed:
  ----- Method: SpurPigCompactor>>pigCompact (in category 'compaction') -----
  pigCompact
  "Traverse the sorted free list, moving objects from the high-end of
  memory to the free objects in the low end of memory.  Return when
+ the address at which objects are being copied to meets the address
- the address at which objects are being copiecd to meets the address
  from which objects are being copied from."
  self cCode: '' inSmalltalk: [coInterpreter transcript nextPutAll: 'pig compacting...'; flush].
  self sortedFreeListPairwiseReverseDo:
  [:low :high| | scanAddress |
  self cCode: '' inSmalltalk: [coInterpreter transcript nextPut: $.; flush].
  scanAddress := manager addressAfter: low.
  [self oop: scanAddress isLessThan: high] whileTrue:
  [scanAddress := self moveARunOfObjectsStartingAt: scanAddress upTo: high.
  scanAddress = 0 ifTrue:
  [^self]]].
  self assert: self checkTraversableSortedFreeList!

Item was changed:
  ----- Method: SpurPigCompactor>>printSortedFreeList (in category 'debug printing') -----
  printSortedFreeList
  <api>
  | freeChunk prevFree nextFree |
  (firstFreeChunk > 0 and: [lastFreeChunk > firstFreeChunk]) ifFalse:
  [coInterpreter print: 'sorted free list empty or corrupt'; cr.
  ^self].
  freeChunk := firstFreeChunk.
  prevFree := 0.
  [((manager addressCouldBeObj: freeChunk)
  and: [manager isFreeObject: freeChunk]) ifFalse:
  [coInterpreter printHexnp: freeChunk; print: ' is not a free chunk!!' ; cr.
  ^self].
  manager printFreeChunk: freeChunk printAsTreeNode: false.
  freeChunk ~= lastFreeChunk] whileTrue:
+ [nextFree := self nextInSortedFreeListLink: freeChunk given: prevFree.
- [nextFree := manager nextInSortedFreeListLink: freeChunk given: prevFree.
  prevFree := freeChunk.
  freeChunk := nextFree]!

Item was added:
+ ----- Method: SpurPigCompactor>>remapObj: (in category 'gc - scavenge/compact') -----
+ remapObj: objOop
+ "Scavenge or simply follow objOop.  Answer the new location of objOop.
+ The send should have been guarded by a send of shouldRemapOop:.
+ The method is called remapObj: for compatibility with ObjectMemory."
+ <api>
+ <inline: false>
+ ^manager vanillaRemapObj: objOop!

Item was added:
+ ----- Method: SpurPigCompactor>>shouldRemapObj: (in category 'gc - scavenge/compact') -----
+ shouldRemapObj: objOop
+ <api>
+ "Answer if the obj should be scavenged (or simply followed). The method is called
+ shouldRemapObj: for compatibility with ObjectMemory.  Defer to the compactor
+ to choose the actual test, there being a difference between the vanilla test and
+ that used with a sliding compactor where objects are not marked as forwarded."
+ ^manager vanillaShouldRemapObj: objOop!

Item was changed:
  ----- Method: SpurPigCompactor>>sortedFreeListDo: (in category 'compaction') -----
  sortedFreeListDo: aBlock
  "Evaluate aBlock with ascending entries in the free list"
  | free nextFree prevFree prevPrevFree |
  <var: #free type: #usqInt>
  <var: #nextFree type: #usqInt>
  <var: #prevFree type: #usqInt>
  <var: #prevPrevFree type: #usqInt>
  <inline: true>
  free := firstFreeChunk.
  prevPrevFree := prevFree := 0.
  [free ~= 0] whileTrue:
+ [nextFree := self nextInSortedFreeListLink: free given: prevFree.
- [nextFree := manager nextInSortedFreeListLink: free given: prevFree.
  self assert: (manager isFreeObject: free).
  self assert: (nextFree = 0 or: [nextFree > free and: [manager isFreeObject: nextFree]]).
  self assert: (prevFree = 0 or: [prevFree < free]).
  aBlock value: free.
  prevPrevFree := prevFree.
  prevFree := free.
  free := nextFree]!

Item was changed:
  ----- Method: SpurPigCompactor>>sortedFreeListPairwiseReverseDo: (in category 'compaction') -----
  sortedFreeListPairwiseReverseDo: aBinaryBlock
  "Evaluate aBinaryBlock with adjacent entries in the free list, from
  high address to low address.  The second argument is in fact the
  start of the next free chunk, not the free chunk itself.  Use
  endOfMemory - bridgeSize as the second argument in the first evaluation."
  | free prevFree prevPrevFree |
  <var: #free type: #usqInt>
  <var: #prevFree type: #usqInt>
  <var: #prevPrevFree type: #usqInt>
  <inline: true>
  free := lastFreeChunk.
  prevPrevFree := prevFree := 0.
  [free ~= 0] whileTrue:
  [aBinaryBlock value: free value: (prevFree = 0
  ifTrue: [manager endOfMemory - manager bridgeSize]
  ifFalse: [manager startOfObject: prevFree]).
  "post evaluation of aBinaryBlock the value of free may be invalid
   because moveARunOfObjectsStartingAt:upTo: may have filled it.
   So reconstruct the position in the enumeration."
  prevFree = 0
  ifTrue:
  [self assert: free = lastFreeChunk.
  prevFree := lastFreeChunk.
+ free := self nextInSortedFreeListLink: lastFreeChunk given: 0]
- free := manager nextInSortedFreeListLink: lastFreeChunk given: 0]
  ifFalse:
  [self assert: (manager isFreeObject: prevFree).
  prevPrevFree = 0
  ifTrue:
  [prevPrevFree := lastFreeChunk.
+ prevFree := self nextInSortedFreeListLink: lastFreeChunk given: 0]
- prevFree := manager nextInSortedFreeListLink: lastFreeChunk given: 0]
  ifFalse:
  [self assert: (manager isFreeObject: prevPrevFree).
+ free := self nextInSortedFreeListLink: prevFree given: prevPrevFree.
- free := manager nextInSortedFreeListLink: prevFree given: prevPrevFree.
  prevPrevFree := prevFree.
  prevFree := free].
+ free := self nextInSortedFreeListLink: prevFree given: prevPrevFree]]!
- free := manager nextInSortedFreeListLink: prevFree given: prevPrevFree]]!

Item was changed:
  ----- Method: SpurPigCompactor>>tryToMovePig:at:end: (in category 'compaction') -----
  tryToMovePig: pigObj at: pigStart end: pigEnd
  "Try to move a pig (a largish object) to a free chunk in low memory.
  Answer the freeChunk that was used to house the moved pig, or
  0 if no free chunk could be found."
  | freeChunk prevFree prevPrevFree pigBytes nextNext |
  prevPrevFree := prevFree := 0.
  freeChunk := firstFreeChunk.
  pigBytes := pigEnd - pigStart.
  [freeChunk ~= 0 and: [freeChunk < pigObj]] whileTrue:
  [| next dest chunkBytes newChunk |
+ next := self nextInSortedFreeListLink: freeChunk given: prevFree.
- next := manager nextInSortedFreeListLink: freeChunk given: prevFree.
  dest := manager startOfObject: freeChunk.
  chunkBytes := (manager addressAfter: freeChunk) - dest.
  "N.B. *must* add allocationUnit, not subtract, to avoid unsigned arithmetic issues when chunkBytes = 0"
  (chunkBytes = pigBytes
   or: [chunkBytes > (pigBytes + manager allocationUnit)]) ifTrue:
  [manager mem: dest asVoidPointer cp: pigStart asVoidPointer y: pigBytes.
  manager forwardUnchecked: pigObj to: dest + (pigObj - pigStart).
  next ~= 0 ifTrue:
+ [nextNext  := self nextInSortedFreeListLink: next given: freeChunk].
- [nextNext  := manager nextInSortedFreeListLink: next given: freeChunk].
  "now either shorten the chunk, or remove it, adjusting the links to keep the list sorted."
  pigBytes < chunkBytes "if false, filled entire free chunk"
  ifTrue:
  [newChunk := manager initFreeChunkWithBytes: chunkBytes - pigBytes at: dest + pigBytes.
  self inSortedFreeListLink: prevFree to: newChunk given: prevPrevFree.
  self inSortedFreeListLink: newChunk to: next given: prevFree.
  next ~= 0 ifTrue:
  [self inSortedFreeListLink: next to: nextNext given: newChunk]]
  ifFalse:
  [self inSortedFreeListLink: prevFree to: next given: prevPrevFree.
  next ~= 0 ifTrue:
  [self inSortedFreeListLink: next to: nextNext given: prevFree]].
  "self checkTraversableSortedFreeList".
  ^freeChunk].
  prevPrevFree := prevFree.
  prevFree := freeChunk.
  freeChunk := next].
  ^0!

Item was removed:
- ----- Method: SpurPigCompactor>>unmarkSurvivingObjectsForPigCompact (in category 'compaction') -----
- unmarkSurvivingObjectsForPigCompact
- manager allPastSpaceObjectsDo:
- [:objOop|
- (manager isMarked: objOop) ifTrue:
- [manager setIsMarkedOf: objOop to: false]]!

Item was added:
+ CogClass subclass: #SpurPlanningCompactor
+ instanceVariableNames: 'manager scavenger coInterpreter biasForGC firstFreeObject firstMobileObject lastMobileObject savedFirstFieldsSpace savedFirstFieldsSpaceWasAllocated firstFieldOfRememberedSet'
+ 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 added:
+ ----- Method: SpurPlanningCompactor>>biasForGC (in category 'compaction - api') -----
+ biasForGC
+ biasForGC := true!

Item was added:
+ ----- Method: SpurPlanningCompactor>>biasForSnapshot (in category 'compaction - api') -----
+ biasForSnapshot
+ biasForGC := false!

Item was added:
+ ----- Method: SpurPlanningCompactor>>coInterpreter: (in category 'instance initialization') -----
+ coInterpreter: aVMSimulator
+ <doNotGenerate>
+ coInterpreter := aVMSimulator!

Item was added:
+ ----- 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:."
+ | onePass |
+ <inline: #never> "for profiling"
+ self initializeCompaction;
+ initializeScan.
+ [onePass := self planCompactSavingForwarders.
+ self updatePointers.
+ self copyAndUnmark.
+ manager checkFreeSpace: GCModeFull.
+ onePass or: [biasForGC]] whileFalse:
+ [self reinitializeScan;
+ updateSavedFirstFieldsSpaceIfNecessary].
+ self endCompaction!

Item was added:
+ ----- Method: SpurPlanningCompactor>>continueCopyAndUnmarkMobileObjectsFrom: (in category 'compaction') -----
+ continueCopyAndUnmarkMobileObjectsFrom: anUnpinnedEntity
+ "copyAndUnmarkMobileObjects has encountered a run of pinned objects around which
+ it cannot compact, but savedFirstFieldsSpace is still not full.  Continue the pass with new
+ firstFreeObject and firstMobileObject, resetting them before continuing.
+ Answer if the end of the heap was reached (savedFirstFieldsSpace has not overflowed)."
+ | result savedFirstFreeObject savedFirstMobileObject nextFreeObject |
+ self assert: (self oop: anUnpinnedEntity isLessThan: manager endOfMemory).
+ self deny: (manager isPinned: anUnpinnedEntity).
+ savedFirstFreeObject := firstFreeObject.
+ savedFirstMobileObject := firstMobileObject.
+ nextFreeObject := self scanForFirstFreeAndFirstMobileObjectFrom: anUnpinnedEntity.
+ nextFreeObject ifNil:
+ [^true].
+ firstFreeObject := nextFreeObject.
+ result := self copyAndUnmarkMobileObjects.
+ firstFreeObject := savedFirstFreeObject.
+ firstMobileObject := savedFirstMobileObject.
+ ^result!

Item was added:
+ ----- Method: SpurPlanningCompactor>>continuePlanCompactSavingForwardersFrom: (in category 'compaction') -----
+ continuePlanCompactSavingForwardersFrom: anUnpinnedEntity
+ "planCompactSavingForwarders has encountered a run of pinned objects around which
+ it cannot compact, but savedFirstFieldsSpace is still not full.  Continue the pass with new
+ firstFreeObject and firstMobileObject, resetting them before continuing.
+ Answer if the end of the heap was reached (savedFirstFieldsSpace has not overflowed)."
+ | result savedFirstFreeObject savedFirstMobileObject nextFreeObject |
+ self assert: (self oop: anUnpinnedEntity isLessThan: manager endOfMemory).
+ self deny: (manager isPinned: anUnpinnedEntity).
+ savedFirstFreeObject := firstFreeObject.
+ savedFirstMobileObject := firstMobileObject.
+ nextFreeObject := self scanForFirstFreeAndFirstMobileObjectFrom: anUnpinnedEntity.
+ nextFreeObject ifNil:
+ [^true].
+ result := self planCompactSavingForwarders.
+ firstFreeObject := savedFirstFreeObject.
+ firstMobileObject := savedFirstMobileObject.
+ ^result!

Item was added:
+ ----- Method: SpurPlanningCompactor>>continueUpdatePointersInMobileObjectsFrom: (in category 'compaction') -----
+ continueUpdatePointersInMobileObjectsFrom: anUnpinnedEntity
+ "updatePointersInMobileObjects has encountered a run of pinned objects around which
+ planCompactSavingForwarders cannot compact, but savedFirstFieldsSpace is still not full.
+ Continue the pass with new firstFreeObject and firstMobileObject, resetting them before continuing.
+ Answer if the end of the heap was reached (savedFirstFieldsSpace has not overflowed)."
+ | result savedFirstFreeObject savedFirstMobileObject nextFreeObject |
+ self assert: (self oop: anUnpinnedEntity isLessThan: manager endOfMemory).
+ self deny: (manager isPinned: anUnpinnedEntity).
+ savedFirstFreeObject := firstFreeObject.
+ savedFirstMobileObject := firstMobileObject.
+ nextFreeObject := self scanForFirstFreeAndFirstMobileObjectFrom: anUnpinnedEntity.
+ nextFreeObject ifNil:
+ [^true].
+ result := self updatePointersInMobileObjects.
+ firstFreeObject := savedFirstFreeObject.
+ firstMobileObject := savedFirstMobileObject.
+ ^result!

Item was added:
+ ----- Method: SpurPlanningCompactor>>copyAndUnmark (in category 'compaction') -----
+ copyAndUnmark
+ "Sweep the heap, unmarking all objects and moving mobile objects to their correct positions,
+ restoring their savedFirstFields."
+ | onePass |
+ self unmarkInitialImmobileObjects.
+ onePass := self copyAndUnmarkMobileObjects.
+ onePass ifFalse:
+ [self unmarkObjectsOverflowingSavedFirstFieldsSpace]!

Item was added:
+ ----- 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.
+ This enumeration matches that in planCompactSavingForwarders and updatePointersInMobileObjects."
+
+ | toFinger top previousPin |
+ toFinger := manager startOfObject: firstFreeObject.
+ top := savedFirstFieldsSpace start - manager bytesPerOop.
+ self deny: (manager isMarked: firstFreeObject).
+ manager allOldSpaceEntitiesForCompactingFrom: firstMobileObject do:
+ [:o|
+ self assert: (previousPin isNil or: [toFinger < previousPin]).
+ (manager isMarked: o) ifTrue:
+ [(manager isPinned: o)
+ ifTrue:
+ [(manager isSegmentBridge: o) ifFalse:
+ [manager setIsMarkedOf: o to: false.
+ manager segmentManager notePinned: o].
+ previousPin ifNotNil:
+ [self assert: previousPin > toFinger.
+ ((manager isSegmentBridge: previousPin)
+  and: [manager isSegmentBridge: o]) ifTrue:
+ [self halt: 'empty segment']].
+ previousPin := o]
+ ifFalse:
+ [| availableSpace bytes next |
+ (top := top + manager bytesPerOop) >= savedFirstFieldsSpace limit ifTrue:
+ [self freeFrom: toFinger upTo: (manager startOfObject: o) previousPin: previousPin.
+ ^false].
+ [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 beyond previousPin and update previousPin appropriately."
+ availableSpace > 0 ifTrue:
+ [manager addFreeChunkWithBytes: availableSpace at: toFinger].
+ toFinger := manager addressAfter: previousPin.
+ self assert: toFinger < manager endOfMemory.
+ next := manager objectStartingAt: toFinger.
+ next >= o ifTrue:
+ [^self continueCopyAndUnmarkMobileObjectsFrom: next].
+ previousPin := (manager isPinned: next) ifTrue: [next]].
+ bytes := self copyAndUnmarkObject: o to: toFinger firstField: (manager longAt: top).
+ toFinger := toFinger + bytes]]].
+ self freeFrom: toFinger upTo: manager endOfMemory previousPin: previousPin.
+ ^true!

Item was added:
+ ----- 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: #always>
+ | 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.
+ ^bytes!

Item was added:
+ ----- Method: SpurPlanningCompactor>>endCompaction (in category 'compaction') -----
+ endCompaction
+ manager
+ unmarkSurvivingObjectsForCompact;
+ endSlidingCompaction.
+ self repinRememberedSet.
+ self releaseSavedFirstFieldsSpace!

Item was added:
+ ----- Method: SpurPlanningCompactor>>findHighestSuitableFreeBlock: (in category 'space management') -----
+ findHighestSuitableFreeBlock: spaceEstimate
+ "If a freeBlock of size at least spaceEstimate exists high enough in the heap, choose it."
+ <inline: true>
+ manager findLargestFreeChunk ifNotNil:
+ [:largestFreeChunk|
+ (manager bytesInObject: largestFreeChunk) >= spaceEstimate ifTrue:
+ [^largestFreeChunk]].
+ ^nil!

Item was added:
+ ----- 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 added:
+ ----- 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 firstUnpinnedObjectFollowing: previousPinOrNil.
+ firstUnpinned >= limit ifTrue:
+ [^self].
+ effectiveToFinger := manager startOfObject: firstUnpinned].
+ manager addFreeChunkWithBytes: limit - effectiveToFinger at: effectiveToFinger!

Item was added:
+ ----- Method: SpurPlanningCompactor>>initialize (in category 'instance initialization') -----
+ initialize
+ biasForGC := true.
+ savedFirstFieldsSpace := SpurContiguousObjStack new.
+ savedFirstFieldsSpaceWasAllocated := false!

Item was added:
+ ----- Method: SpurPlanningCompactor>>initializeCompaction (in category 'compaction') -----
+ initializeCompaction
+ manager checkFreeSpace: GCModeFull.
+ self selectSavedFirstFieldsSpace.
+ self unpinRememberedSet.
+ manager
+ resetFreeListHeads;
+ totalFreeOldSpace: 0;
+ beginSlidingCompaction!

Item was added:
+ ----- Method: SpurPlanningCompactor>>initializeScan (in category 'compaction') -----
+ initializeScan
+ savedFirstFieldsSpace top: savedFirstFieldsSpace start - manager bytesPerOop.
+ firstFreeObject := self scanForFirstFreeAndFirstMobileObjectFrom: (manager objectAfter: manager hiddenRootsObject).
+ firstFreeObject ifNil:
+ [self error: 'uncompactable heap; no unmarked objects found']!

Item was added:
+ ----- Method: SpurPlanningCompactor>>isMobile: (in category 'private') -----
+ isMobile: obj
+ <inline: #always>
+ ^(self oop: obj isGreaterThanOrEqualTo: firstMobileObject andLessThanOrEqualTo:  lastMobileObject)
+ and: [(manager isPinned: obj) not]!

Item was added:
+ ----- Method: SpurPlanningCompactor>>isPostMobile: (in category 'private') -----
+ isPostMobile: obj
+ "For asserts"
+ ^self oop: obj isGreaterThanOrEqualTo: firstFreeObject andLessThanOrEqualTo:  lastMobileObject!

Item was added:
+ ----- Method: SpurPlanningCompactor>>manager: (in category 'instance initialization') -----
+ manager: aSpurNBitMMXEndianSimulator
+ <doNotGenerate>
+ manager := aSpurNBitMMXEndianSimulator.
+ aSpurNBitMMXEndianSimulator coInterpreter ifNotNil:
+ [:coint| coInterpreter := coint].
+ aSpurNBitMMXEndianSimulator scavenger ifNotNil:
+ [:scav| scavenger := scav]!

Item was added:
+ ----- Method: SpurPlanningCompactor>>numPointerSlotsWhileCompactingOf:savedFirstFieldPointer: (in category 'private') -----
+ numPointerSlotsWhileCompactingOf: obj savedFirstFieldPointer: firstFieldPtrOrNil
+ "This is a version of SpurMemoryManager>>numPointerSlotsOf: that deals with the
+ possibility of obj being a CompiledMethod whose header is in savedFirstFieldsSpace.
+ Answer the number of pointer fields in the given object.
+ Works with CompiledMethods, as well as ordinary objects."
+ <inline: true>
+ | fmt contextSize numLiterals header |
+ fmt := manager formatOf: obj.
+ fmt <= manager lastPointerFormat ifTrue:
+ [(fmt = manager indexablePointersFormat
+  and: [manager isContextNonImm: obj]) ifTrue:
+ ["contexts end at the stack pointer"
+ contextSize := coInterpreter fetchStackPointerOf: obj.
+ ^CtxtTempFrameStart + contextSize].
+ ^manager numSlotsOf: obj  "all pointers"].
+ self deny: fmt = manager forwardedFormat.
+ fmt < manager firstCompiledMethodFormat ifTrue: [^0]. "no pointers"
+
+ "CompiledMethod: contains both pointers and bytes"
+ self assert: firstFieldPtrOrNil notNil == (self isMobile: obj).
+ header := firstFieldPtrOrNil
+ ifNil: [manager methodHeaderOf: obj]
+ ifNotNil: [manager methodHeaderFromSavedFirstField: (manager longAt: firstFieldPtrOrNil)].
+ numLiterals := manager literalCountOfMethodHeader: header.
+ ^numLiterals + LiteralStart!

Item was added:
+ ----- 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).
+
+ Note that this method is potentially recursive. If skipping a run of pinned objects
+ causes the the algorithm to encounter another run of immobile objects it will
+ recurse via continuePlanCompactSavingForwardersFrom:.
+
+ This enumeration matches that in updatePointersInMobileObjects and copyAndUnmarkMobileObjects."
+
+ | toFinger top previousPin |
+ toFinger := manager startOfObject: firstFreeObject.
+ top := savedFirstFieldsSpace top.
+ self deny: (manager isMarked: firstFreeObject).
+ manager allOldSpaceEntitiesFrom: firstMobileObject do:
+ [:o|
+ self assert: (previousPin isNil or: [toFinger < previousPin]).
+ (manager isMarked: o) ifTrue:
+ [(manager isPinned: o)
+ ifTrue:
+ [previousPin ifNotNil:
+ [self assert: previousPin > toFinger.
+ ((manager isSegmentBridge: previousPin)
+  and: [manager isSegmentBridge: o]) ifTrue:
+ [self halt: 'empty segment']].
+ previousPin := o]
+ ifFalse:
+ [| availableSpace bytes next |
+ (top := top + manager bytesPerOop) >= savedFirstFieldsSpace limit ifTrue:
+ [savedFirstFieldsSpace top: top.
+ ^false].
+ [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 beyond previousPin and update previousPin appropriately."
+ toFinger := manager addressAfter: previousPin.
+ next := manager objectStartingAt: toFinger.
+ next >= o ifTrue:
+ [savedFirstFieldsSpace top: top.
+ ^self continuePlanCompactSavingForwardersFrom: next].
+ previousPin := (manager isPinned: next) ifTrue: [next]].
+ lastMobileObject := o.
+ manager
+ longAt: top put: (manager fetchPointer: 0 ofObject: o);
+ storePointerUnchecked: 0 "Don't use forward:to:; we dont want to alter the object in any way other than by setting the forwarding pointer"
+ ofObject: o
+ withValue: ((manager hasOverflowHeader: o)
+ ifTrue: [toFinger + manager baseHeaderSize]
+ ifFalse: [toFinger]).
+ toFinger := toFinger + (manager bytesInObject: o)]]].
+ savedFirstFieldsSpace top: top.
+ ^true!

Item was added:
+ ----- Method: SpurPlanningCompactor>>reinitializeScan (in category 'compaction') -----
+ reinitializeScan
+ firstFreeObject := self scanForFirstFreeAndFirstMobileObjectFrom: firstFreeObject.
+ firstFreeObject ifNil:
+ [self error: 'uncompactable heap; no unmarked objects found']!

Item was added:
+ ----- Method: SpurPlanningCompactor>>releaseSavedFirstFieldsSpace (in category 'space management') -----
+ releaseSavedFirstFieldsSpace
+ <inline: true>
+ savedFirstFieldsSpaceWasAllocated ifTrue:
+ [manager
+ sqDeallocateMemorySegmentAt: savedFirstFieldsSpace start asVoidPointer
+ OfSize: savedFirstFieldsSpace limit - savedFirstFieldsSpace start.
+ savedFirstFieldsSpaceWasAllocated := false]!

Item was added:
+ ----- Method: SpurPlanningCompactor>>relocateObjectsInHeapEntity:from:to: (in category 'compaction') -----
+ relocateObjectsInHeapEntity: heapEntity from: startIndex to: finishIndex
+ "Sweep the fields in some non-pointer heap entity (objStackPage, rememberedSet),
+ updating all references to mobile objects to their eventual locations.  Answer the
+ heapEntity's eventual location."
+ <inline: true>
+ startIndex to: finishIndex do:
+ [:i| | oop fwd |
+ oop := manager fetchPointer: i ofObject: heapEntity.
+ ((manager isNonImmediate: oop) and: [self isMobile: oop]) ifTrue:
+ [self assert: (manager isMarked: oop).
+ fwd := manager fetchPointer: 0 ofObject: oop.
+ self assert: (self isPostMobile: fwd).
+ manager storePointerUnchecked: i ofObject: heapEntity withValue: fwd]].
+ ^(self isMobile: heapEntity)
+ ifTrue: [manager fetchPointer: 0 ofObject: heapEntity]
+ ifFalse: [heapEntity]!

Item was added:
+ ----- Method: SpurPlanningCompactor>>remapObj: (in category 'gc - scavenge/compact') -----
+ remapObj: objOop
+ "Scavenge or simply follow objOop.  Answer the new location of objOop.
+ The send should have been guarded by a send of shouldRemapOop:.
+ The method is called remapObj: for compatibility with ObjectMemory."
+ <api>
+ <inline: false>
+ ^manager slidingCompactionRemapObj: objOop!

Item was added:
+ ----- Method: SpurPlanningCompactor>>repinRememberedSet (in category 'private') -----
+ repinRememberedSet
+ <inline: true>
+ scavenger rememberedSetSize > 0 ifTrue:
+ [manager storePointerUnchecked: 0 ofObject: manager rememberedSetObj withValue: firstFieldOfRememberedSet].
+ manager setIsPinnedOf: manager rememberedSetObj to: true.
+ scavenger relocateRememberedSet!

Item was added:
+ ----- Method: SpurPlanningCompactor>>scanForFirstFreeAndFirstMobileObjectFrom: (in category 'compaction') -----
+ scanForFirstFreeAndFirstMobileObjectFrom: initialObject
+ "Scan from initialObject, setting firstMobileObject to the first marked object after
+ the first free object found. Answer the first free object found, or nil if none."
+ <inline: false>
+ | firstFree |
+ manager allOldSpaceEntitiesFrom: initialObject do:
+ [:o|
+ (manager isMarked: o)
+ ifTrue:
+ [firstFree ifNotNil:
+ [firstMobileObject := o.
+ ^firstFree]]
+ ifFalse:
+ [firstFree ifNil:
+ [firstFree := o]]].
+ ^firstFree!

Item was added:
+ ----- Method: SpurPlanningCompactor>>selectSavedFirstFieldsSpace (in category 'space management') -----
+ selectSavedFirstFieldsSpace
+ "To compact the heap the algorithm must save the first field (used for the forwarding pointer)
+ of all moved objects. This is done in savedFirstFieldsSpace, a contiguous block of memory borrowed
+ for the duration of compaction. In a 32-bit system a typical upper bound on the space needed
+ is about 1/40 of the heap size.  The default new space size of 4Mb provides an eden of about
+ 3.6 Mb, which would serve the needs of a 144 Mb heap.  The default segment increment of
+ 16 Mb would serve the needs of a 640 Mb heap. Make an estimate of the size needed, and
+ either use eden, a large free chunk, or a newly-allocated segment, falling back on eden if
+ the alternatives can't be had."
+ <inline: true>
+ | spaceEstimate sizeOfEden |
+ spaceEstimate := manager endOfMemory - manager firstObject // 40.
+ sizeOfEden := scavenger eden limit - scavenger eden start.
+ spaceEstimate > sizeOfEden ifTrue:
+ [(self findHighestSuitableFreeBlock: spaceEstimate) ifNotNil:
+ [:highestSuitableFreeBlock|
+ (spaceEstimate > (manager sizeOfFree: highestSuitableFreeBlock)
+  and: [self useSegmentForSavedFirstFieldsSpace: spaceEstimate]) ifTrue:
+ [^self].
+ (manager sizeOfFree: highestSuitableFreeBlock) > sizeOfEden ifTrue:
+ [self useFreeChunkForSavedFirstFieldsSpace: highestSuitableFreeBlock.
+ ^self]]].
+ self useEdenForSavedFirstFieldsSpace!

Item was added:
+ ----- Method: SpurPlanningCompactor>>shouldRemapObj: (in category 'gc - scavenge/compact') -----
+ shouldRemapObj: objOop
+ <api>
+ "Answer if the obj should be scavenged, or simply followed. Sent via the compactor
+ from shouldRemapObj:.  We test for being already scavenged because mapStackPages
+ via mapInterpreterOops may be applied twice in the context of a global GC where a
+ scavenge, followed by a scan-mark-free, and final compaction passes may result in
+ scavenged fields being visited twice."
+ ^manager slidingCompactionShouldRemapObj: objOop!

Item was added:
+ ----- Method: SpurPlanningCompactor>>unmarkInitialImmobileObjects (in category 'compaction') -----
+ unmarkInitialImmobileObjects
+ "Sweep the initial immobile heap, unmarking all objects up to the first mobile object."
+ manager allOldSpaceObjectsFrom: manager firstObject do:
+ [:o|
+ o >= firstMobileObject ifTrue:
+ [^self].
+ manager setIsMarkedOf: o to: false]!

Item was added:
+ ----- Method: SpurPlanningCompactor>>unmarkObjectsOverflowingSavedFirstFieldsSpace (in category 'compaction') -----
+ unmarkObjectsOverflowingSavedFirstFieldsSpace
+ self shouldBeImplemented!

Item was added:
+ ----- Method: SpurPlanningCompactor>>unpinRememberedSet (in category 'private') -----
+ unpinRememberedSet
+ <inline: true>
+ firstFieldOfRememberedSet := manager fetchPointer: 0 ofObject: manager rememberedSetObj.
+ manager setIsPinnedOf: manager rememberedSetObj to: false!

Item was added:
+ ----- 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."
+ | onePass |
+ coInterpreter mapInterpreterOops.
+ self updatePointersInManagerHeapEntities.
+ self updatePointersInSurvivingObjects.
+ self updatePointersInInitialImmobileObjects.
+ onePass := self updatePointersInMobileObjects.
+ onePass ifFalse:
+ [self updatePointersInObjectsOverflowingSavedFirstFieldsSpace]!

Item was added:
+ ----- Method: SpurPlanningCompactor>>updatePointersFrom:to:in: (in category 'compaction') -----
+ updatePointersFrom: start to: finish in: obj
+ <inline: #always>
+ start to: finish do:
+ [:i| | oop fwd |
+ oop := manager fetchPointer: i ofObject: obj.
+ ((manager isNonImmediate: oop) and: [self isMobile: oop]) ifTrue:
+ [self assert: (manager isMarked: oop).
+ fwd := manager fetchPointer: 0 ofObject: oop.
+ self assert: (self isPostMobile: fwd).
+ manager storePointerUnchecked: i ofObject: obj withValue: fwd]]!

Item was added:
+ ----- Method: SpurPlanningCompactor>>updatePointersIn:startingAt:savedFirstFieldPointer: (in category 'compaction') -----
+ updatePointersIn: obj startingAt: startIndex savedFirstFieldPointer: firstFieldPtrOrNil
+ "Sweep the pointer fields in obj, updating all references to mobile objects to their eventual locations.
+ firstFieldPtrOrNil is supplied for mobile objects so that the first field of a compiled method (which is
+ its header, or reference to a CogMethod holding its header) can be retrieved."
+ <inline: true>
+ startIndex to: (self numPointerSlotsWhileCompactingOf: obj savedFirstFieldPointer: firstFieldPtrOrNil) - 1 do:
+ [:i| | oop fwd |
+ oop := manager fetchPointer: i ofObject: obj.
+ ((manager isNonImmediate: oop) and: [self isMobile: oop]) ifTrue:
+ [self assert: ((manager isMarked: oop) or: [obj = manager hiddenRootsObject]).
+ fwd := manager fetchPointer: 0 ofObject: oop.
+ self assert: (self isPostMobile: fwd).
+ manager storePointerUnchecked: i ofObject: obj withValue: fwd]]!

Item was added:
+ ----- 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|
+ o >= firstFreeObject ifTrue:
+ [^self].
+ self assert: (manager isMarked: o).
+ self updatePointersIn: o startingAt: 0 savedFirstFieldPointer: nil]!

Item was added:
+ ----- Method: SpurPlanningCompactor>>updatePointersInManagerHeapEntities (in category 'compaction') -----
+ updatePointersInManagerHeapEntities
+ "The special non-pointer objects containing pointers, which are the objStacks and the rememberedSet,
+ must be updated manually sicme they will not be recognized as containing pointers in the normal sweep."
+ manager relocateObjStacksForPlanningCompactor.
+ (scavenger rememberedSetSize > 0
+ and: [self isMobile: firstFieldOfRememberedSet]) ifTrue:
+ [firstFieldOfRememberedSet := manager fetchPointer: 0 ofObject: firstFieldOfRememberedSet].
+ self relocateObjectsInHeapEntity: manager rememberedSetObj from: 1 to: scavenger rememberedSetSize - 1
+ "Note that we /must not/ set the rememberedSetObj here since it is a slot in the hiddenRootsObj
+ and will be updated normally in updatePointersInInitialImmobileObjects.  So do not do
+ (self isMobile: manager rememberedSetObj) ifTrue:
+ [manager rememberedSetObj: (manager fetchPointer: 0 ofObject: manager rememberedSetObj)]"!

Item was added:
+ ----- 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.
+ This enumeration matches that in planCompactSavingForwarders and copyAndUnmarkMobileObjects."
+
+ | toFinger top previousPin |
+ toFinger := manager startOfObject: firstFreeObject.
+ top := savedFirstFieldsSpace start - manager bytesPerOop.
+ self deny: (manager isMarked: firstFreeObject).
+ manager allOldSpaceEntitiesFrom: firstMobileObject do:
+ [:o|
+ self assert: (previousPin isNil or: [toFinger < previousPin]).
+ (manager isMarked: o) ifTrue:
+ [(manager isPinned: o)
+ ifTrue:
+ [self updatePointersIn: o startingAt: 0 savedFirstFieldPointer: nil.
+ previousPin ifNotNil:
+ [self assert: previousPin > toFinger.
+ ((manager isSegmentBridge: previousPin)
+  and: [manager isSegmentBridge: o]) ifTrue:
+ [self halt: 'empty segment']].
+ previousPin := o]
+ ifFalse:
+ [| availableSpace bytes next |
+ (top := top + manager bytesPerOop) >= savedFirstFieldsSpace limit ifTrue:
+ [^false].
+ [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 beyond previousPin and update previousPin appropriately."
+ toFinger := manager addressAfter: previousPin.
+ next := manager objectStartingAt: toFinger.
+ next >= o ifTrue:
+ [^self continueUpdatePointersInMobileObjectsFrom: next].
+ previousPin := (manager isPinned: next) ifTrue: [next]].
+ ((manager formatOf: o) <= manager lastPointerFormat
+  and: [(manager numSlotsOf: o) > 0]) ifTrue:
+ [| oop fwd |
+ "Relocate the saved first field; Note that CompiledMethods can be excluded since their
+  first field is either a SmallInteger or a reference to a CogMethod outside of oldSpace."
+ oop := manager longAt: top.
+ ((manager isNonImmediate: oop) and: [self isMobile: oop]) ifTrue:
+ [self assert: (manager isMarked: oop).
+ fwd := manager fetchPointer: 0 ofObject: oop.
+ self assert: (self isPostMobile: fwd).
+ manager longAt: top put: fwd]].
+ self updatePointersIn: o startingAt: 1 savedFirstFieldPointer: top.
+ toFinger := toFinger + (manager bytesInObject: o)]]].
+ ^true!

Item was added:
+ ----- Method: SpurPlanningCompactor>>updatePointersInSurvivingObjects (in category 'compaction') -----
+ updatePointersInSurvivingObjects
+ "Sweep pastSpace, updating all references to mobile objects to their eventual locations."
+ manager allPastSpaceObjectsDo:
+ [:o|
+ self assert: (manager isMarked: o).
+ self updatePointersIn: o startingAt: 0 savedFirstFieldPointer: nil]!

Item was added:
+ ----- Method: SpurPlanningCompactor>>updateSavedFirstFieldsSpaceIfNecessary (in category 'space management') -----
+ updateSavedFirstFieldsSpaceIfNecessary
+ "If savedFirstFieldsSpace is a free chunk then it may need to be repositioned if there is more than one pass."
+
+ ((manager isInOldSpace: savedFirstFieldsSpace start)
+ and: [savedFirstFieldsSpaceWasAllocated not]) ifTrue:
+ [self useFreeChunkForSavedFirstFieldsSpace: manager findLargestFreeChunk].
+
+ savedFirstFieldsSpace top: savedFirstFieldsSpace start - manager bytesPerOop.
+ manager resetFreeListHeads!

Item was added:
+ ----- Method: SpurPlanningCompactor>>useEdenForSavedFirstFieldsSpace (in category 'space management') -----
+ useEdenForSavedFirstFieldsSpace
+ "Use teden to hold the savedFirstFieldsSpace."
+ <inline: true>
+ savedFirstFieldsSpace
+ start: scavenger eden start;
+ limit: scavenger eden limit!

Item was added:
+ ----- Method: SpurPlanningCompactor>>useFreeChunkForSavedFirstFieldsSpace: (in category 'space management') -----
+ useFreeChunkForSavedFirstFieldsSpace: highestSuitableFreeBlock
+ "Use the supplied free chunk to hold the savedFirstFieldsSpace.
+ Invoked when eden is found not to be big enough for the job."
+ <inline: true>
+ savedFirstFieldsSpace
+ start: highestSuitableFreeBlock;
+ limit: (manager addressAfter: highestSuitableFreeBlock)!

Item was added:
+ ----- Method: SpurPlanningCompactor>>useSegmentForSavedFirstFieldsSpace: (in category 'space management') -----
+ useSegmentForSavedFirstFieldsSpace: spaceEstimate
+ "Attempt to allocate a memory segment large enough to hold the savedFirstFieldsSpace.
+ Invoked when neither eden nor a large free chunk are found to be big enough for the
+ job."
+ | allocatedSize |
+ (manager "sent to the manager so that the simulator can increase memory to simulate a new segment"
+ sqAllocateMemorySegmentOfSize: spaceEstimate
+ Above: (self firstGapOfSizeAtLeast: spaceEstimate)
+ AllocatedSizeInto: (self cCode: [self addressOf: allocatedSize]
+ inSmalltalk: [[:sz| allocatedSize := sz]])) ifNotNil:
+ [:segAddress|
+ savedFirstFieldsSpaceWasAllocated := true.
+ savedFirstFieldsSpace
+ start: segAddress;
+ limit: segAddress + allocatedSize.
+ ^true].
+ ^false!

Item was added:
+ CogClass subclass: #SpurSlidingCompactor
+ instanceVariableNames: 'manager scavenger coInterpreter compactedCopySpace'
+ classVariableNames: ''
+ poolDictionaries: 'SpurMemoryManagementConstants VMBasicConstants VMSpurObjectRepresentationConstants'
+ category: 'VMMaker-SpurMemoryManager'!
+
+ !SpurSlidingCompactor commentStamp: 'eem 12/17/2016 15:30' prior: 0!
+ SpurSlidingCompactor compacts memory completely by sliding objects down in memory.  It does so by using a buffer (compactedCopySpace) to hold a copy of compacted objects in some region of the heap being compacted.  Starting at the first object above free space (up until a pinned object), objects are copied into CCS until it fills up, and as objects are copied, their originals are forwarded to the location they would occupy.  Once the CCS is full, or all of the heap has been copied to it, memory is scanned searching for oops in the range being compacted, and oops are updated to their actual positions.  Then the contents of the CCS are block copied into place.  The process repeats until all of the heap has been compacted.  This will leave one contiguous free chunk in the topmost occupied segment (ignoring pinned objects).  The number of passes made to follow forwarders is approximately the allocated size of the heap divided by the size of CCS; the larger CCS the more objects that can
  be compacted in one go (ignoring the effect of pinned objects).
+
+ Instance Variables
+ coInterpreter: <StackInterpreter>
+ compactedCopySpace: <SpurNewSpaceSpace>
+ manager: <SpurMemoryManager>
+ scavenger: <SpurGenerationScavenger>
+
+ compactedCopySpace
+ - a large contiguous region of memory used to copy objects into during compaction.  The compactor may try and allocate a segment, use a large free chunk or use eden for this memory.!

Item was added:
+ ----- Method: SpurSlidingCompactor>>biasForGC (in category 'compaction - api') -----
+ biasForGC
+ <inline: true>!

Item was added:
+ ----- Method: SpurSlidingCompactor>>biasForSnapshot (in category 'compaction - api') -----
+ biasForSnapshot
+ <inline: true>!

Item was added:
+ ----- Method: SpurSlidingCompactor>>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:.
+ destination: nil or the start of a run of free and/or unmarked objects
+ pinnedObject: nil or the pinned object found in the sweep around which unpinned objects must be copied."
+ | destination pinnedObject |
+ <inline: #never> "for profiling"
+ manager checkFreeSpace: GCModeFull.
+ manager resetFreeListHeads.
+ self selectCompactedCopySpace.
+ destination := pinnedObject := nil.
+ manager allOldSpaceEntitiesFrom: manager firstObject do:
+ [:o|
+ (manager isMarked: o)
+ ifTrue: "forwarders should have been followed in markAndTrace:"
+ [self assert: (manager isForwarded: o) not.
+ destination
+ ifNil:
+ [manager setIsMarkedOf: o to: false.
+ (manager isPinned: o) ifTrue:
+ [manager segmentManager notePinned: o]]
+ ifNotNil:
+ [(manager isPinned: o)
+ ifTrue:
+ [manager segmentManager notePinned: o.
+ destination := self copyObjectsInCompactedCopySpaceTo: destination followingUpTo: o.
+ (manager startOfObject: o) - destination > manager allocationUnit
+ ifTrue: "Possible to move objects below the pinnedObject"
+ [pinnedObject
+ ifNil: []
+ ifNotNil: [].
+ pinnedObject := o]
+ ifFalse: "Impossible; ensure there's a free chunk if necessary."
+ [pinnedObject
+ ifNil: []
+ ifNotNil: [].
+ destination := nil]] "WAIT; NEED AT LEAST 2 WORDS FOR FREE CHUNK"
+ ifFalse:
+ [manager setIsMarkedOf: o to: false.
+ (self fitsInCompactedCopySpace: o) ifFalse:
+ [destination := self copyObjectsInCompactedCopySpaceTo: destination followingUpTo: o].
+  (self fitsInCompactedCopySpace: o)
+ ifFalse: [destination := self slideHugeObject: o downTo: destination]
+ ifTrue:
+ [self copyToCompactedCopySpace: o andForwardTargetedAt: destination]]]]
+ ifFalse: "unmarked; two cases, an unreachable object or a free chunk. Should be faster to set free than to check if already free..."
+ [destination ifNil: [destination := manager startOfObject: o].
+ manager setObjectFree: o]]!

Item was changed:
  ----- Method: StackInterpreter>>mapStackPages (in category 'object memory support') -----
  mapStackPages
  <inline: #never>
  <var: #thePage type: #'StackPage *'>
  <var: #theSP type: #'char *'>
  <var: #theFP type: #'char *'>
  <var: #callerFP type: #'char *'>
  <var: #theIPPtr type: #'char *'>
  | numLivePages |
  numLivePages := 0.
  0 to: numStackPages - 1 do:
  [:i| | thePage theSP theFP callerFP theIPPtr theIP oop |
  thePage := stackPages stackPageAt: i.
  thePage isFree ifFalse:
  [self assert: (self ifCurrentStackPageHasValidHeadPointers: thePage).
  numLivePages := numLivePages + 1.
  theSP := thePage headSP.
  theFP := thePage  headFP.
  "Skip the instruction pointer on top of stack of inactive pages."
  thePage = stackPage
  ifTrue: [theIPPtr := 0]
  ifFalse:
  [theIPPtr := theSP.
  theSP := theSP + objectMemory wordSize].
  [self assert: (thePage addressIsInPage: theFP).
  self assert: (thePage addressIsInPage: theSP).
  self assert: (theIPPtr = 0 or: [thePage addressIsInPage: theIPPtr]).
  [theSP <= (theFP + FoxReceiver)] whileTrue:
  [oop := stackPages longAt: theSP.
  (objectMemory shouldRemapOop: oop) ifTrue:
  [stackPages longAt: theSP put: (objectMemory remapObj: oop)].
  theSP := theSP + objectMemory wordSize].
  (self frameHasContext: theFP) ifTrue:
  [(objectMemory shouldRemapObj: (self frameContext: theFP)) ifTrue:
  [stackPages
  longAt: theFP + FoxThisContext
  put: (objectMemory remapObj: (self frameContext: theFP))].
+ "With SqueakV3 objectMemory or SpurPlanningCompactor can't assert since object body is yet to move."
+ (objectMemory hasSpurMemoryManagerAPI
+  and: [objectMemory slidingCompactionInProgress not]) ifTrue:
- "With SqueakV3 objectMemory can't assert since object body is yet to move."
- objectMemory hasSpurMemoryManagerAPI ifTrue:
  [self assert: ((self isMarriedOrWidowedContext: (self frameContext: theFP))
   and: [(self frameOfMarriedContext: (self frameContext: theFP)) = theFP])]].
  (objectMemory shouldRemapObj: (self frameMethod: theFP)) ifTrue:
  [theIPPtr ~= 0 ifTrue:
  [self assert: (stackPages longAt: theIPPtr) > (self frameMethod: theFP).
  theIP := (stackPages longAt: theIPPtr) - (self frameMethod: theFP)].
  stackPages
  longAt: theFP + FoxMethod
  put: (objectMemory remapObj: (self frameMethod: theFP)).
  theIPPtr ~= 0 ifTrue:
  [stackPages longAt: theIPPtr put: theIP + (self frameMethod: theFP)]].
  (callerFP := self frameCallerFP: theFP) ~= 0] whileTrue:
  [theSP := (theIPPtr := theFP + FoxCallerSavedIP) + objectMemory wordSize.
  theFP := callerFP].
  theSP := theFP + FoxCallerContext. "a.k.a. FoxCallerSavedIP"
  [theSP <= thePage baseAddress] whileTrue:
  [oop := stackPages longAt: theSP.
  (objectMemory shouldRemapOop: oop) ifTrue:
  [stackPages longAt: theSP put: (objectMemory remapObj: oop)].
  theSP := theSP + objectMemory wordSize]]].
  stackPages recordLivePagesOnMapping: numLivePages!

Item was changed:
  ----- Method: StackInterpreterSimulator>>printHexnp: (in category 'debug printing') -----
  printHexnp: anInteger
 
  traceOn ifTrue:
+ [transcript nextPutAll: ((anInteger ifNil: [0]) storeStringBase: 16)]!
- [transcript nextPutAll: (anInteger storeStringBase: 16)]!