The Trunk: System-eem.960.mcz

Eliot Miranda uploaded a new version of System to project The Trunk:
http://source.squeak.org/trunk/System-eem.960.mcz

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

Name: System-eem.960
Author: eem
Time: 11 July 2017, 5:07:17.753367 pm
UUID: 1462ebef-1d0c-43ad-b06c-097ac7105135
Ancestors: System-eem.959

Have ImageSegment>>loadSegmentFrom:outPointers: auto-select between legacy V3 and 32-bit Spur segments.  Support for loading 32-bit Spur segs on 64-bit and vice verse remains to be written.

Rewrite the space analysis code for the Spur image segment format.

Make the send of classOrganizersBeRoots: (an EToys extension) in NativeImageSegment>>smartFillRoots: an optional send.

=============== Diff against System-eem.959 ===============

Item was changed:
  ----- Method: ImageSegment>>loadSegmentFrom:outPointers: (in category 'read/write segment') -----
  loadSegmentFrom: segment outPointers: outPointers
  "Attempt to load the segment into memory (reify the objects in segment
  as real objects), using outPointers to bind references to objects not in the
  segment.  Answer a collection of all the objects in the segment."
+ | segmentFormat |
+ state == #imported ifTrue:
+ [segmentFormat := segment first bitAnd: 16rFFFFFF.
+ segmentFormat = 6502 ifTrue:
+ [LegacyImageSegment adoptInstance: self.
+ ^self loadSegmentFrom: segment outPointers: outPointers].
+ segmentFormat = Smalltalk imageFormatVersion ifTrue:
+ [NativeImageSegment adoptInstance: self.
+ ^self loadSegmentFrom: segment outPointers: outPointers].
+ self error: 'no handling for format ', segmentFormat asString. ' in a ', Smalltalk imageFormatVersion asString, ' image.'].
  self subclassResponsibility!

Item was removed:
- ----- Method: NativeImageSegment>>classNameAt: (in category 'statistics') -----
- classNameAt: index
- | ccIndex |
- self errorRewriteForSpur.
- ccIndex := self compactIndexAt: index.
- ccIndex = 0 ifFalse:[^(Smalltalk compactClassesArray at: ccIndex) name].
- ccIndex := segment at: index-1.
- (ccIndex bitAnd: 16r80000000) = 0 ifTrue:[
- "within segment; likely a user object"
- ^#UserObject].
- ccIndex := (ccIndex bitAnd: 16r7FFFFFFF) bitShift: -2.
- ^(outPointers at: ccIndex) name!

Item was removed:
- ----- Method: NativeImageSegment>>compactIndexAt: (in category 'compact classes') -----
- compactIndexAt: ind
- | word |
- "Look in this header word in the segment and find it's compact class index. *** Warning: When class ObjectMemory change, be sure to change it here. *** "
-
- ((word := segment at: ind) bitAnd: 3) = 2 ifTrue: [^ 0].  "free block"
- ^ (word >> 12) bitAnd: 16r1F "Compact Class field of header word"
- !

Item was added:
+ ----- Method: NativeImageSegment>>copyStatisticsDictionaryWithClassNames: (in category 'statistics') -----
+ copyStatisticsDictionaryWithClassNames: aDictionary
+ | d |
+ d := aDictionary copyEmpty.
+ aDictionary keysAndValuesDo:
+ [:classIndex :value|
+ d
+ at: ((classIndex anyMask: 16r200000) "TopHashBit = 16r200000, => in out pointers"
+ ifTrue: [(outPointers at: classIndex - 16r200000 + 1) name]
+ ifFalse: ['InSegmentClass', classIndex asString])
+ put: value].
+ ^d!

Item was changed:
  ----- Method: NativeImageSegment>>doSpaceAnalysis (in category 'statistics') -----
  doSpaceAnalysis
  "Capture statistics about the IS and print the number of instances per class and space usage"
+ | is64Bit index instCount instSpace |
- | index sz word hdrBits cc instCount instSpace |
- self errorRewriteForSpur.
  state == #activeCopy ifFalse:[self errorWrongState].
+ instCount := Dictionary new.
+ instSpace := Dictionary new.
+ is64Bit := ((segment at: 1) bitAnd: 16rFFFFFF) >= 68000.
+ index := 3. "skip version word"
+ "The Spur image format (in little endian format) is (num bits:fieldName(s)))
+ msb: | 8: numSlots | (on a byte boundary)
+ | 2 bits | (msb,lsb = {isMarked,?})
+ | 22: identityHash | (on a word boundary)
+ | 3 bits | (msb <-> lsb = {isGrey,isPinned,isRemembered}
+ | 5: format | (on a byte boundary)
+ | 2 bits | (msb,lsb = {isImmutable,?})
+ | 22: classIndex | (on a word boundary) : LSB"
+ [index > segment size] whileFalse:
+ [| hiWord loWord numSlots bytes classIndex |
+ loWord := segment at: index.
+ hiWord := segment at: index + 1.
+ numSlots := hiWord bitShift: -24.
+ numSlots = 255
+ ifTrue: "word is an overflow header word.  Slot count is in the least significant 56 bits."
+ [numSlots := hiWord = 0
+ ifTrue: [loWord]
+ ifFalse: [(hiWord bitShift: 32) + loWord bitAnd: 16rFFFFFFFFFFFFFF].
+ loWord := segment at: index + 2.
+ hiWord := segment at: index + 3.
+ bytes := 16] "two word header"
+ ifFalse:
+ [bytes := 8]. "one word header"
+ bytes := bytes + (8 * is64Bit "objects are a multiple of 8 bytes in length, with at leats one slot"
+ ifTrue: [numSlots max: 1]
+ ifFalse: [(numSlots max: 1) + 1 // 2]).
+ classIndex := loWord bitAnd: 16r3FFFFF.
+ (index > 3 or: [classIndex ~~ 33]) ifTrue: "Don't count the initial arrayOfRoots"
+ [instCount at: classIndex put: (instCount at: classIndex ifAbsent:[0]) + 1.
+  instSpace at: classIndex put: (instSpace at: classIndex ifAbsent:[0]) + bytes].
+ index := index + (bytes / 4)].
+ ^{instCount. instSpace} collect: [:dict| self copyStatisticsDictionaryWithClassNames: dict]!
- instCount := IdentityDictionary new.
- instSpace := IdentityDictionary new.
- index := 2. "skip version word, first object"
- "go past extra header words"
- hdrBits := (segment at: index) bitAnd: 3.
- hdrBits = 1 ifTrue: [index := index+1].
- hdrBits = 0 ifTrue: [index := index+2].
- [index > segment size] whileFalse:[
- hdrBits := (word := segment at: index) bitAnd: 3.
- hdrBits = 2 ifTrue:[sz := word bitAnd: 16rFFFFFFFC].
- hdrBits = 0 ifTrue:[sz := ((segment at: index-2) bitAnd: 16rFFFFFFFC) + 8].
- hdrBits = 1 ifTrue:[sz := (word bitAnd: "SizeMask" 252) + 4].
- hdrBits = 3 ifTrue:[sz := word bitAnd: "SizeMask" 252].
- hdrBits = 2
- ifTrue:[cc := #freeChunk]
- ifFalse:[cc := self classNameAt: index].
- instCount at: cc put: (instCount at: cc ifAbsent:[0]) + 1.
- instSpace at: cc put: (instSpace at: cc ifAbsent:[0]) + sz.
- index := self objectAfter: index].
- ^{instCount. instSpace}!

Item was removed:
- ----- Method: NativeImageSegment>>errorRewriteForSpur (in category 'error handling') -----
- errorRewriteForSpur
- self error: 'the method must be rewritten for Spur'!

Item was removed:
- ----- Method: NativeImageSegment>>objectAfter: (in category 'compact classes') -----
- objectAfter: ind
- "Return the object or free chunk immediately following the given object or free chunk in the segment.  *** Warning: When class ObjectMemory change, be sure to change it here. ***"
-
- | sz word newInd hdrBits |
- self errorRewriteForSpur.
- sz := ((word := segment at: ind "header") bitAnd: 3) = 2   "free block?"
- ifTrue: [word bitAnd: 16rFFFFFFFC]
- ifFalse: [(word bitAnd: 3) = 0 "HeaderTypeSizeAndClass"
- ifTrue: [(segment at: ind-2) bitAnd: 16rFFFFFFFC]
- ifFalse: [word bitAnd: "SizeMask" 252]].
-
- newInd := ind + (sz>>2).
- "adjust past extra header words"
- (hdrBits := (segment atPin: newInd) bitAnd: 3) = 3 ifTrue: [^ newInd].
- "If at end, header word will be garbage.  This is OK"
- hdrBits = 1 ifTrue: [^ newInd+1].
- hdrBits = 0 ifTrue: [^ newInd+2].
- ^ newInd "free"!

Item was changed:
  ----- Method: NativeImageSegment>>smartFillRoots: (in category 'read/write segment') -----
  smartFillRoots: dummy
  | refs known ours ww blockers |
  "Put all traced objects into my arrayOfRoots.  Remove some
  that want to be in outPointers.  Return blockers, an
  IdentityDictionary of objects to replace in outPointers."
 
  blockers := dummy blockers.
  known := (refs := dummy references) size.
  refs keys do: [:obj | "copy keys to be OK with removing items"
  (obj isSymbol) ifTrue: [refs removeKey: obj.  known := known-1].
  (obj class == PasteUpMorph) ifTrue: [
  obj isWorldMorph & (obj owner == nil) ifTrue: [
  (dummy project ~~ nil and: [obj == dummy project world]) ifFalse: [
  refs removeKey: obj.  known := known-1.
  blockers at: obj put:
  (StringMorph contents: 'The worldMorph of a different world')]]].
  "Make a ProjectViewMorph here"
  "obj class == Project ifTrue: [Transcript show: obj; cr]."
  (blockers includesKey: obj) ifTrue: [
  refs removeKey: obj ifAbsent: [known := known+1].  known := known-1].
  ].
  ours := dummy project ifNotNil: [dummy project world] ifNil: [ActiveWorld].
  refs keysDo: [:obj |
  obj isMorph ifTrue: [
  ww := obj world.
  (ww == ours) | (ww == nil) ifFalse: [
  refs removeKey: obj.  known := known-1.
  blockers at: obj put: (StringMorph contents:
  obj printString, ' from another world')]]].
  "keep original roots on the front of the list"
+ dummy rootObject do: [:rr | refs removeKey: rr ifAbsent: []].
+ (self respondsTo: #classOrganizersBeRoots:) ifTrue: "an EToys extension"
+ [self classOrganizersBeRoots: dummy].
+ ^dummy rootObject, refs keys asArray!
- (dummy rootObject) do: [:rr | refs removeKey: rr ifAbsent: []].
- self classOrganizersBeRoots: dummy.
- ^ dummy rootObject, refs fasterKeys asArray.!