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.!