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

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

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

Name: VMMaker.oscog-eem.2248
Author: eem
Time: 29 June 2017, 4:59:22.607415 pm
UUID: 448c072a-f72b-4003-8e32-dba2ca76b4cc
Ancestors: VMMaker.oscog-eem.2247

Add a test for image segments that tries to save all of HashedCollection's subclasses and reload it.  Currently no comparison of input and output yet.

Refactor SpurPlanningCompactorTests & (the new) SpurImageSegmentTests under SpurImageSegmentTests and SpurPlanningCompactorTestsImageResource to SpurImageTestResource.

Simplify and avoid inlining the segment manager result-returning/restoration routines.  Add a few more sends of halt to error results retrurned (in mapOopsFrom:...).
Don't offset class out pointer references by firstClassIndexPun.
Extract the check for an out pointer class hash (in mapOopsFrom:...) into its own method.

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

Item was added:
+ Object subclass: #SimulatorHarness
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: 'VMObjectIndices'
+ category: 'VMMaker-Support'!
+
+ !SimulatorHarness commentStamp: 'eem 6/29/2017 12:12' prior: 0!
+ SimulatorHarness provides machinery for executing code within a simulator that is initialized with an image but not up and running.!

Item was added:
+ ----- Method: SimulatorHarness>>deny: (in category 'testing') -----
+ deny: aBooleanOrBlock
+ aBooleanOrBlock value ifTrue: [AssertionFailure signal: 'Assertion failed']!

Item was added:
+ ----- Method: SimulatorHarness>>interpreter:object:perform:withArguments: (in category 'execution') -----
+ interpreter: sim object: receiver perform: selector withArguments: arguments
+ "Interpret an expression in oldHeap using oldInterpreter.
+ Answer the result."
+ | fp savedpc savedsp savedStackPages result startByteCount |
+ self assert: ({receiver. selector}, arguments allSatisfy:
+ [:oop| oop isInteger and: [sim objectMemory addressCouldBeOop: oop]]).
+ savedpc := sim localIP.
+ savedsp := sim localSP.
+ savedStackPages := Set with: sim stackPage.
+ sim internalPush: receiver.
+ arguments do: [:arg| sim internalPush: arg].
+ sim
+ argumentCount: arguments size;
+ messageSelector: selector.
+ fp := sim localFP.
+ startByteCount := sim byteCount.
+ "sim byteCount = 66849 ifTrue: [self halt]."
+ sim normalSend.
+ sim incrementByteCount. "otherwise, send is not counted"
+ ["sim printFrame: sim localFP WithSP: sim localSP"
+ "sim setBreakSelector: #elementsForwardIdentityTo:"
+ "sim byteCount = 66849 ifTrue: [self halt]."
+ "(sim byteCount > 7508930 and: [sim localFP = -16r27894]) ifTrue:
+ [self halt]."
+ fp = sim localFP] whileFalse:
+ [sim singleStep.
+ (savedStackPages includes: sim stackPage) ifFalse: "If the stack gets deep something has probably gone wrong..."
+ [savedStackPages size > 20 ifTrue: [self halt].
+ savedStackPages add: sim stackPage]].
+ result := sim internalPopStack.
+ self assert: savedsp = sim localSP.
+ self assert: sim localIP - 1 = savedpc.
+ sim localIP: savedpc.
+ ^result!

Item was added:
+ ----- Method: SimulatorHarness>>withExecutableInterpreter:do: (in category 'execution') -----
+ withExecutableInterpreter: sim do: aBlock
+ "With the oldInterpreter ready to execute code, evaluate aBlock,
+ then return the interpreter (and the heap) to the ``just snapshotted'' state."
+ | savedpc savedfp initialContext finalContext |
+ sim
+ initStackPages;
+ loadInitialContext;
+ internalizeIPandSP.
+ savedpc := sim localIP.
+ savedfp := sim localFP.
+ "sim printHeadFrame."
+ aBlock cull: sim cull: self.
+ "sim printHeadFrame."
+ sim
+ internalPush: sim localIP;
+ externalizeIPandSP.
+ "now undo the execution state"
+ self assert: sim localFP = savedfp.
+ initialContext := sim frameContext: savedfp.
+ finalContext := sim voidVMStateForSnapshotFlushingExternalPrimitivesIf: false.
+ self assert: initialContext = finalContext.
+ self assert: sim localIP = savedpc.
+ sim objectMemory
+ storePointer: SuspendedContextIndex
+ ofObject: sim activeProcess
+ withValue: finalContext!

Item was added:
+ SimulatorHarness subclass: #SimulatorHarnessForTests
+ instanceVariableNames: 'simulator'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'VMMaker-Tests'!

Item was added:
+ ----- Method: SimulatorHarnessForTests>>findClassNamed: (in category 'utilities') -----
+ findClassNamed: classNameString
+ | className classNameIndex om |
+ (className := self findSymbol: classNameString) ifNil:
+ [^nil].
+ classNameIndex := simulator classNameIndex.
+ (om := simulator objectMemory) allObjectsDo:
+ [:obj|
+ ((om numSlotsOf: obj) > classNameIndex
+ and: [(simulator objCouldBeClassObj: obj)
+ and: [(om fetchPointer: simulator classNameIndex ofObject: obj) = className]]) ifTrue:
+ [^obj]].
+ ^nil!

Item was added:
+ ----- Method: SimulatorHarnessForTests>>findSymbol: (in category 'utilities') -----
+ findSymbol: aString
+ "Find the Symbol equal to aString in oldHeap."
+ | om size symbolClassTag |
+ symbolClassTag := (om := simulator objectMemory) rawClassTagForClass: self symbolClass.
+ size := aString size.
+ om allObjectsDo:
+ [:obj|
+ (symbolClassTag = (om fetchClassTagOfNonImm: obj)
+ and: [(om numBytesOf: obj) = size
+ and: ["(om fetchByte: 0 ofObject: obj) asCharacter == $C ifTrue:
+ [simulator printOopShort: obj; halt]."
+ (om str: aString n: obj + om baseHeaderSize cmp: size) = 0]]) ifTrue:
+ [^obj]].
+ ^nil!

Item was added:
+ ----- Method: SimulatorHarnessForTests>>interpreter:object:perform:withArguments: (in category 'execution') -----
+ interpreter: sim object: receiver perform: selector withArguments: arguments
+ simulator := sim.
+ ^super interpreter: sim object: receiver perform: selector withArguments: arguments!

Item was added:
+ ----- Method: SimulatorHarnessForTests>>symbolClass (in category 'utilities') -----
+ symbolClass
+ ^simulator objectMemory fetchClassOfNonImm: (simulator objectMemory splObj: SelectorDoesNotUnderstand)!

Item was added:
+ ----- Method: SimulatorHarnessForTests>>withExecutableInterpreter:do: (in category 'execution') -----
+ withExecutableInterpreter: sim do: aBlock
+ simulator := sim.
+ ^super withExecutableInterpreter: sim do: aBlock!

Item was added:
+ ----- Method: Spur32BitMMLECoSimulator>>return:restoringObjectsIn:savedFirstFields:and:savedHashes: (in category 'image segment in/out') -----
+ return: errCode restoringObjectsIn: firstArray savedFirstFields: savedFirstFields and: secondArray savedHashes: savedHashes
+ self leakCheckImageSegments ifTrue:
+ [self halt: errCode printString].
+ ^super return: errCode restoringObjectsIn: firstArray savedFirstFields: savedFirstFields and: secondArray savedHashes: savedHashes!

Item was removed:
- ----- Method: Spur32BitMMLECoSimulator>>return:restoringObjectsIn:upTo:savedFirstFields:and:savedHashes: (in category 'image segment in/out') -----
- return: errCode restoringObjectsIn: firstArray upTo: limitOrTag savedFirstFields: savedFirstFields and: secondArray savedHashes: savedHashes
- self leakCheckImageSegments ifTrue:
- [self halt: errCode printString].
- ^super return: errCode restoringObjectsIn: firstArray upTo: limitOrTag savedFirstFields: savedFirstFields and: secondArray savedHashes: savedHashes!

Item was added:
+ ----- Method: Spur32BitMMLESimulator>>return:restoringObjectsIn:savedFirstFields:and:savedHashes: (in category 'image segment in/out') -----
+ return: errCode restoringObjectsIn: firstArray savedFirstFields: savedFirstFields and: secondArray savedHashes: savedHashes
+ self leakCheckImageSegments ifTrue:
+ [self halt: errCode printString].
+ ^super return: errCode restoringObjectsIn: firstArray savedFirstFields: savedFirstFields and: secondArray savedHashes: savedHashes!

Item was removed:
- ----- Method: Spur32BitMMLESimulator>>return:restoringObjectsIn:upTo:savedFirstFields:and:savedHashes: (in category 'image segment in/out') -----
- return: errCode restoringObjectsIn: firstArray upTo: limitOrTag savedFirstFields: savedFirstFields and: secondArray savedHashes: savedHashes
- self leakCheckImageSegments ifTrue:
- [self halt: errCode printString].
- ^super return: errCode restoringObjectsIn: firstArray upTo: limitOrTag savedFirstFields: savedFirstFields and: secondArray savedHashes: savedHashes!

Item was added:
+ ----- Method: Spur64BitMMLECoSimulator>>return:restoringObjectsIn:savedFirstFields:and:savedHashes: (in category 'image segment in/out') -----
+ return: errCode restoringObjectsIn: firstArray savedFirstFields: savedFirstFields and: secondArray savedHashes: savedHashes
+ self leakCheckImageSegments ifTrue:
+ [self halt: errCode printString].
+ ^super return: errCode restoringObjectsIn: firstArray savedFirstFields: savedFirstFields and: secondArray savedHashes: savedHashes!

Item was removed:
- ----- Method: Spur64BitMMLECoSimulator>>return:restoringObjectsIn:upTo:savedFirstFields:and:savedHashes: (in category 'image segment in/out') -----
- return: errCode restoringObjectsIn: firstArray upTo: limitOrTag savedFirstFields: savedFirstFields and: secondArray savedHashes: savedHashes
- self leakCheckImageSegments ifTrue:
- [self halt: errCode printString].
- ^super return: errCode restoringObjectsIn: firstArray upTo: limitOrTag savedFirstFields: savedFirstFields and: secondArray savedHashes: savedHashes!

Item was added:
+ ----- Method: Spur64BitMMLESimulator>>return:restoringObjectsIn:savedFirstFields:and:savedHashes: (in category 'image segment in/out') -----
+ return: errCode restoringObjectsIn: firstArray savedFirstFields: savedFirstFields and: secondArray savedHashes: savedHashes
+ self leakCheckImageSegments ifTrue:
+ [self halt: errCode printString].
+ ^super return: errCode restoringObjectsIn: firstArray savedFirstFields: savedFirstFields and: secondArray savedHashes: savedHashes!

Item was removed:
- ----- Method: Spur64BitMMLESimulator>>return:restoringObjectsIn:upTo:savedFirstFields:and:savedHashes: (in category 'image segment in/out') -----
- return: errCode restoringObjectsIn: firstArray upTo: limitOrTag savedFirstFields: savedFirstFields and: secondArray savedHashes: savedHashes
- self leakCheckImageSegments ifTrue:
- [self halt: errCode printString].
- ^super return: errCode restoringObjectsIn: firstArray upTo: limitOrTag savedFirstFields: savedFirstFields and: secondArray savedHashes: savedHashes!

Item was added:
+ LongTestCase subclass: #SpurImageSegmentTests
+ instanceVariableNames: ''
+ classVariableNames: 'CheckForLeaks'
+ poolDictionaries: 'VMBasicConstants VMSqueakClassIndices'
+ category: 'VMMaker-Tests'!

Item was added:
+ ----- Method: SpurImageSegmentTests class>>resources (in category 'accessing') -----
+ resources
+ ^{SpurTrunkImageTestResource}!

Item was added:
+ ----- Method: SpurImageSegmentTests>>initializedVM (in category 'private') -----
+ initializedVM
+ ^self resources anyOne current initializedVM cloneSimulation!

Item was added:
+ ----- Method: SpurImageSegmentTests>>testSaveHashedCollectionAndSubclasses (in category 'tests') -----
+ testSaveHashedCollectionAndSubclasses
+ SimulatorHarnessForTests new
+ withExecutableInterpreter: self initializedVM
+ do: [:vm :harness| | objects |
+ CheckForLeaks == true ifTrue: "CheckForLeaks := self confirm: 'Check for leaks?'"
+ [vm objectMemory setCheckForLeaks: (vm objectMemory class bindingOf: #GCModeImageSegment) value].
+ objects := harness
+ interpreter: vm
+ object: (harness findClassNamed: 'Compiler')
+ perform: (harness findSymbol: #evaluate:)
+ withArguments: {vm objectMemory stringForCString:
+ '| seg out result |
+ seg := WordArray new: 1024 * 1024.
+ out := Array new: 256.
+ nil tryPrimitive: 98 withArgs: { HashedCollection subclasses,
+ (HashedCollection subclasses collect: [:ea| ea class]).
+ seg. out }.
+ result := { seg. out }.
+ nil tryPrimitive: 99 withArgs: result.
+ result'}]!

Item was added:
+ TestResource subclass: #SpurImageTestResource
+ instanceVariableNames: 'emptyVM vmWithLoadedImage'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'VMMaker-Tests'!

Item was added:
+ ----- Method: SpurImageTestResource class>>baseImageName (in category 'accessing') -----
+ baseImageName
+ ^'core32-preen.image'!

Item was added:
+ ----- Method: SpurImageTestResource class>>imageNameForTests (in category 'accessing') -----
+ imageNameForTests
+ "self imageNameForTests"
+ | baseImageName |
+ baseImageName := self baseImageName.
+ #('.' 'oscogvm/image' '../oscogvm/image') do:
+ [:dirName|
+ ((FileDirectory default directoryExists: dirName)
+  and: [(FileDirectory on: dirName) fileExists: baseImageName]) ifTrue:
+ [^dirName, '/', baseImageName]].
+ self error: 'cannot find ', baseImageName!

Item was added:
+ ----- Method: SpurImageTestResource class>>preenImage (in category 'preening') -----
+ preenImage
+ "Assume there's a Pharo bootstrap core32.image in ../oscogvm/image/core32.image.
+ We should find out where the image directory is and write a download script to get it.
+ But for now assume it's there.  See e.g.
+ https://bintray.com/pharo-project/pharo/Pharo/201701061402-32bit#files"
+ "[self preenImage] timeToRun"
+ Spur32BitPreen new
+ writeDefaultHeader: true;
+ savedWindowSize: 640@480;
+ preenImage: self imageNameForTests!

Item was added:
+ ----- Method: SpurImageTestResource>>emptyVM (in category 'accessing') -----
+ emptyVM
+ ^emptyVM ifNil:
+ [emptyVM := StackInterpreterSimulator newWithOptions: #(ObjectMemory Spur32BitMemoryManager
+  compactorClass SpurPlanningCompactor)]!

Item was added:
+ ----- Method: SpurImageTestResource>>initializedVM (in category 'accessing') -----
+ initializedVM
+ vmWithLoadedImage ifNil:
+ [vmWithLoadedImage := StackInterpreterSimulator newWithOptions: #(ObjectMemory Spur32BitMemoryManager).
+ vmWithLoadedImage
+ openOn: self class imageNameForTests extraMemory: 0.
+ vmWithLoadedImage objectMemory
+ initializeMarkStack; "The Pharo bootstrap has no mark or weakling stacks :-)"
+ initializeWeaklingStack].
+ ^vmWithLoadedImage!

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

Item was changed:
  ----- Method: SpurMemoryManager>>assignClassIndicesAndPinFrom:to:outPointers:filling: (in category 'image segment in/out') -----
  assignClassIndicesAndPinFrom: segmentStart to: segmentLimit outPointers: outPointerArray filling: loadedObjectsArray
  "This is part of loadImageSegmentFrom:outPointers:.
  Make a final pass, assigning the real class indices and/or pinning pinned objects."
  | fillIdx objOop |
  objOop := self objectStartingAt: segmentStart.
  fillIdx := 0.
  [objOop < segmentLimit] whileTrue:
  [| classRef classOop classIndex |
  self storePointerUnchecked: fillIdx ofObject: loadedObjectsArray withValue: objOop.
  fillIdx := fillIdx + 1.
  "In the segment, class indices are offset indexes into the segment data,
+  or into outPointers.  See mapOopsFrom:to:outPointers:outHashes: and
+  newOutPointer:at:in:hashes:."
-  or into outPointers.  See mapOopsFrom:to:outPointers:outHashes:."
  classRef := self classIndexOf: objOop.
  classOop := (classRef anyMask: TopHashBit)
+ ifTrue: [self fetchPointer: classRef - TopHashBit ofObject: outPointerArray]
- ifTrue: [self fetchPointer: classRef - TopHashBit - self firstClassIndexPun ofObject: outPointerArray]
  ifFalse: [classRef - self firstClassIndexPun * self allocationUnit + segmentStart].
  classIndex := self rawHashBitsOf: classOop.
  self assert: (classIndex > self lastClassIndexPun
   and: [(self classOrNilAtIndex: classIndex) = classOop]).
  self setClassIndexOf: objOop to: classIndex.
  ((self isInNewSpace: objOop)
   and: [self isPinned: objOop]) ifTrue:
  [| oldClone |
  oldClone := self cloneInOldSpaceForPinning: objOop.
  oldClone ~= 0 ifTrue:
  [self setIsPinnedOf: oldClone to: true.
  self forward: objOop to: oldClone]].
  objOop := self objectAfter: objOop limit: segmentLimit]!

Item was changed:
  ----- Method: SpurMemoryManager>>copyObj:toAddr:startAt:stopAt:savedFirstFields:index: (in category 'image segment in/out') -----
  copyObj: objOop toAddr: segAddr startAt: segStart stopAt: endSeg savedFirstFields: savedFirstFields index: i
  "This is part of storeImageSegmentInto:outPointers:roots:.
  Copy objOop into the segment beginning at segAddr, and forward it to the copy,
  saving its first field in savedFirstField, and setting its marked bit to indicate it has
  been copied.  If it is a class in the class table, set the copy's hash to 0 for reassignment
  on load, and mark it as a class by setting its isRemembered bit.
  Answer the next segmentAddr if successful.  Answer an appropriate error code if not"
 
  "Copy the object..."
  | bodySize copy hash |
  <inline: false>
  bodySize := self bytesInObject: objOop.
  (self oop: segAddr + bodySize isGreaterThanOrEqualTo: endSeg) ifTrue:
+ [^PrimErrWritePastObject halt].
- [^PrimErrWritePastObject].
  self mem: segAddr asVoidPointer cp: (self startOfObject: objOop) asVoidPointer y: bodySize.
  copy := self objectStartingAt: segAddr.
 
  "Clear remembered, mark bits of all headers copied into the segment (except classes)"
  self
  setIsRememberedOf: copy to: false;
  setIsMarkedOf: copy to: false.
 
  "Make any objects with hidden dynamic state (contexts, methods) look like normal objects."
  self ifAProxy: objOop updateCopy: copy.
 
  "If the object is a class, zero its identityHash (which is its classIndex) and set its
  isRemembered bit.  It will be assigned a new hash and entered into the table on load."
  hash := self rawHashBitsOf: objOop.
  (hash > self lastClassIndexPun and: [(self classOrNilAtIndex: hash) = objOop]) ifTrue:
  [self setHashBitsOf: copy to: 0.
  self setIsRememberedOf: copy to: true].
 
  "Now forward the object to its copy in the segment."
  self storePointerUnchecked: i ofObject: savedFirstFields withValue: (self fetchPointer: 0 ofObject: objOop);
  storePointerUnchecked: 0 ofObject: objOop withValue: copy;
  setIsMarkedOf: objOop to: true.
 
  "Answer the new end of segment"
  ^segAddr + bodySize!

Item was added:
+ ----- Method: SpurMemoryManager>>is:outPointerClassHashFor:in:limit: (in category 'image segment in/out') -----
+ is: hash outPointerClassHashFor: oop in: outPointerArray limit: outIndex
+ "suspect; what about false positives?"
+ ^(hash anyMask: TopHashBit)
+  and: [hash - TopHashBit <= outIndex
+  and: [oop = (self fetchPointer: hash - TopHashBit ofObject: outPointerArray)]]!

Item was changed:
  ----- Method: SpurMemoryManager>>mapOopsAndValidateClassRefsFrom:to:outPointers: (in category 'image segment in/out') -----
  mapOopsAndValidateClassRefsFrom: segmentStart to: segmentLimit outPointers: outPointerArray
  "This is part of loadImageSegmentFrom:outPointers:.
  Scan through mapping oops and validating class references.  Defer
  entering any class objects into the class table and/or pinning objects
  until the second pass in assignClassIndicesAndPinFrom:to:outPointers:."
  | numOutPointers numSegObjs objOop |
  numOutPointers := self numSlotsOf: outPointerArray.
  numSegObjs := 0.
  objOop := self objectStartingAt: segmentStart.
  [objOop < segmentLimit] whileTrue:
  [| classIndex hash oop mappedOop |
  numSegObjs := numSegObjs + 1.
  (self isMarked: objOop) ifTrue:
  [^PrimErrInappropriate].
  classIndex := self classIndexOf: objOop.
  "validate the class ref, but don't update it until any internal classes have been added to the class table."
  (classIndex anyMask: TopHashBit)
  ifTrue:
+ [classIndex := classIndex - TopHashBit.
- [classIndex := classIndex - TopHashBit - self firstClassIndexPun.
  classIndex >= numOutPointers ifTrue:
  [^PrimErrBadIndex halt].
  mappedOop := self fetchPointer: classIndex ofObject: outPointerArray.
  hash := self rawHashBitsOf: mappedOop.
  (hash > self lastClassIndexPun and: [(self classOrNilAtIndex: hash) = mappedOop]) ifFalse:
  [^PrimErrInappropriate halt]]
  ifFalse: "The class is contained within the segment."
  [(oop := classIndex - self firstClassIndexPun * self allocationUnit + segmentStart) >= segmentLimit ifTrue:
  [^PrimErrBadIndex halt].
  (self rawHashBitsOf: oop) ~= 0 ifTrue:
  [^PrimErrInappropriate halt]].
  0 to: (self numPointerSlotsOf: objOop) - 1 do:
  [:i|
  oop := self fetchPointer: i ofObject: objOop.
  (self isNonImmediate: oop) ifTrue:
  [(oop anyMask: TopOopBit)
  ifTrue:
  [(oop := oop - TopOopBit / self bytesPerOop) >= numOutPointers ifTrue:
  [^PrimErrBadIndex halt].
  mappedOop := self fetchPointer: oop ofObject: outPointerArray]
  ifFalse:
  [(oop bitAnd: self allocationUnit - 1) ~= 0 ifTrue:
  [^PrimErrInappropriate halt].
  (mappedOop := oop + segmentStart) >= segmentLimit ifTrue:
  [^PrimErrBadIndex halt]].
  self storePointerUnchecked: i ofObject: objOop withValue: mappedOop]].
  objOop := self objectAfter: objOop limit: segmentLimit].
  ^numSegObjs negated!

Item was changed:
  ----- Method: SpurMemoryManager>>mapOopsFrom:to:outPointers:outHashes: (in category 'image segment in/out') -----
  mapOopsFrom: segStart to: segAddr outPointers: outPointerArray outHashes: savedOutHashes
  "This is part of storeImageSegmentInto:outPointers:roots:.
  Now scan, adding out pointers to the outPointersArray; all objects in arrayOfObjects
  have had their first fields set to point to their copies in segmentWordArray.  Answer
  the outIndex if the scan succeded.  Fail if outPointers is too small and answer -1.
 
  As established by copyObj:toAddr:startAt:stopAt:savedFirstFields:index:,
  the marked bit is set for all objects in the segment
  the remembered bit is set for all classes in the segment.
 
  Class indices should be set as follows (see assignClassIndicesAndPinFrom:to:outPointers:filling:)
  - class indices for classes in the segment "
  | objOop outIndex |
  outIndex := 0.
  self fillObj: outPointerArray numSlots: (self numSlotsOf: outPointerArray) with: nilObj.
  objOop := self objectStartingAt: segStart.
  [objOop < segAddr] whileTrue:
  [| oop hash segIndex |
  oop := self fetchClassOfNonImm: objOop.
  "Set the classIndex of the instance.  This is a segment offset (segAddr - segStart / allocatiopnUnit) for instances of
   classes within the segment, and an outPointer index (index in outPointers + TopHashBit) for classes outside the segment."
  (self isMarked: oop)
  ifTrue: "oop is a class in the segment; storeImageSegmentInto:outPointers:roots: established offset is within range."
  [oop := self fetchPointer: 0 ofObject: oop.
  self assert: (self oop: oop isGreaterThanOrEqualTo: segStart andLessThan: segAddr).
+ segIndex := oop - segStart / self allocationUnit + self firstClassIndexPun.
+ (segIndex anyMask: TopHashBit) ifTrue: "Too many classes in the segment"
+ [^-1 halt]]
- segIndex := oop - segStart / self allocationUnit.
- self deny: (segIndex + self firstClassIndexPun anyMask: TopHashBit)]
  ifFalse: "oop is an outPointer; locate or allocate its oop"
  [hash := self rawHashBitsOf: oop.
+ (self is: hash outPointerClassHashFor: oop in: outPointerArray limit: outIndex)
- ((hash anyMask: TopHashBit)
- and: [hash - TopHashBit <= outIndex
- and: [oop = (self fetchPointer: hash - TopHashBit ofObject: outPointerArray)]])
  ifTrue: [segIndex := hash]
  ifFalse: "oop is a new outPointer; allocate its oop"
  [outIndex := self newOutPointer: oop at: outIndex in: outPointerArray hashes: savedOutHashes.
  outIndex = 0 ifTrue: "no room in outPointers; fail"
+ [^-1 halt].
+ segIndex := self rawHashBitsOf: oop].
+ self assert: (segIndex anyMask: TopHashBit)].
+ self setClassIndexOf: objOop to: segIndex.
- [^-1].
- self assert: ((self rawHashBitsOf: oop) anyMask: TopHashBit).
- segIndex := self rawHashBitsOf: oop]].
- self setClassIndexOf: objOop to: segIndex + self firstClassIndexPun.
  0 to: (self numPointerSlotsOf: objOop) - 1 do:
  [:i|
  oop := self fetchPointer: i ofObject: objOop.
  (self isNonImmediate: oop) ifTrue:
  [(self isMarked: oop)
  ifTrue: "oop is an object in the segment."
  [oop := self fetchPointer: 0 ofObject: oop.
  self assert: (self oop: oop isGreaterThanOrEqualTo: segStart andLessThan: segAddr).
  oop := oop - segStart]
  ifFalse: "oop is an outPointer; locate or allocate its oop"
  [hash := self rawHashBitsOf: oop.
+ (self is: hash outPointerClassHashFor: oop in: outPointerArray limit: outIndex)
- ((hash anyMask: TopHashBit)
- and: [(hash := hash - TopHashBit) <= outIndex
- and: [oop = (self fetchPointer: hash ofObject: outPointerArray)]])
  ifTrue: [oop := hash * self bytesPerOop + TopOopBit]
  ifFalse: "oop is a new outPointer; allocate its oop"
  [outIndex := self newOutPointer: oop at: outIndex in: outPointerArray hashes: savedOutHashes.
  outIndex = 0 ifTrue: "no room in outPointers; fail"
+ [^-1 halt].
- [^-1].
  self assert: ((self rawHashBitsOf: oop) anyMask: TopHashBit).
  oop := (self rawHashBitsOf: objOop) - TopHashBit * self bytesPerOop + TopOopBit]].
  self storePointerUnchecked: i ofObject: objOop withValue: oop]].
  objOop := self objectAfter: objOop limit: segAddr].
  ^outIndex!

Item was added:
+ ----- Method: SpurMemoryManager>>return:restoringObjectsIn:savedFirstFields:and:savedHashes: (in category 'image segment in/out') -----
+ return: errCode restoringObjectsIn: firstArray savedFirstFields: savedFirstFields and: secondArray savedHashes: savedHashes
+ <inline: false>
+ "This is part of storeImageSegmentInto:outPointers:roots:."
+ self restoreObjectsIn: firstArray upTo: -1 savedFirstFields: savedFirstFields.
+ self restoreObjectsIn: secondArray savedHashes: savedHashes.
+ self runLeakCheckerFor: GCModeImageSegment.
+ self assert: self allObjectsUnmarked.
+ ^errCode!

Item was added:
+ ----- Method: SpurMemoryManager>>return:restoringObjectsIn:upTo:savedFirstFields: (in category 'image segment in/out') -----
+ return: errCode restoringObjectsIn: firstArray upTo: limitOrTag savedFirstFields: savedFirstFields
+ <inline: false>
+ "This is part of storeImageSegmentInto:outPointers:roots:."
+ self restoreObjectsIn: firstArray upTo: limitOrTag savedFirstFields: savedFirstFields.
+ self runLeakCheckerFor: GCModeImageSegment.
+ self assert: self allObjectsUnmarked.
+ ^errCode!

Item was removed:
- ----- Method: SpurMemoryManager>>return:restoringObjectsIn:upTo:savedFirstFields:and:savedHashes: (in category 'image segment in/out') -----
- return: errCode restoringObjectsIn: firstArray upTo: limitOrTag savedFirstFields: savedFirstFields and: secondArray savedHashes: secondSavedHashes
- "This is part of storeImageSegmentInto:outPointers:roots:."
- self restoreObjectsIn: firstArray upTo: limitOrTag savedFirstFields: savedFirstFields.
- self restoreObjectsIn: secondArray savedHashes: secondSavedHashes.
- self runLeakCheckerFor: GCModeImageSegment.
- self assert: self allObjectsUnmarked.
- ^errCode!

Item was changed:
  ----- Method: SpurMemoryManager>>setCheckForLeaks: (in category 'spur bootstrap') -----
  setCheckForLeaks: integerFlags
  " 0 = do nothing.
   1 = check for leaks on fullGC (GCModeFull).
   2 = check for leaks on scavenger (GCModeNewSpace).
   4 = check for leaks on incremental (GCModeIncremental)
+  8 = check for leaks on become (GCModeBecome)
+ 16 = check for leaks on image segments (GCModeImageSegment)"
-  8 = check for leaks on become
- 16 = check for leaks on image segments"
  checkForLeaks := integerFlags!

Item was changed:
  ----- Method: SpurMemoryManager>>storeImageSegmentInto:outPointers:roots: (in category 'image segment in/out') -----
  storeImageSegmentInto: segmentWordArrayArg outPointers: outPointerArrayArg roots: arrayOfRootsArg
  "This primitive is called from Squeak as...
  <imageSegment> storeSegmentFor: arrayOfRoots into: aWordArray outPointers: anArray.
 
  This primitive will store a binary image segment (in the same format as objects in the heap) of the
  set of objects in arrayOfObjects.  All pointers from within the set to objects outside the set will be
  copied into the array of outPointers.  In their place in the image segment will be an oop equal to the
  offset in the outPointer array (the first would be 8), but with the high bit set.
 
  Since Spur has a class table the load primitive must insert classes that have instances into the
  class table.  This primitive marks such classes using the isRemembered bit, which isn't meaningful
  as a remembered bit in the segment.
 
  The primitive expects the segmentWordArray and outPointerArray to be more than adequately long.
  In this case it returns normally, and truncates the two arrays to exactly the right size.
 
  The primitive can fail for the following reasons with the specified failure codes:
  PrimErrGenericError: the segmentWordArray is too small for the version stamp
  PrimErrWritePastObject: the segmentWordArray is too small to contain the reachable objects
  PrimErrBadIndex: the outPointerArray is too small
  PrimErrNoMemory: additional allocations failed
  PrimErrLimitExceeded: there is no room in the hash field to store out pointer indices or class references."
  <inline: false>
  | segmentWordArray outPointerArray arrayOfRoots
   arrayOfObjects savedFirstFields savedOutHashes segStart segAddr endSeg outIndex numClassesInSegment |
  ((self isObjImmutable: segmentWordArrayArg)
  or: [self isObjImmutable: outPointerArrayArg]) ifTrue:
  [^PrimErrNoModification].
  "Since segmentWordArrayArg & outPointerArrayArg may get shortened, they can't be pinned."
  ((self isPinned: segmentWordArrayArg)
  or: [self isPinned: outPointerArrayArg]) ifTrue:
  [^PrimErrObjectIsPinned].
  (self numSlotsOf: outPointerArrayArg) > self maxIdentityHash ifTrue:
  [^PrimErrLimitExceeded].
 
  self runLeakCheckerFor: GCModeImageSegment.
 
  "First scavenge to collect any new space garbage that refers to the graph."
  self scavengingGC.
  segmentWordArray := self updatePostScavenge: segmentWordArrayArg.
  outPointerArray := self updatePostScavenge: outPointerArrayArg.
  arrayOfRoots := self updatePostScavenge: arrayOfRootsArg.
 
  "Now compute the transitive closure, collecting the sequence of objects to be stored in the arrayOfObjects array.
  Included in arrayOfObjects are the arrayOfRoots and all its contents.  All objects have been unmarked."
  arrayOfObjects := self objectsReachableFromRoots: arrayOfRoots.
  arrayOfObjects ifNil:
  [^PrimErrNoMemory].
 
  self assert: self allObjectsUnmarked. "work to be done when the incremental GC is written"
 
  "Both to expand the max size of segment and to reduce the length of the
  load-time pass that adds classes to the class table, move classes to the
  front of arrayOfObjects, leaving the root array as the first element."
  numClassesInSegment := self moveClassesForwardsIn: arrayOfObjects.
 
  "The scheme is to copy the objects into segmentWordArray, and then map the oops in segmentWordArray.
  Therefore the primitive needs to both map efficiently originals to copies in segmentWordArray and
  be able to undo any side-effects if the primitive fails because either segmentWordArray or outPointerArray
  is too small.  The mapping is done by having the objects to be stored in arrayOfObjects refer to their mapped
  locations through their first field, just like a forwarding pointer, but without becoming a forwarder, saving their
  first field in savedFirstFields, and the objects in outPointerArray pointing to tehir locations in the outPointerArray
  through their identityHashes, saved in savedOutHashes.
  Since arrayOfObjects and its savedFirstFields, and outPointerArray and its saved hashes, can be enumerated
  side-by-side, the hashes can be restored to the originals.  So the hash of an object in arrayOfObjects
  is set to its offset in segmentWordArray / self allocationUnit, and the hash of an object in outPointerArray
  is set to its index in outPointerArray plus the top hash bit.  Oops in segmentWordArray are therefore
  mapped by accessing the original oop's identityHash, testing the bottom bit to distinguish between internal
  and external oops.  The saved hash arrays are initialized with an out-of-range hash value so that the first
  unused entry can be identified."
 
  savedFirstFields := self allocateSlots: (self numSlotsOf: arrayOfObjects)
  format: self wordIndexableFormat
  classIndex: self wordSizeClassIndexPun.
  savedOutHashes := self allocateSlots: (self numSlotsForBytes: (self numSlotsOf: outPointerArray) * 4)
  format: self firstLongFormat
  classIndex: self thirtyTwoBitLongsClassIndexPun.
  (savedFirstFields isNil or: [savedOutHashes isNil]) ifTrue:
  [self freeObject: arrayOfObjects.
  ^PrimErrNoMemory].
 
  self fillObj: savedFirstFields numSlots: (self numSlotsOf: savedFirstFields) with: 0.
  self fillObj: savedOutHashes numSlots: (self numSlotsOf: savedOutHashes) with: self savedOutHashFillValue.
 
  segAddr := segmentWordArray + self baseHeaderSize.
  endSeg := self addressAfter: segmentWordArray.
 
  "Write a version number for byte order and version check."
  segAddr >= endSeg ifTrue: [^PrimErrGenericFailure].
  self long32At: segAddr put: self imageSegmentVersion.
  self long32At: segAddr + 4 put: self imageSegmentVersion.
  segStart := segAddr := segAddr + self allocationUnit.
 
  "Copy all reachable objects to the segment, setting the marked bit for all objects (clones) in the segment,
  and the remembered bit for all classes (clones) in the segment."
  0 to: (self numSlotsOf: arrayOfObjects) - 1 do:
  [:i| | newSegAddrOrError objOop |
  "Check that classes in the segment are addressible.  Since the top bit of the hash field is used to tag
  classes external to the segment, the segment offset must not inadvertently set this bit.  This limit still
  allows for a million or more classes."
  (i = numClassesInSegment
  and: [segAddr - segStart / self allocationUnit + self lastClassIndexPun >= TopHashBit]) ifTrue:
  [^self return: PrimErrLimitExceeded
+ restoringObjectsIn: arrayOfObjects upTo: i savedFirstFields: savedFirstFields].
- restoringObjectsIn: arrayOfObjects upTo: i savedFirstFields: savedFirstFields
- and: outPointerArray savedHashes: savedOutHashes].
  objOop := self fetchPointer: i ofObject: arrayOfObjects.
  self deny: ((self isImmediate: objOop) or: [self isForwarded: objOop]).
+ newSegAddrOrError := self copyObj: objOop
+ toAddr: segAddr
+ startAt: segStart
+ stopAt: endSeg
+ savedFirstFields: savedFirstFields
+ index: i.
- newSegAddrOrError := self copyObj: objOop toAddr: segAddr startAt: segStart stopAt: endSeg savedFirstFields: savedFirstFields index: i.
  newSegAddrOrError < segStart ifTrue:
  [^self return: newSegAddrOrError
+ restoringObjectsIn: arrayOfObjects upTo: i savedFirstFields: savedFirstFields].
- restoringObjectsIn: arrayOfObjects upTo: i savedFirstFields: savedFirstFields
- and: outPointerArray savedHashes: savedOutHashes].
  segAddr := newSegAddrOrError].
 
  "Check that it can be safely shortened."
  (endSeg ~= segAddr
  and: [endSeg - segAddr < (self baseHeaderSize + self bytesPerOop)]) ifTrue:
  [^self return: PrimErrWritePastObject
+ restoringObjectsIn: arrayOfObjects upTo: -1 savedFirstFields: savedFirstFields].
- restoringObjectsIn: arrayOfObjects upTo: -1 savedFirstFields: savedFirstFields
- and: outPointerArray savedHashes: savedOutHashes].
 
  "Now scan, adding out pointers to the outPointersArray; all objects in arrayOfObjects
  have their first field pointing to the corresponding copy in segmentWordArray."
  (outIndex := self mapOopsFrom: segStart
  to: segAddr
  outPointers: outPointerArray
  outHashes: savedOutHashes) < 0 ifTrue: "no room in outPointers; fail"
  [^self return: PrimErrBadIndex
+ restoringObjectsIn: arrayOfObjects savedFirstFields: savedFirstFields
- restoringObjectsIn: arrayOfObjects upTo: -1 savedFirstFields: savedFirstFields
  and: outPointerArray savedHashes: savedOutHashes].
 
  "We're done.  Shorten the results, restore hashes and return."
  self shorten: segmentWordArray toIndexableSize: segAddr - (segmentWordArray + self baseHeaderSize) / 4.
  self shorten: outPointerArray toIndexableSize: outIndex.
  ^self return: PrimNoErr
+ restoringObjectsIn: arrayOfObjects savedFirstFields: savedFirstFields
- restoringObjectsIn: arrayOfObjects upTo: -1 savedFirstFields: savedFirstFields
  and: outPointerArray savedHashes: savedOutHashes!

Item was removed:
- ----- Method: SpurPlanningCompactorTests class>>imageNameForTests (in category 'accessing') -----
- imageNameForTests
- "self imageNameForTests"
- | baseImageName |
- baseImageName := 'core32-preen.image'.
- #('.' 'oscogvm/image' '../oscogvm/image') do:
- [:dirName|
- ((FileDirectory default directoryExists: dirName)
-  and: [(FileDirectory on: dirName) fileExists: baseImageName]) ifTrue:
- [^dirName, '/', baseImageName]].
- self error: 'cannot find ', baseImageName!

Item was changed:
  ----- Method: SpurPlanningCompactorTests class>>preenImage (in category 'utilities') -----
  preenImage
  "Assume there's a Pharo bootstrap core32.image in ../oscogvm/image/core32.image.
  We should find out where the image directory is and write a download script to get it.
+ But for now assume it's there.  See e.g.
+ https://bintray.com/pharo-project/pharo/Pharo/201701061402-32bit#files"
- But for now assume it's there."
  "[SpurPlanningCompactorTests preenImage] timeToRun"
  Spur32BitPreen new
  writeDefaultHeader: true;
  savedWindowSize: 640@480;
  preenImage: '../oscogvm/image/core32'!

Item was changed:
  ----- Method: SpurPlanningCompactorTests class>>resources (in category 'accessing') -----
  resources
+ ^{SpurImageTestResource}!
- ^{SpurPlanningCompactorTestsImageResource}!

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

Item was changed:
  ----- Method: SpurPlanningCompactorTests>>initializedVM (in category 'private') -----
  initializedVM
  | newVM |
  newVM := self resources anyOne current emptyVM cloneSimulation.
  newVM
+ openOn: SpurImageTestResource imageNameForTests extraMemory: 0;
- openOn: self class imageNameForTests extraMemory: 0;
  initStackPages.
  newVM objectMemory
  initializeMarkStack; "The Pharo bootstrap has no mark or weakling stacks :-)"
  initializeWeaklingStack.
  ^newVM!

Item was removed:
- TestResource subclass: #SpurPlanningCompactorTestsImageResource
- instanceVariableNames: 'emptyVM'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'VMMaker-Tests'!

Item was removed:
- ----- Method: SpurPlanningCompactorTestsImageResource>>emptyVM (in category 'accessing') -----
- emptyVM
- ^emptyVM ifNil:
- [emptyVM := StackInterpreterSimulator newWithOptions: #(ObjectMemory Spur32BitMemoryManager
-  compactorClass SpurPlanningCompactor)]!

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

Item was added:
+ ----- Method: SpurSegmentManager>>computeTotalHeapSizeIncludingBridges (in category 'simulation only') -----
+ computeTotalHeapSizeIncludingBridges
+ totalHeapSizeIncludingBridges := manager endOfMemory - manager oldSpaceStart!

Item was added:
+ SpurImageTestResource subclass: #SpurTrunkImageTestResource
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'VMMaker-Tests'!

Item was added:
+ ----- Method: SpurTrunkImageTestResource class>>baseImageName (in category 'accessing') -----
+ baseImageName
+ ^'trunk6-preen.image'!

Item was removed:
- ----- Method: StackInterpreterSimulatorTests class>>imageNameForTests (in category 'accessing') -----
- imageNameForTests
- "self imageNameForTests"
- | baseImageName |
- baseImageName := 'core32-preen.image'.
- #('.' 'oscogvm/image' '../oscogvm/image') do:
- [:dirName|
- ((FileDirectory default directoryExists: dirName)
-  and: [(FileDirectory on: dirName) fileExists: baseImageName]) ifTrue:
- [^dirName, '/', baseImageName]].
- self error: 'cannot find ', baseImageName!

Item was changed:
  ----- Method: StackInterpreterSimulatorTests>>testEmptySimulatorCloneCanLoadImage (in category 'tests') -----
  testEmptySimulatorCloneCanLoadImage
  self shouldnt:
  [(StackInterpreterSimulator newWithOptions: #(ObjectMemory Spur32BitMemoryManager))
  cloneSimulation
+ openOn: SpurImageTestResource imageNameForTests extraMemory: 0]
- openOn: self class imageNameForTests extraMemory: 0]
  raise: Error!

Item was changed:
  ----- Method: StackInterpreterSimulatorTests>>testSimulatorCanReloadImage (in category 'tests') -----
  testSimulatorCanReloadImage
  self shouldnt:
  [(StackInterpreterSimulator newWithOptions: #(ObjectMemory Spur32BitMemoryManager))
+ openOn: SpurImageTestResource imageNameForTests extraMemory: 0;
+ openOn: SpurImageTestResource imageNameForTests extraMemory: 0]
- openOn: self class imageNameForTests extraMemory: 0;
- openOn: self class imageNameForTests extraMemory: 0]
  raise: Error!