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

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

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

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

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

Name: VMMaker.oscog-eem.2253
Author: eem
Time: 11 July 2017, 8:06:14.601027 pm
UUID: 45202565-6d57-4e4b-812f-a8eea4685e21
Ancestors: VMMaker.oscog-eem.2252

Spur:
When laoding an object references to young outpointers would require remembering.  nstead, tenure anything in outPointers if segment is old.  To this end refactor cloneInOldSpaceForPinning: into cloneInOldSpace:forPinning:

Fix bug in forgetObject: when forgetting other than the first or last remembered object.

Update some comments and send halt to some error codes.

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

Item was changed:
  ----- Method: Spur32BitMMLESimulator>>loadImageSegmentFrom:outPointers: (in category 'image segment in/out') -----
  loadImageSegmentFrom: segmentWordArray outPointers: outPointerArray
  self leakCheckImageSegments ifTrue:
+ [parent ifNil:
+ [| result |
+ self halt.
+ result := coInterpreter cloneSimulation objectMemory loadImageSegmentFrom: segmentWordArray outPointers: outPointerArray.
+ Smalltalk garbageCollect]].
- [self halt].
  ^super loadImageSegmentFrom: segmentWordArray outPointers: outPointerArray!

Item was changed:
  ----- Method: SpurGenerationScavenger>>forgetObject: (in category 'gc - global') -----
  forgetObject: objOop
  "Forget the argument."
  self assert: rememberedSetSize > 0.
  self assert: (manager isRemembered: objOop).
  manager setIsRememberedOf: objOop to: false.
  objOop = (rememberedSet at: rememberedSetSize - 1) ifFalse:
  [| index |
  index := 0.
  [index < rememberedSetSize] whileTrue:
+ [objOop = (rememberedSet at: index)
+ ifTrue:
+ [rememberedSet at: index put: (rememberedSet at: rememberedSetSize - 1).
+ index := rememberedSetSize]
+ ifFalse: [index := index + 1]]].
- [objOop = (rememberedSet at: index) ifTrue:
- [rememberedSet at: index put: (rememberedSet at: rememberedSetSize - 1).
- index := rememberedSetSize]]].
  rememberedSetSize := rememberedSetSize - 1.
  self assert: rememberedSetSize >= 0!

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.
  [self oop: objOop isLessThan: 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:."
  classRef := self classIndexOf: objOop.
  classOop := (classRef anyMask: TopHashBit)
  ifTrue: [self fetchPointer: classRef - TopHashBit 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 cloneInOldSpace: objOop forPinning: true.
- 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 added:
+ ----- Method: SpurMemoryManager>>cloneInOldSpace:forPinning: (in category 'allocation') -----
+ cloneInOldSpace: objOop forPinning: forPinning
+ <inline: false>
+ | numSlots fmt newObj hash |
+ numSlots := self numSlotsOf: objOop.
+ fmt := self formatOf: objOop.
+
+ forPinning
+ ifTrue:
+ [newObj := self allocateSlotsForPinningInOldSpace: numSlots
+ bytes: (self objectBytesForSlots: numSlots)
+ format: fmt
+ classIndex: (self classIndexOf: objOop)]
+ ifFalse:
+ [newObj := self allocateSlotsInOldSpace: numSlots
+ bytes: (self objectBytesForSlots: numSlots)
+ format: fmt
+ classIndex: (self classIndexOf: objOop)].
+ newObj ifNil:
+ [^0].
+ (self isPointersFormat: fmt)
+ ifTrue:
+ [| hasYoung |
+ hasYoung := false.
+ 0 to: numSlots - 1 do:
+ [:i| | oop |
+ oop := self fetchPointer: i ofObject: objOop.
+ ((self isNonImmediate: oop)
+ and: [self isForwarded: oop]) ifTrue:
+ [oop := self followForwarded: oop].
+ ((self isNonImmediate: oop)
+ and: [self isYoungObject: oop]) ifTrue:
+ [hasYoung := true].
+ self storePointerUnchecked: i
+ ofObject: newObj
+ withValue: oop].
+ hasYoung ifTrue:
+ [scavenger remember: newObj]]
+ ifFalse:
+ [0 to: numSlots - 1 do:
+ [:i|
+ self storePointerUnchecked: i
+ ofObject: newObj
+ withValue: (self fetchPointer: i ofObject: objOop)].
+ fmt >= self firstCompiledMethodFormat ifTrue:
+ [coInterpreter maybeFixClonedCompiledMethod: newObj.
+ ((self isYoungObject: objOop) or: [self isRemembered: objOop]) ifTrue:
+ [scavenger remember: newObj]]].
+ (hash := self rawHashBitsOf: objOop) ~= 0 ifTrue:
+ [self setHashBitsOf: newObj to: hash].
+ ^newObj!

Item was removed:
- ----- Method: SpurMemoryManager>>cloneInOldSpaceForPinning: (in category 'allocation') -----
- cloneInOldSpaceForPinning: objOop
- | numSlots fmt newObj |
- numSlots := self numSlotsOf: objOop.
- fmt := self formatOf: objOop.
-
- newObj := self allocateSlotsForPinningInOldSpace: numSlots
- bytes: (self objectBytesForSlots: numSlots)
- format: fmt
- classIndex: (self classIndexOf: objOop).
- newObj ifNil:
- [^0].
- (self isPointersFormat: fmt)
- ifTrue:
- [| hasYoung |
- hasYoung := false.
- 0 to: numSlots - 1 do:
- [:i| | oop |
- oop := self fetchPointer: i ofObject: objOop.
- ((self isNonImmediate: oop)
- and: [self isForwarded: oop]) ifTrue:
- [oop := self followForwarded: oop].
- ((self isNonImmediate: oop)
- and: [self isYoungObject: oop]) ifTrue:
- [hasYoung := true].
- self storePointerUnchecked: i
- ofObject: newObj
- withValue: oop].
- hasYoung ifTrue:
- [scavenger remember: newObj]]
- ifFalse:
- [0 to: numSlots - 1 do:
- [:i|
- self storePointerUnchecked: i
- ofObject: newObj
- withValue: (self fetchPointer: i ofObject: objOop)].
- fmt >= self firstCompiledMethodFormat ifTrue:
- [coInterpreter maybeFixClonedCompiledMethod: newObj.
- ((self isYoungObject: objOop) or: [self isRemembered: objOop]) ifTrue:
- [scavenger remember: newObj]]].
- ^newObj!

Item was added:
+ ----- Method: SpurMemoryManager>>ensureNoNewObjectsIn: (in category 'image segment in/out') -----
+ ensureNoNewObjectsIn: outPointerArray
+ "This is part of loadImageSegmentFrom:outPointers:.
+ Since the reembered bit is currently used to identify classes in the segment, setting remembered bits
+ in new objects in the segment is difficult.  Instead simply arrange that there are no new objects in
+ outPointerArray, obviating the need to remember any of the loaded objects in the segment."
+ | scanClassTable |
+ (self isRemembered: outPointerArray) ifFalse: [^0].
+ scanClassTable := false.
+ 0 to: (self numSlotsOf: outPointerArray) - 1 do:
+ [:i| | oop clone hash |
+ oop := self fetchPointer: i ofObject: outPointerArray.
+ (self isYoung: oop) ifTrue:
+ [clone := self cloneInOldSpace: oop forPinning: false.
+ clone = 0 ifTrue:
+ [^PrimErrNoMemory halt].
+ ((hash := self rawHashBitsOf: oop) ~= 0
+  and: [(self classOrNilAtIndex: hash) = oop]) ifTrue:
+ [scanClassTable := true].
+ self forward: oop to: clone.
+ self storePointerUnchecked: i ofObject: outPointerArray withValue: clone]].
+ scavenger forgetObject: outPointerArray.
+ scanClassTable ifTrue:
+ [self postBecomeScanClassTable: BecamePointerObjectFlag].
+ ^0!

Item was changed:
  ----- Method: SpurMemoryManager>>enterClassesIntoClassTableFrom:to: (in category 'image segment in/out') -----
  enterClassesIntoClassTableFrom: segmentStart to: segmentLimit
    "This is part of loadImageSegmentFrom:outPointers:.
  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).
  [(self oop: objOop isLessThan: 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).
  [self oop: objOop isLessThan: oop] whileTrue:
  [self expungeFromClassTable: objOop.
  objOop := self objectAfter: objOop limit: segmentLimit].
+ ^errorCode halt].
- ^errorCode].
  objOop := self objectAfter: objOop limit: segmentLimit].
  ^0!

Item was changed:
  ----- Method: SpurMemoryManager>>is:outPointerClassHashFor:in:limit: (in category 'image segment in/out') -----
  is: hash outPointerClassHashFor: oop in: outPointerArray limit: outIndex
+ "This is part of storeImageSegmentInto:outPointers:roots:.
+ suspect; what about false positives?"
- "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>>isCopiedIntoSegment: (in category 'image segment in/out') -----
  isCopiedIntoSegment: anObjectInTheHeap
+ "This is part of storeImageSegmentInto:outPointers:roots:."
  <inline: true>
  ^self isMarked: anObjectInTheHeap!

Item was changed:
  ----- Method: SpurMemoryManager>>loadImageSegmentFrom:outPointers: (in category 'image segment in/out') -----
  loadImageSegmentFrom: segmentWordArray outPointers: outPointerArray
  "This primitive is called from Smalltalk 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 segmentWordArray will become an
  array of the loaded objects.  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?
 
  The primitive, if it succeeds, also becomes the segmentWordArray into the array of loaded objects.
  This allows fixing up of loaded objects directly, without nextObject, which Spur doesn't support."
 
  <inline: false>
  | segmentLimit segmentStart segVersion errorCode numLoadedObjects loadedObjectsArray |
 
  segmentLimit := self numSlotsOf: segmentWordArray.
  (self objectBytesForSlots: segmentLimit) < (self allocationUnit "version info" + self baseHeaderSize "one object header") ifTrue:
+ [^PrimErrBadArgument halt].
- [^PrimErrBadArgument].
 
  "Verify format.  If the format is wrong, word-swap (since ImageSegment data are 32-bit longs).
  If it is still wrong, undo the damage and fail."
  segVersion := self longAt: segmentWordArray + self baseHeaderSize.
  (coInterpreter readableFormat: (segVersion bitAnd: 16rFFFFFF "low 3 bytes")) ifFalse:
  [self reverseBytesIn32BitWordsFrom: segmentWordArray + self baseHeaderSize
  to: (self addressAfter: segmentWordArray).
  segVersion := self longAt: segmentWordArray + self baseHeaderSize.
  (coInterpreter readableFormat: (segVersion bitAnd: 16rFFFFFF "low 3 bytes")) ifFalse:
  [self reverseBytesIn32BitWordsFrom: segmentWordArray + self baseHeaderSize
  to: (self addressAfter: segmentWordArray).
+ ^PrimErrBadArgument halt]].
- ^PrimErrBadArgument]].
 
  segmentStart := segmentWordArray + self baseHeaderSize + self allocationUnit.
  segmentLimit := segmentLimit * self bytesPerOop + segmentWordArray + self baseHeaderSize.
 
  "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 >> 24 bitAnd: 16rFF) ~= (self imageSegmentVersion >> 24 bitAnd: 16rFF) ifTrue:
  "Reverse the byte-type objects once"
  [true
+ ifTrue: [^PrimErrBadArgument halt]
- ifTrue: [^PrimErrBadArgument]
  ifFalse:
  [self byteSwapByteObjectsFrom: (self objectStartingAt: segmentStart)
  to: segmentLimit
  flipFloatsIf: false]].
 
+ "Avoid having to remember by arranging that there are no young outPointers if segment is in old space."
+ (self isOldObject: segmentWordArray) ifTrue:
+ [errorCode := self ensureNoNewObjectsIn: 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."
  errorCode := self mapOopsAndValidateClassRefsFrom: segmentStart to: segmentLimit outPointers: outPointerArray.
  errorCode > 0 ifTrue:
  [^errorCode].
  numLoadedObjects := errorCode negated.
  loadedObjectsArray := self allocateSlots: numLoadedObjects format: self arrayFormat classIndex: ClassArrayCompactIndex.
  loadedObjectsArray ifNil:
+ [^PrimErrNoMemory halt].
- [^PrimErrNoMemory].
 
  "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].
 
  "Make a final pass, assigning class indices and/or pinning pinned objects and collecting the loaded objects in loadedObjectsArray"
  self assignClassIndicesAndPinFrom: segmentStart to: segmentLimit outPointers: outPointerArray filling: loadedObjectsArray.
 
  "Evaporate the container, leaving the newly loaded objects in place."
  (self hasOverflowHeader: segmentWordArray)
  ifTrue: [self rawOverflowSlotsOf: segmentWordArray put: self allocationUnit / self bytesPerOop]
  ifFalse: [self rawNumSlotsOf: segmentWordArray put: self allocationUnit / self bytesPerOop].
 
  "Finally forward the segmentWordArray to the loadedObjectsArray"
  self forward: segmentWordArray to: loadedObjectsArray.
 
  self runLeakCheckerFor: GCModeImageSegment.
 
  ^self objectStartingAt: segmentStart!

Item was changed:
  ----- Method: SpurMemoryManager>>markAsCopiedIntoSegment: (in category 'image segment in/out') -----
  markAsCopiedIntoSegment: anObjectInTheHeap
+ "This is part of storeImageSegmentInto:outPointers:roots:."
  <inline: true>
  self setIsMarkedOf: anObjectInTheHeap to: true!

Item was changed:
  ----- Method: SpurMemoryManager>>pinObject: (in category 'primitive support') -----
  pinObject: objOop
  "Attempt to pin objOop, which must not be immediate.
  If the attempt succeeds answer objOop's (possibly moved) oop.
  If the attempt fails, which can only occur if there is no memory, answer 0."
  <inline: false>
  | oldClone seg |
  <var: #seg type: #'SpurSegmentInfo *'>
  self assert: (self isNonImmediate: objOop).
  self flag: 'policy decision here. if already old, do we clone in a segment containing pinned objects or merely pin?'.
  "We choose to clone to keep pinned objects together to reduce fragmentation,
  if the object is not too large, assuming that pinning is rare and that fragmentation is a bad thing.
  Too large is defined as over 1mb.  The size of a 640x480x4 bitmap is 1228800."
  (self isOldObject: objOop) ifTrue:
  [(self numBytesOf: objOop) > (1024 * 1024) ifTrue:
  [self setIsPinnedOf: objOop to: true.
  ^objOop].
  seg := segmentManager segmentContainingObj: objOop.
  seg containsPinned ifTrue:
  [self setIsPinnedOf: objOop to: true.
  ^objOop].
  segmentManager someSegmentContainsPinned ifFalse:
  [self setIsPinnedOf: objOop to: true.
  seg containsPinned: true.
  ^objOop]].
+ oldClone := self cloneInOldSpace: objOop forPinning: true.
- oldClone := self cloneInOldSpaceForPinning: objOop.
  oldClone ~= 0 ifTrue:
  [becomeEffectsFlags := self becomeEffectFlagsFor: objOop.
  self setIsPinnedOf: oldClone to: true.
  self forward: objOop to: oldClone.
  self followSpecialObjectsOop.
  coInterpreter postBecomeAction: becomeEffectsFlags.
  self postBecomeScanClassTable: becomeEffectsFlags.
  becomeEffectsFlags := 0].
  ^oldClone!

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 |
  <var: 'segAddr' type: #usqInt>
  ((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.
  self deny: (self forwardersIn: outPointerArray).
  self deny: (self forwardersIn: arrayOfRoots).
 
  "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"
  self deny: (self forwardersIn: 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."
  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 their 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 first field of the heap object corresponding to
  an object in arrayOfObjects is set to its location in segmentWordArray, and the hash of an object in outPointerArray
  is set to its index in outPointerArray plus the top hash bit.  Classes in arrayOfObjects have their marked bit set.
  Oops in objects in segmentWordArray are therefore mapped by accessing the original oop, and following its first
  field. Class indices in segmentWordArray are mapped by fetching the original class, and testing its marked bit.
  If marked, the first field is followed to access the class copy in the segment.  Out pointers (objects and classes,
  which are unmarked), the object's identityHash is set (eek!!!!) to its index in the outPointerArray. So savedOutHashes
  parallels the outPointerArray. The saved hash array is 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.
 
+ self assert: arrayOfRoots = (self fetchPointer: 0 ofObject: arrayOfObjects).
+
  "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].
  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.
  (self oop: newSegAddrOrError isLessThan: segStart) ifTrue:
  [^self return: newSegAddrOrError
  restoringObjectsIn: arrayOfObjects upTo: i savedFirstFields: savedFirstFields].
  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].
 
  "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
  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
  and: outPointerArray savedHashes: savedOutHashes!

Loading...