[Vm-dev] VM Maker: VMMaker.oscog-eem.908.mcz
commits at source.squeak.org
commits at source.squeak.org
Thu Oct 23 19:13:53 UTC 2014
Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.908.mcz
==================== Summary ====================
Name: VMMaker.oscog-eem.908
Author: eem
Time: 23 October 2014, 12:11:14.104 pm
UUID: e256ea16-b97f-485e-a32f-49d4254845be
Ancestors: VMMaker.oscog-eem.907
Refactor the Spur image segment code into smaller
methods. Collect the classes in a segment at the
start of the seg, immediately following the root obj,
to ease postponing adding cxlasses in th seg to the
class table until after validation. Byte swap image
segments in the load primitive if required, as is
expected by the ImageSegment code.
Print slots of word objects in longPrintOop:
=============== Diff against VMMaker.oscog-eem.907 ===============
Item was added:
+ ----- Method: Spur32BitMMLECoSimulator>>loadImageSegmentFrom:outPointers: (in category 'image segment in/out') -----
+ loadImageSegmentFrom: segmentWordArray outPointers: outPointerArray
+ self leakCheckImageSegments ifTrue:
+ [self halt].
+ ^super loadImageSegmentFrom: segmentWordArray outPointers: outPointerArray!
Item was added:
+ ----- Method: Spur32BitMMLECoSimulator>>return:restoringObjectsIn:savedHashes:and:savedHashes: (in category 'image segment in/out') -----
+ return: errCode restoringObjectsIn: firstArray savedHashes: firstSavedHashes and: secondArray savedHashes: secondSavedHashes
+ self leakCheckImageSegments ifTrue:
+ [self halt]..
+ ^super return: errCode restoringObjectsIn: firstArray savedHashes: firstSavedHashes and: secondArray savedHashes: secondSavedHashes!
Item was added:
+ ----- Method: Spur32BitMMLECoSimulator>>storeImageSegmentInto:outPointers:roots: (in category 'image segment in/out') -----
+ storeImageSegmentInto: segmentWordArray outPointers: outPointerArray roots: arrayOfRoots
+ self leakCheckImageSegments ifTrue:
+ [self halt].
+ ^super storeImageSegmentInto: segmentWordArray outPointers: outPointerArray roots: arrayOfRoots!
Item was changed:
----- Method: Spur32BitMMLESimulator>>loadImageSegmentFrom:outPointers: (in category 'image segment in/out') -----
loadImageSegmentFrom: segmentWordArray outPointers: outPointerArray
+ self leakCheckImageSegments ifTrue:
+ [self halt].
- self halt.
^super loadImageSegmentFrom: segmentWordArray outPointers: outPointerArray!
Item was removed:
- ----- Method: Spur32BitMMLESimulator>>newOutPointer:at:in:hashes:topHashBit: (in category 'object access') -----
- newOutPointer: oop at: outIndex in: outPointerArray hashes: savedOutHashes topHashBit: topHashBit
- self halt.
- ^super newOutPointer: oop at: outIndex in: outPointerArray hashes: savedOutHashes topHashBit: topHashBit!
Item was added:
+ ----- Method: Spur32BitMMLESimulator>>return:restoringObjectsIn:savedHashes:and:savedHashes: (in category 'image segment in/out') -----
+ return: errCode restoringObjectsIn: firstArray savedHashes: firstSavedHashes and: secondArray savedHashes: secondSavedHashes
+ self leakCheckImageSegments ifTrue:
+ [self halt: errCode printString].
+ ^super return: errCode restoringObjectsIn: firstArray savedHashes: firstSavedHashes and: secondArray savedHashes: secondSavedHashes!
Item was added:
+ ----- Method: Spur32BitMMLESimulator>>storeImageSegmentInto:outPointers:roots: (in category 'image segment in/out') -----
+ storeImageSegmentInto: segmentWordArray outPointers: outPointerArray roots: arrayOfRoots
+ self leakCheckImageSegments ifTrue:
+ [self halt].
+ ^super storeImageSegmentInto: segmentWordArray outPointers: outPointerArray roots: arrayOfRoots!
Item was added:
+ ----- Method: SpurMemoryManager>>assignClassIndicesAndPinFrom:to:outPointers: (in category 'image segment in/out') -----
+ assignClassIndicesAndPinFrom: segmentStart to: segmentLimit outPointers: outPointerArray
+ "Make a final pass, assigning class indices and/or pinning pinned objects"
+ | objOop topHashBit |
+ topHashBit := 1 bitShift: self identityHashFieldWidth - 1.
+ objOop := self objectStartingAt: segmentStart.
+ [objOop < segmentLimit] whileTrue:
+ [| classRef classOop classIndex |
+ classRef := self classIndexOf: objOop.
+ classOop := (classRef anyMask: topHashBit)
+ ifTrue: [self fetchPointer: classRef - topHashBit ofObject: outPointerArray]
+ ifFalse: [classRef * 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: (in category 'image segment in/out') -----
copyObj: objOop toAddr: segAddr startAt: segStart stopAt: endSeg
"Copy objOop into the segment beginning at segAddr, and forward it to the copy.
+ 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.
- If it is a class in the class table, set the copy's hash to 0 for reassignment on load.
Answer the next segmentAddr if successful. Answer an appropriate error code if not"
"Copy the object..."
| bodySize copy hash newOop |
<inline: false>
bodySize := self bytesInObject: objOop.
(self oop: segAddr + bodySize isGreaterThanOrEqualTo: endSeg) ifTrue:
[^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)"
- "Clear remembered, mark bits of all headers copied into the segment"
self
setIsRememberedOf: copy to: false;
setIsMarkedOf: copy to: false.
+ "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."
- "If the object is a class, zero its identityHash (which is its classIndex).
- The class will be assigned a new hash 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].
- [self setHashBitsOf: copy to: 0].
newOop := copy - segStart / self allocationUnit.
newOop > self maxIdentityHash ifTrue:
[^PrimErrLimitExceeded].
self setHashBitsOf: objOop to: copy - segStart / self allocationUnit.
self setIsMarkedOf: objOop to: true.
"Answer the new end of segment"
^segAddr + bodySize!
Item was added:
+ ----- Method: SpurMemoryManager>>ensureHasOverflowHeader:forwardIfCloned: (in category 'image segment in/out') -----
+ ensureHasOverflowHeader: arrayArg forwardIfCloned: forwardIfCloned
+ "If arrayArg is too short to be truncated, clone it so that the clone is long enough.
+ Answer nil if it can't be cloned."
+ <inline: false>
+ (self hasOverflowHeader: arrayArg) ifTrue:
+ [^arrayArg].
+ ^(self
+ allocateSlots: self numSlotsMask + 1
+ format: (self formatOf: arrayArg)
+ classIndex: (self classIndexOf: arrayArg)) ifNotNil:
+ [:clonedArray|
+ self mem: clonedArray + self baseHeaderSize
+ cp: arrayArg + self baseHeaderSize
+ y: (self numSlotsOf: arrayArg) * self bytesPerOop.
+ (self isRemembered: arrayArg) ifTrue:
+ [scavenger remember: clonedArray].
+ forwardIfCloned ifTrue:
+ [self forward: arrayArg to: clonedArray].
+ clonedArray]!
Item was added:
+ ----- Method: SpurMemoryManager>>enterClassesIntoClassTableFrom:to: (in category 'image segment in/out') -----
+ enterClassesIntoClassTableFrom: segmentStart to: segmentLimit
+ "Scan for classes contained in the segment, entering them into the class table,
+ and clearing their isRemembered: bit. Classes are at the front, after the root
+ array and have the remembered bit set. If the attempt succeeds, answer 0,
+ otherwise remove all entered entries and answer an error code."
+ | objOop errorCode|
+ objOop := self objectAfter: (self objectStartingAt: segmentStart).
+ [objOop < segmentLimit
+ and: [self isRemembered: objOop]] whileTrue:
+ [self setIsRememberedOf: objOop to: false.
+ (errorCode := self enterIntoClassTable: objOop) ~= 0 ifTrue:
+ [| oop |
+ oop := objOop.
+ objOop := self objectAfter: (self objectStartingAt: segmentStart).
+ [objOop < oop] whileTrue:
+ [self expungeFromClassTable: objOop.
+ objOop := self objectAfter: objOop limit: segmentLimit].
+ ^errorCode].
+ objOop := self objectAfter: objOop limit: segmentLimit].
+ ^0!
Item was changed:
----- Method: SpurMemoryManager>>loadImageSegmentFrom:outPointers: (in category 'image segment in/out') -----
+ loadImageSegmentFrom: segmentWordArray outPointers: outPointerArray
- loadImageSegmentFrom: segmentWordArrayArg outPointers: outPointerArray
"This primitive is called from Squeak as...
<imageSegment> loadSegmentFrom: aWordArray outPointers: anArray."
"This primitive will load a binary image segment created by primitiveStoreImageSegment.
It expects the outPointer array to be of the proper size, and the wordArray to be well formed.
It will return as its value the original array of roots, and the erstwhile segmentWordArray will
have been truncated to a size of zero. If this primitive should fail, the segmentWordArray will,
sadly, have been reduced to an unrecognizable and unusable jumble. But what more could you
have done with it anyway?"
+ <inline: false>
+ | segmentLimit segmentStart segVersion errorCode |
"First thing is to verify format. If Spur is ever ported to big-endian machines then the segment
may have to be byte/word swapped, but so far it only runs on little-endian machines, so for now
just fail if endinanness is wrong."
+ segVersion := self longAt: segmentWordArray + self baseHeaderSize.
- <inline: false>
- | segmentWordArray firstNeedingPostProcessing numOutPointers objOop segLimit segStart segVersion topHashBit topOopBit |
- segVersion := self longAt: segmentWordArrayArg + self baseHeaderSize.
(coInterpreter readableFormat: (segVersion bitAnd: 16rFFFF "low 2 bytes")) ifFalse:
+ [self reverseBytesFrom: segmentWordArray + self baseHeaderSize
+ to: (self addressAfter: segmentWordArray).
+ segVersion := self longAt: segmentWordArray + self baseHeaderSize.
+ (coInterpreter readableFormat: (segVersion bitAnd: 16rFFFF "low 2 bytes")) ifFalse:
+ [self reverseBytesFrom: segmentWordArray + self baseHeaderSize
+ to: (self addressAfter: segmentWordArray).
+ ^PrimErrBadArgument]].
- [^PrimErrBadArgument].
+ segmentStart := segmentWordArray + self baseHeaderSize + self allocationUnit.
+ segmentLimit := (self numSlotsOf: segmentWordArray) * self bytesPerOop + segmentWordArray + self baseHeaderSize.
- "If segmentWordArrayArg is too short to be truncated, clone it so that the clone is long enough."
- (self hasOverflowHeader: segmentWordArrayArg)
- ifTrue:
- [segmentWordArray := segmentWordArrayArg]
- ifFalse:
- [segmentWordArray := self allocateSlots: self numSlotsMask + 1
- format: (self formatOf: segmentWordArrayArg)
- classIndex: (self classIndexOf: segmentWordArrayArg).
- segmentWordArray ifNil: [^PrimErrNoMemory].
- self mem: segmentWordArray + self baseHeaderSize
- cp: segmentWordArrayArg + self baseHeaderSize
- y: (self numSlotsOf: segmentWordArrayArg) * self bytesPerOop].
+ "Notionally reverse the Byte type objects if the data is from opposite endian machine.
+ Test top byte. $d on the Mac or $s on the PC. Rest of word is equal. If Spur is ever
+ ported to big-endian machines then the segment may have to be byte/word swapped,
+ but so far it only runs on little-endian machines, so for now just fail if endinanness is wrong."
+ self flag: #endianness.
+ (segVersion >> 16) ~= (self imageSegmentVersion >> 16) ifTrue:
+ "Reverse the byte-type objects once"
+ [true
+ ifTrue: [^PrimErrBadArgument]
+ ifFalse:
+ [self byteSwapByteObjectsFrom: (self objectStartingAt: segmentStart)
+ to: segmentLimit
+ flipFloatsIf: false]].
- segStart := segmentWordArray + self baseHeaderSize + self allocationUnit.
- segLimit := (self numSlotsOf: segmentWordArrayArg) * self bytesPerOop + segmentWordArray + self baseHeaderSize.
+ "scan through mapping oops and validating class references. Defer entering any
+ class objects into the class table and/or pinning objects until a second pass."
+ errorCode := self mapOopsAndValidateClassRefsFrom: segmentStart to: segmentLimit outPointers: outPointerArray.
+ errorCode ~= 0 ifTrue:
+ [^errorCode].
- "scan through mapping oops and validating class references.
- Defer entering any class objects into the class table and/or
- pinning objects until a second pass."
- numOutPointers := self numSlotsOf: outPointerArray.
- firstNeedingPostProcessing := 0.
- topHashBit := 1 bitShift: self identityHashFieldWidth - 1.
- topOopBit := 1 bitShift: self bytesPerOop * 8 - 1.
- objOop := self objectStartingAt: segStart.
- [objOop < segLimit] whileTrue:
- [| classIndex hash oop outPointer |
- ((self isRemembered: objOop) or: [self isMarked: objOop]) ifTrue:
- [^PrimErrInappropriate].
- (firstNeedingPostProcessing = 0
- and: [(self isInNewSpace: objOop)
- and: [self isPinned: objOop]]) ifTrue:
- [firstNeedingPostProcessing := objOop].
- classIndex := self classIndexOf: objOop.
- (classIndex anyMask: topHashBit)
- ifTrue:
- [classIndex - topHashBit >= numOutPointers ifTrue:
- [^PrimErrBadIndex].
- outPointer := self fetchPointer: classIndex - topHashBit ofObject: outPointerArray.
- hash := self rawHashBitsOf: outPointer.
- (hash > self lastClassIndexPun and: [(self classOrNilAtIndex: hash) = outPointer]) ifFalse:
- [^PrimErrInappropriate].
- self setClassIndexOf: objOop to: hash]
- ifFalse: "The class is contained within the segment."
- [(oop := classIndex * self allocationUnit + segStart) >= segLimit ifTrue:
- [^PrimErrBadIndex].
- (self rawHashBitsOf: oop) ~= 0 ifTrue:
- [^PrimErrInappropriate].
- self setIsRememberedOf: objOop to: true.
- "Don't populate the classTable until all oops have been mapped."
- firstNeedingPostProcessing = 0 ifTrue:
- [firstNeedingPostProcessing := objOop]].
- 0 to: (self numPointerSlotsOf: objOop) - 1 do:
- [:i|
- oop := self fetchPointer: i ofObject: objOop.
- (self isNonImmediate: oop) ifTrue:
- [(oop bitAnd: self allocationUnit - 1) ~= 0 ifTrue:
- [^PrimErrInappropriate].
- (oop anyMask: topOopBit)
- ifTrue:
- [oop / self bytesPerOop >= numOutPointers ifTrue:
- [^PrimErrBadIndex].
- outPointer := self fetchPointer: oop / self bytesPerOop ofObject: outPointerArray.
- self storePointerUnchecked: i ofObject: objOop withValue: outPointer]
- ifFalse:
- [oop + segStart >= segLimit ifTrue:
- [^PrimErrBadIndex].
- self storePointerUnchecked: i ofObject: objOop withValue: oop + segStart]]].
- objOop := self objectAfter: objOop limit: segLimit].
+ "Scan for classes contained in the segment, entering them into the class table.
+ Classes are at the front, after the root array and have the remembered bit set."
+ errorCode := self enterClassesIntoClassTableFrom: segmentStart to: segmentLimit.
+ errorCode ~= 0 ifTrue:
+ [^errorCode].
- "Scan for classes contained in the segment, entering them into
- the class table, and assigning the class indices of their instances."
- firstNeedingPostProcessing ~= 0 ifTrue:
- [objOop := firstNeedingPostProcessing.
- self assert: (self isRemembered: objOop).
- [objOop < segLimit] whileTrue:
- [(self isRemembered: objOop) ifTrue:
- [| classIndex hash oop errorCode |
- self setIsRememberedOf: objOop to: false.
- classIndex := self classIndexOf: objOop.
- self deny: (classIndex anyMask: topHashBit). "The class is contained within the segment."
- oop := classIndex * self allocationUnit + segStart.
- (hash := self rawHashBitsOf: oop) = 0 ifTrue: "The class needs to be added to the classTable"
- [(errorCode := self enterIntoClassTable: oop) ~= 0 ifTrue:
- [objOop := self objectStartingAt: segStart.
- [objOop < segLimit] whileTrue:
- [hash := self rawHashBitsOf: objOop.
- hash > self lastClassIndexPun and: [(self classOrNilAtIndex: hash) = objOop ifTrue:
- [self expungeFromClassTable: objOop].
- objOop := self objectAfter: objOop limit: segLimit]].
- ^errorCode].
- hash := self rawHashBitsOf: oop].
- self setClassIndexOf: objOop to: hash].
- ((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: segLimit]].
+ "Make a final pass, assigning class indices and/or pinning pinned objects"
+ self assignClassIndicesAndPinFrom: segmentStart to: segmentLimit outPointers: outPointerArray.
+
"Finally evaporate the container, leaving the newly loaded objects in place."
+ (self hasOverflowHeader: segmentWordArray)
+ ifTrue: [self setOverflowNumSlotsOf: segmentWordArray to: 0]
+ ifFalse: [self setRawNumSlotsOf: segmentWordArray to: 0].
- self setOverflowNumSlotsOf: segmentWordArray to: 0.
self leakCheckImageSegments ifTrue:
[self runLeakCheckerForFullGC: true].
+ ^self objectStartingAt: segmentStart!
- ^self objectStartingAt: segStart!
Item was added:
+ ----- Method: SpurMemoryManager>>mapOopsAndValidateClassRefsFrom:to:outPointers: (in category 'image segment in/out') -----
+ mapOopsAndValidateClassRefsFrom: segmentStart to: segmentLimit outPointers: outPointerArray
+ "scan through mapping oops and validating class references.
+ Defer entering any class objects into the class table and/or
+ pinning objects until a second pass."
+ | numOutPointers objOop topHashBit topOopBit |
+ numOutPointers := self numSlotsOf: outPointerArray.
+ topHashBit := 1 bitShift: self identityHashFieldWidth - 1.
+ topOopBit := 1 bitShift: self bytesPerOop * 8 - 1.
+ objOop := self objectStartingAt: segmentStart.
+ [objOop < segmentLimit] whileTrue:
+ [| classIndex hash oop mappedOop |
+ (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 - topHashBit >= numOutPointers ifTrue:
+ [^PrimErrBadIndex].
+ mappedOop := self fetchPointer: classIndex - topHashBit ofObject: outPointerArray.
+ hash := self rawHashBitsOf: mappedOop.
+ (hash > self lastClassIndexPun and: [(self classOrNilAtIndex: hash) = mappedOop]) ifFalse:
+ [^PrimErrInappropriate]]
+ ifFalse: "The class is contained within the segment."
+ [(oop := classIndex * self allocationUnit + segmentStart) >= segmentLimit ifTrue:
+ [^PrimErrBadIndex].
+ (self rawHashBitsOf: oop) ~= 0 ifTrue:
+ [^PrimErrInappropriate]].
+ 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].
+ mappedOop := self fetchPointer: oop ofObject: outPointerArray]
+ ifFalse:
+ [(oop bitAnd: self allocationUnit - 1) ~= 0 ifTrue:
+ [^PrimErrInappropriate].
+ (mappedOop := oop + segmentStart) >= segmentLimit ifTrue:
+ [^PrimErrBadIndex]].
+ self storePointerUnchecked: i ofObject: objOop withValue: mappedOop]].
+ objOop := self objectAfter: objOop limit: segmentLimit].
+ ^0!
Item was added:
+ ----- Method: SpurMemoryManager>>mapOopsFrom:to:outPointers:outHashes: (in category 'image segment in/out') -----
+ mapOopsFrom: segStart to: segAddr outPointers: outPointerArray outHashes: savedOutHashes
+ "Now scan, adding out pointers to the outPointersArray; all objects in arrayOfObjects
+ have their hashes set to point to their copies in segmentWordArray. Answer the outIndex
+ if the scan succeded, otherwise answer -1. It will fail if outPointers is too small."
+ | objOop outIndex topHashBit topOopBit |
+ outIndex := 0.
+ self fillObj: outPointerArray numSlots: (self numSlotsOf: outPointerArray) with: nilObj.
+ topHashBit := 1 bitShift: self identityHashFieldWidth - 1.
+ topOopBit := 1 bitShift: self bytesPerOop * 8 - 1.
+ objOop := self objectStartingAt: segStart.
+ [objOop < segAddr] whileTrue:
+ [| oop hash |
+ oop := self fetchClassOfNonImm: objOop.
+ (self isMarked: oop) ifFalse: "oop is a new outPointer; allocate its oop"
+ [outIndex := self newOutPointer: oop at: outIndex in: outPointerArray hashes: savedOutHashes topHashBit: topHashBit.
+ outIndex = 0 ifTrue:"no room in outPointers; fail"
+ [^-1]].
+ hash := self rawHashBitsOf: oop.
+ self setClassIndexOf: objOop to: hash.
+ 0 to: (self numPointerSlotsOf: objOop) - 1 do:
+ [:i|
+ oop := self fetchPointer: i ofObject: objOop.
+ (self isNonImmediate: oop) ifTrue:
+ [(self isMarked: oop) ifFalse: "oop is a new outPointer; allocate its oop"
+ [outIndex := self newOutPointer: oop at: outIndex in: outPointerArray hashes: savedOutHashes topHashBit: topHashBit.
+ outIndex = 0 ifTrue: "no room in outPointers; fail"
+ [^-1]].
+ oop := self mappedOopOf: oop topHashBit: topHashBit topOopBit: topOopBit..
+ self storePointerUnchecked: i ofObject: objOop withValue: oop]].
+ objOop := self objectAfter: objOop limit: segAddr].
+ ^outIndex!
Item was added:
+ ----- Method: SpurMemoryManager>>moveClassesForwardsIn: (in category 'image segment in/out') -----
+ moveClassesForwardsIn: arrayOfObjects
+ "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."
+ | there |
+ there := 0. "if > 0, this is the index of the first non-class past the first element."
+ 1 to: (self numSlotsOf: arrayOfObjects) - 1 do:
+ [:here| | objOop hash tempObjOop |
+ objOop := self fetchPointer: here ofObject: arrayOfObjects.
+ hash := self rawHashBitsOf: objOop.
+ (hash > self lastClassIndexPun and: [(self classOrNilAtIndex: hash) = objOop])
+ ifTrue:
+ [there > 0 ifTrue: "if there is zero we're in a run of classes at the start so don't move"
+ [tempObjOop := self fetchPointer: there ofObject: arrayOfObjects.
+ self storePointerUnchecked: there ofObject: arrayOfObjects withValue: objOop.
+ self storePointerUnchecked: here ofObject: arrayOfObjects withValue: tempObjOop.
+ there := there + 1]]
+ ifFalse:
+ [there = 0 ifTrue:
+ [there := here]]]!
Item was changed:
----- Method: SpurMemoryManager>>newOutPointer:at:in:hashes:topHashBit: (in category 'image segment in/out') -----
newOutPointer: oop at: outIndex in: outPointerArray hashes: savedOutHashes topHashBit: topHashBit
"oop is a new outPointer; allocate its oop, and answer the new outIndex.
If outPointerArray is full, answer 0."
<inline: true>
+ outIndex >= (self numSlotsOf: outPointerArray) ifTrue:
+ ["no room in outPointers; fail"
+ ^0].
- outIndex >= (self rawOverflowSlotsOf: outPointerArray) ifTrue:
- ["no room in outPointers; fail"
- ^0].
self storePointer: outIndex ofObject: outPointerArray withValue: oop.
self storeLong32: outIndex ofObject: savedOutHashes withValue: (self rawHashBitsOf: oop).
self setHashBitsOf: oop to: outIndex + topHashBit.
self setIsMarkedOf: oop to: true.
^outIndex + 1!
Item was changed:
----- Method: SpurMemoryManager>>objectsReachableFromRoots: (in category 'image segment in/out') -----
objectsReachableFromRoots: arrayOfRoots
"Answer an Array of all the objects only reachable from the argument, an Array of root objects,
starting with arrayOfRoots. If there is no space, answer a SmallInteger whose value is the
number of slots required. This is used to collect the objects to include in an image segment
on Spur, separate from creating the segment, hence simplifying the implementation.
Thanks to Igor Stasenko for this idea."
| freeChunk ptr start limit count oop objOop |
self assert: (self isArray: arrayOfRoots).
"Mark all objects except those only reachable from the arrayOfRoots by marking
each object in arrayOfRoots and then marking all reachable objects (from the
system roots). This leaves unmarked only objects reachable from the arrayOfRoots.
N.B. A side-effect of the marking is that all forwarders in arrayOfRoots will be followed."
self assert: self allObjectsUnmarked.
+ self markObjectsIn: arrayOfRoots.
- self setIsMarkedOf: arrayOfRoots to: true.
self markObjects: false.
"After the mark phase all unreachable weak slots will have been nilled
and all active ephemerons fired."
self assert: (self isEmptyObjStack: markStack).
self assert: (self isEmptyObjStack: weaklingStack).
self assert: self noUnscannedEphemerons.
"Use the largest free chunk to answer the result."
freeChunk := self allocateLargestFreeChunk.
ptr := start := freeChunk + self baseHeaderSize.
limit := self addressAfter: freeChunk.
count := 0.
"First put the roots; order is important."
self push: arrayOfRoots onObjStack: markStack.
+ 0 to: (self numSlotsOf: arrayOfRoots) - 1 do:
+ [:i|
+ oop := self fetchPointer: i ofObject: arrayOfRoots.
+ (self isNonImmediate: oop) ifTrue:
+ [self push: oop onObjStack: markStack]].
"Now collect the unmarked objects reachable from the roots."
[self isEmptyObjStack: markStack] whileFalse:
[objOop := self popObjStack: markStack.
count := count + 1.
ptr < limit ifTrue:
[self longAt: ptr put: objOop.
ptr := ptr + self bytesPerSlot].
oop := self fetchClassOfNonImm: objOop.
(self isMarked: oop) ifFalse:
[self setIsMarkedOf: objOop to: true.
self push: oop onObjStack: markStack].
0 to: (self numPointerSlotsOf: objOop) - 1 do:
[:i|
oop := self fetchPointer: i ofObject: objOop.
((self isImmediate: oop)
or: [self isMarked: oop]) ifFalse:
[self setIsMarkedOf: objOop to: true.
self push: oop onObjStack: markStack]]].
self unmarkAllObjects.
totalFreeOldSpace := totalFreeOldSpace - (self bytesInObject: freeChunk).
"Now try and allocate the result"
(count > (ptr - start / self bytesPerSlot) "not enough room"
or: [limit ~= ptr and: [limit - ptr <= self allocationUnit]]) ifTrue: "can't split a single word"
[self freeChunkWithBytes: (self bytesInObject: freeChunk) at: (self startOfObject: freeChunk).
self checkFreeSpace.
^self integerObjectOf: count].
"There's room; set the format, & classIndex and shorten."
self setFormatOf: freeChunk to: self arrayFormat.
self setClassIndexOf: freeChunk to: ClassArrayCompactIndex.
self shorten: freeChunk toIndexableSize: count.
self possibleRootStoreInto: freeChunk.
self checkFreeSpace.
self runLeakCheckerForFullGC: false.
^freeChunk!
Item was changed:
----- Method: SpurMemoryManager>>shorten:toIndexableSize: (in category 'allocation') -----
shorten: objOop toIndexableSize: indexableSize
"Reduce the number of indexable fields in objOop, a pointer object, to nSlots. Convert the
unused residual to a free chunk. Without changes to numSlotsForShortening:toIndexableSize:
this only works for arrayFormat and longFormat objects.
Answer the number of bytes returned to free memory, which may be zero if no change
was possible."
<inline: false>
| numSlots bytesBefore delta freeChunk |
numSlots := self numSlotsForShortening: objOop toIndexableSize: indexableSize.
numSlots = (self numSlotsOf: objOop) ifTrue:
[^0].
bytesBefore := self bytesInObject: objOop.
(self hasOverflowHeader: objOop)
ifTrue: [self rawOverflowSlotsOf: objOop put: numSlots]
ifFalse:
[self assert: numSlots < self numSlotsMask.
self rawNumSlotsOf: objOop put: numSlots].
delta := bytesBefore - (self bytesInObject: objOop).
+ "We have options.
+ 1. we can clone the object and forward to the clone.
+ 2. if the following object has a short header we can given it a large header."
+ self flag: 'deal with it, dude'.
+ delta <= self allocationUnit ifTrue:
+ [self error: 'shorten:toIndexableSize: attempted to shorten to allocationUnit!!'].
freeChunk := self initFreeChunkWithBytes: delta at: (self addressAfter: objOop).
(self isInOldSpace: objOop)
ifTrue:
[totalFreeOldSpace := totalFreeOldSpace + delta.
self addToFreeList: freeChunk bytes: delta]
ifFalse:
[self
setClassIndexOf: freeChunk to: self wordSizeClassIndexPun;
setFormatOf: freeChunk to: self firstLongFormat].
^delta!
Item was changed:
----- Method: SpurMemoryManager>>storeImageSegmentInto:outPointers:roots: (in category 'image segment in/out') -----
storeImageSegmentInto: segmentWordArray outPointers: outPointerArray roots: arrayOfRoots
"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 objercts 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 4). but with the high bit set.
+ Since Spur has a class table the load primitive must insert classes that have instances in 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.
- In this case it returns normally, and truncates the two arrays to exactly the right size. To simplify
- truncation, both incoming arrays are required to be whatever the objectMemory considers long
- objects. If either array is too small, the primitive will fail.
The primitive can fail for the following reasons with the specified failure codes:
PrimErrWritePastObject: the segmentWordArray is too small
PrimErrBadIndex: the outPointerArray is too small
PrimErrNoMemory: additional allocations failed
PrimErrLimitExceeded: there is no room in the hash field to store object oops."
<inline: false>
+ | arrayOfObjects savedInHashes savedOutHashes fillValue segStart segAddr endSeg outIndex |
- | arrayOfObjects savedInHashes savedOutHashes fillValue endSeg segAddr topHashBit objOop outIndex segStart topOopBit |
- (self hasOverflowHeader: segmentWordArray) ifFalse: "Must have 128-bit header"
- [^PrimErrWritePastObject].
- (self hasOverflowHeader: outPointerArray) ifFalse: "Must have 128-bit header"
- [^PrimErrBadIndex].
-
self leakCheckImageSegments ifTrue:
[self runLeakCheckerForFullGC: true].
"First compute the transitive closure, collecting the sequence of objects to be stored in the arrayOfObjects array."
arrayOfObjects := self objectsReachableFromRoots: arrayOfRoots.
arrayOfObjects ifNil:
[^PrimErrNoMemory].
+ self assert: self allObjectsUnmarked. "work to be done when the incremental GC is written"
+
-
"The scheme is to copy the objects into segmentWordArray, and then map the oops in sementWordArray.
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 sementWordArray or outPointerArray
is too small. The mapping is done by having the originals (either the objects in arrayOfObjects or the
objects in outPointerArray) refer to their mapped locations through their identityHash, and saving their
identityHashes in two ByteArrays, one that mirrors arrayOfObjects, and one that mirrors outPointerArray.
Since arrayOfObjects and its saved hashes, 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."
savedInHashes := self allocateSlots: (self numSlotsForBytes: (self numSlotsOf: arrayOfObjects) * 4)
format: self firstLongFormat
classIndex: self thirtyTwoBitLongsClassIndexPun.
savedOutHashes := self allocateSlots: (self numSlotsForBytes: (self numSlotsOf: outPointerArray) * 4)
format: self firstLongFormat
classIndex: self thirtyTwoBitLongsClassIndexPun.
(savedInHashes isNil or: [savedOutHashes isNil]) ifTrue:
+ [self freeObject: arrayOfObjects.
+ ^PrimErrNoMemory].
+
- [^PrimErrNoMemory].
fillValue := self wordSize = 4 ifTrue: [self maxIdentityHash + 1] ifFalse: [self maxIdentityHash + 1 << 32 + (self maxIdentityHash + 1)].
self fillObj: savedInHashes numSlots: (self numSlotsOf: savedInHashes) with: fillValue.
self fillObj: savedOutHashes numSlots: (self numSlotsOf: savedOutHashes) with: fillValue.
+ "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."
+ self moveClassesForwardsIn: arrayOfObjects.
+
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."
- self assert: self allObjectsUnmarked. "work to be done when the incremental GC is written"
-
0 to: (self numSlotsOf: arrayOfObjects) - 1 do:
+ [:i| | newSegAddrOrError objOop |
- [:i| | newSegAddrOrError |
objOop := self fetchPointer: i ofObject: arrayOfObjects.
self deny: ((self isImmediate: objOop) or: [self isForwarded: objOop]).
self storeLong32: i ofObject: savedInHashes withValue: (self rawHashBitsOf: objOop).
newSegAddrOrError := self copyObj: objOop toAddr: segAddr startAt: segStart stopAt: endSeg.
newSegAddrOrError < segStart ifTrue:
[^self return: newSegAddrOrError
restoringObjectsIn: arrayOfObjects savedHashes: savedInHashes
and: outPointerArray savedHashes: savedOutHashes].
segAddr := newSegAddrOrError].
+ "Check that it can be safely shortened."
(endSeg ~= segAddr
and: [endSeg - segAddr < (self baseHeaderSize + self bytesPerSlot)]) ifTrue:
[^self return: PrimErrWritePastObject
restoringObjectsIn: arrayOfObjects savedHashes: savedInHashes
and: outPointerArray savedHashes: savedOutHashes].
"Now scan, adding out pointers to the outPointersArray; all objects in arrayOfObjects
have their hashes set to point to their copies in segmentWordArray."
+ (outIndex := self mapOopsFrom: segStart
+ to: segAddr
+ outPointers: outPointerArray
+ outHashes: savedOutHashes) < 0 ifTrue: "no room in outPointers; fail"
+ [^self return: PrimErrBadIndex
+ restoringObjectsIn: arrayOfObjects savedHashes: savedInHashes
+ and: outPointerArray savedHashes: savedOutHashes].
- outIndex := 0.
- self fillObj: outPointerArray numSlots: (self numSlotsOf: outPointerArray) with: nilObj.
- topHashBit := 1 bitShift: self identityHashFieldWidth - 1.
- topOopBit := 1 bitShift: self bytesPerOop * 8 - 1.
- objOop := self objectStartingAt: segStart.
- [objOop < segAddr] whileTrue:
- [| oop hash |
- oop := self fetchClassOfNonImm: objOop.
- (self isMarked: oop) ifFalse: "oop is a new outPointer; allocate its oop"
- [outIndex := self newOutPointer: oop at: outIndex in: outPointerArray hashes: savedOutHashes topHashBit: topHashBit.
- outIndex = 0 ifTrue:"no room in outPointers; fail"
- [^self return: PrimErrBadIndex
- restoringObjectsIn: arrayOfObjects savedHashes: savedInHashes
- and: outPointerArray savedHashes: savedOutHashes]].
- hash := self rawHashBitsOf: oop.
- self setClassIndexOf: objOop to: hash.
- 0 to: (self numPointerSlotsOf: objOop) - 1 do:
- [:i|
- oop := self fetchPointer: i ofObject: objOop.
- (self isNonImmediate: oop) ifTrue:
- [(self isMarked: oop) ifFalse: "oop is a new outPointer; allocate its oop"
- [outIndex := self newOutPointer: oop at: outIndex in: outPointerArray hashes: savedOutHashes topHashBit: topHashBit.
- outIndex = 0 ifTrue: "no room in outPointers; fail"
- [^self return: PrimErrBadIndex
- restoringObjectsIn: arrayOfObjects savedHashes: savedInHashes
- and: outPointerArray savedHashes: savedOutHashes]].
- oop := self mappedOopOf: oop topHashBit: topHashBit topOopBit: topOopBit..
- self storePointerUnchecked: i ofObject: objOop withValue: oop]].
- objOop := self objectAfter: objOop limit: segAddr].
+ "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 savedHashes: savedInHashes
and: outPointerArray savedHashes: savedOutHashes!
Item was changed:
----- Method: StackInterpreter>>longPrintOop: (in category 'debug printing') -----
longPrintOop: oop
<api>
| fmt lastIndex startIP bytecodesPerLine column |
((objectMemory isImmediate: oop)
or: [(objectMemory addressCouldBeObj: oop) not
or: [(oop bitAnd: objectMemory allocationUnit - 1) ~= 0
or: [(objectMemory isFreeObject: oop)
or: [objectMemory isForwarded: oop]]]]) ifTrue:
[self printOop: oop.
^self].
self printHex: oop.
(objectMemory fetchClassOfNonImm: oop)
ifNil: [self print: ' has a nil class!!!!']
ifNotNil: [:class|
self print: ': a(n) '; printNameOfClass: class count: 5;
print: ' ('.
objectMemory hasSpurMemoryManagerAPI ifTrue:
[self printHexnp: (objectMemory compactClassIndexOf: oop); print: '=>'].
self printHexnp: class; print: ')'].
fmt := objectMemory formatOf: oop.
self print: ' format '; printHexnp: fmt.
fmt > objectMemory lastPointerFormat
ifTrue: [self print: ' nbytes '; printNum: (objectMemory numBytesOf: oop)]
ifFalse: [(objectMemory isIndexableFormat: fmt) ifTrue:
[| len |
len := objectMemory lengthOf: oop.
self print: ' size '; printNum: len - (objectMemory fixedFieldsOf: oop format: fmt length: len)]].
objectMemory printHeaderTypeOf: oop.
self print: ' hash '; printHexnp: (objectMemory rawHashBitsOf: oop).
self cr.
(fmt between: objectMemory firstByteFormat and: objectMemory firstCompiledMethodFormat - 1) ifTrue:
[^self printStringOf: oop; cr].
(fmt between: objectMemory firstLongFormat and: objectMemory firstByteFormat - 1) ifTrue:
+ [0 to: ((objectMemory num32BitUnitsOf: oop) min: 256) - 1 do:
+ [:i| | fieldOop |
+ fieldOop := objectMemory fetchLong32: i ofObject: oop.
+ self space; printNum: i - 1; space; printHex: fieldOop; space; cr].
+ ^self].
- [^self].
"this is nonsense. apologies."
startIP := (objectMemory lastPointerOf: oop) + BytesPerOop - objectMemory baseHeaderSize / BytesPerOop.
lastIndex := 256 min: startIP.
lastIndex > 0 ifTrue:
[1 to: lastIndex do:
[:i| | fieldOop |
fieldOop := objectMemory fetchPointer: i - 1 ofObject: oop.
self space; printNum: i - 1; space; printHex: fieldOop; space.
(i = 1 and: [objectMemory isCompiledMethod: oop])
ifTrue: [self printMethodHeaderOop: fieldOop]
ifFalse: [self cCode: [self printOopShort: fieldOop]
inSmalltalk: [self print: (self shortPrint: fieldOop)]].
self cr]].
(objectMemory isCompiledMethod: oop)
ifFalse:
[startIP > 64 ifTrue: [self print: '...'; cr]]
ifTrue:
[startIP := startIP * BytesPerWord + 1.
lastIndex := objectMemory lengthOf: oop.
lastIndex - startIP > 100 ifTrue:
[lastIndex := startIP + 100].
bytecodesPerLine := 8.
column := 1.
startIP to: lastIndex do:
[:index| | byte |
column = 1 ifTrue:
[self cCode: 'printf("0x%08x: ", oop+BaseHeaderSize+index-1)'
inSmalltalk: [self print: (oop+BaseHeaderSize+index-1) hex; print: ': ']].
byte := objectMemory fetchByte: index - 1 ofObject: oop.
self cCode: 'printf(" %02x/%-3d", byte,byte)'
inSmalltalk: [self space; print: (byte radix: 16); printChar: $/; printNum: byte].
column := column + 1.
column > bytecodesPerLine ifTrue:
[column := 1. self cr]].
column = 1 ifFalse:
[self cr]]!
More information about the Vm-dev
mailing list