hg/stx-libtool2: comparison SnapShotImageMemory.st

equal deleted inserted replaced

-:bbbb798caa45
+:5a5e9b9b5138
 "{ Package: 'stx:libtool2' }"
 Object subclass:#SnapShotImageMemory
 	instanceVariableNames:'image stream msb ptrSize intSize intTag spaceInfos symbolEntries
-		globalEntries addrToObjectMapping'
+		globalEntries addrToObjectMapping fetchINT hdrSize'
 	classVariableNames:''
 	poolDictionaries:''
 	category:'System-Support'
 !
 !
 fetchClassObjectAt:baseAddr
 |addr classPtr size bits o classRef nInsts|
-(baseAddr bitAnd:3) ~~ 0 ifTrue:[self halt].
+(baseAddr bitAnd:ptrSize-1) ~~ 0 ifTrue:[self halt].
 o := addrToObjectMapping at:(baseAddr bitShift:-2) ifAbsent:nil.
 o notNil ifTrue:[^ o].
 addr := baseAddr.
 classPtr := self fetchPointerAt:addr.
 addr := addr + ptrSize.
-size := self fetchUnboxedIntegerAt:addr.
+size := self fetchUnboxedInteger4At:addr.
-addr := addr + ptrSize.
+addr := addr + 4.
-bits := self fetchUnboxedIntegerAt:addr.
+bits := self fetchUnboxedInteger4At:addr.
-addr := addr + ptrSize.
+addr := addr + 4.
-nInsts := (size - (intSize * 3 "headerSize")) // intSize.
+nInsts := (size - hdrSize) // intSize.
 o := ImageClassObject new:nInsts.
 o memory:self.
 o address:baseAddr.
 addrToObjectMapping at:(baseAddr bitShift:-2) put:o.
 (self class isPointerOOP:classPtr) ifFalse:[
 self halt
 ].
-size > 8000 ifTrue:[self halt].
+"/ size > 8000 ifTrue:[self halt].
 o byteSize:size.
 o bits:bits.
 1 to:nInsts do:[:idx |
-o at:idx put:(self fetchUnboxedIntegerAt:addr).
+o at:idx put:(fetchINT value).
 "/        o at:idx put:(self fetchObjectAt:(self fetchUnboxedIntegerAt:addr)).
 addr := addr + ptrSize.
 ].
 classRef := self fetchClassObjectAt:classPtr.
 ^ o
 !
 fetchObjectAt:baseAddr
-|addr classPtr classRef size bits o nBytes nInsts flags indexTypeFlags imgAddr
+|addr classPtr classRef size bits o nBytes nInsts flags indexTypeFlags imgAddr|
-|
 baseAddr == 0 ifTrue:[^ nil].
 (baseAddr bitAnd:1) == 1 ifTrue:[
-(baseAddr bitTest:16r80000000) ifTrue:[
+"/ sign extent integer
-^ (baseAddr - 16r100000000) bitShift32:-1
+ptrSize == 8 ifTrue:[
-] ifFalse:[
+(baseAddr bitTest:16r8000000000000000) ifTrue:[
+^ (baseAddr - 16r10000000000000000) bitShift:-1
+].
+^ baseAddr bitShift:-1
+] ifFalse:[
+(baseAddr bitTest:16r80000000) ifTrue:[
+^ (baseAddr - 16r100000000) bitShift32:-1
+].
 ^ baseAddr bitShift32:-1
-]
+].
 ].
-(baseAddr bitAnd:3) ~~ 0 ifTrue:[self halt].
+(baseAddr bitAnd:ptrSize-1) ~~ 0 ifTrue:[self halt].
 o := addrToObjectMapping at:(baseAddr bitShift:-2) ifAbsent:nil.
 o notNil ifTrue:[^ o].
 addr := baseAddr.
 classPtr := self fetchPointerAt:addr.
 addr := addr + ptrSize.
-size := self fetchUnboxedIntegerAt:addr.
+size := self fetchUnboxedInteger4At:addr.
-addr := addr + ptrSize.
+addr := addr + 4.
-bits := self fetchUnboxedIntegerAt:addr.
+bits := self fetchUnboxedInteger4At:addr.
-addr := addr + ptrSize.
+addr := addr + 4.
 (self class isPointerOOP:classPtr) ifFalse:[
 self halt
 ].
 classRef := self fetchClassObjectAt:classPtr.
+imgAddr := self imageAddressOf:addr.
+stream position:imgAddr.
 flags := classRef flags.
 indexTypeFlags := flags bitAnd:Behavior maskIndexType.
 (indexTypeFlags = Behavior flagBytes) ifTrue:[
-nBytes := (size - (intSize * 3)).
+nBytes := (size - hdrSize).
 o := ImageByteObject new:nBytes.
 o memory:self.
 o address:baseAddr.
 o classRef:classRef.
 "/ size > 8000 ifTrue:[self halt].
 o byteSize:size.
 o bits:bits.
 addrToObjectMapping at:(baseAddr bitShift:-2) put:o.
-imgAddr := self imageAddressOf:addr.
-stream position:imgAddr.
 1 to:nBytes do:[:idx |
 o at:idx put:(stream next).
 addr := addr + 1.
 ].
 self halt
 ]
 ].
 ].
-nInsts := (size - (intSize * 3)) // intSize.
+nInsts := (size - hdrSize) // intSize.
 (flags bitTest:Behavior flagBehavior)
 "/ classRef isImageBehavior
 ifTrue:[
 o := ImageClassObject new:nInsts.
 ] ifFalse:[
 o byteSize:size.
 o bits:bits.
 addrToObjectMapping at:(baseAddr bitShift:-2) put:o.
 1 to:nInsts do:[:idx |
-o at:idx put:(self fetchUnboxedIntegerAt:addr).
+o at:idx put:(fetchINT value).
 "/            o at:idx put:(self fetchObjectAt:(self fetchUnboxedIntegerAt:addr)).
 addr := addr + ptrSize.
 ]
 ].
 ^ o
 fetchPointerAt:addr
 ^ self fetchUnboxedIntegerAt:addr
 !
-fetchUnboxedIntegerAt:addr
+fetchUnboxedInteger4At:addr
 |ptr imgAddr|
-(addr bitAnd:3) ~~ 0 ifTrue:[self halt].
+(addr bitAnd:(4-1)) ~~ 0 ifTrue:[self halt].
 imgAddr := self imageAddressOf:addr.
 stream position:imgAddr.
 ptr := stream nextUnsignedLongMSB:msb.
+^ ptr
+!
+fetchUnboxedIntegerAt:addr
+|ptr imgAddr|
+(addr bitAnd:(ptrSize-1)) ~~ 0 ifTrue:[self halt].
+imgAddr := self imageAddressOf:addr.
+stream position:imgAddr.
+ptr := fetchINT value.
 ^ ptr
 !
 imageAddressOf:addr
 spaceInfos do:[:eachSpace |
 fetchByteArrayFor:aByteArrayRef
 |nBytes|
 (aByteArrayRef isImageBytes) ifFalse:[self halt].
-nBytes := aByteArrayRef byteSize - (intSize * 3).
+nBytes := aByteArrayRef byteSize - hdrSize.
 ^ ((ByteArray new:nBytes) replaceFrom:1 to:nBytes-1 with:aByteArrayRef startingAt:1).
 !
 fetchStringFor:aStringRef
 |nBytes|
 (aStringRef isImageBytes) ifFalse:[self halt].
-nBytes := aStringRef byteSize - (intSize * 3).
+nBytes := aStringRef byteSize - hdrSize.
-^ ((ByteArray new:nBytes-1) replaceFrom:1 to:nBytes-1 with:aStringRef startingAt:1) asString.
+^ ((ByteArray new:nBytes-1)
+replaceFrom:1 to:nBytes-1 with:aStringRef startingAt:1) asString.
 !
 for:aFilename
 stream := aFilename asFilename readStream binary.
 addrToObjectMapping := IdentityDictionary new.
 printStringOfClass:aClassRef
 |nameSlot|
 (aClassRef isImageBehavior) ifFalse:[self halt].
-((aClassRef byteSize // intSize) - 3) < Class instSize ifTrue:[self halt.].
+((aClassRef byteSize - hdrSize) // intSize) < Class instSize ifTrue:[self halt.].
 nameSlot := aClassRef nameSlot.
 nameSlot isInteger ifTrue:[
 nameSlot := self fetchObjectAt:nameSlot
 ].
 (aStringRef isString) ifFalse:[self halt].
 ^ self fetchStringFor:aStringRef.
 !
 printStringOfSymbol:aSymbolRef
-|nBytes|
 (aSymbolRef isImageSymbol) ifFalse:[self halt].
 ^ self fetchStringFor:aSymbolRef.
-"/    nBytes := aSymbolRef size - (intSize * 3).
-"/    ^ ((ByteArray new:nBytes-1) replaceFrom:1 to:nBytes-1 with:aSymbolRef startingAt:1) asString.
 !
 readGlobalEntries
 |refPointer theSymbolPtr theSymbolRef theValuePtr theValueRef pos|
 globalEntries := OrderedCollection new.
 [
-refPointer := stream nextUnsignedLongMSB:msb.
+refPointer := fetchINT value.
-theSymbolPtr := stream nextUnsignedLongMSB:msb.
+theSymbolPtr := fetchINT value.
-theValuePtr := stream nextUnsignedLongMSB:msb.
+theValuePtr := fetchINT value.
 theSymbolPtr ~~ 0
 ] whileTrue:[
 globalEntries add:(theSymbolPtr -> theValuePtr).
 ].
 globalEntries := globalEntries asArray.
 stream position:pos.
 !
 readHeader
 "
-(self for:'stmeas.img') readHeader
+(self for:'st.img') readHeader
 (self for:'crash.img') readHeader
 "
 |order magic version timeStamp snapID last_util_addr hiText_addr flags
 lowData hiData charSlots charTableSlots fixMemStart fixMemEnd
 ].
 version := stream nextUnsignedLongMSB:msb.
 timeStamp := stream nextUnsignedLongMSB:msb.
 ptrSize := stream nextByte.
 ptrSize ~~ 4 ifTrue:[
-self error:'unhandled ptr format'
+ptrSize ~~ 8 ifTrue:[
+self error:'unhandled ptr format'
+].
 ].
 stream next:7.    "/ filler
 intSize := stream nextUnsignedLongMSB:msb.
-intSize == 9 ifTrue:[
+intSize == 9 "encoded as SmallInteger; i.e. with tag" ifTrue:[
 intSize := 4.
 intTag := 1.
 ] ifFalse:[
-self error:'unhandled int format'
+intSize == 17 "encoded as SmallInteger; i.e. with tag" ifTrue:[
-].
+intSize := 8.
+intTag := 1.
+] ifFalse:[
+self error:'unhandled int format'
+].
+].
+hdrSize := ptrSize + 4 + 4.
+intSize == 4 ifTrue:[
+fetchINT := [stream nextUnsignedLongMSB:msb]
+] ifFalse:[
+fetchINT := [stream nextUnsignedHyperMSB:msb]
+].
 snapID := stream nextUnsignedLongMSB:msb.
-last_util_addr := stream next:intSize.
+intSize == 8 ifTrue:[
-hiText_addr := stream next:intSize.
+"/ sigh - align for 8byte
-flags := stream next:intSize.
+stream next:4
-stream next:8.    "/ info, debug & filler
+].
+last_util_addr := fetchINT value.
-lowData := stream nextUnsignedLongMSB:msb.
+hiText_addr := fetchINT value.
-hiData := stream nextUnsignedLongMSB:msb.
+flags := fetchINT value.
+"infoPrinting :=" stream next.
-charSlots := stream nextUnsignedLongMSB:msb.
+"debugPrinting :=" stream next.
-charTableSlots := stream nextUnsignedLongMSB:msb.
+stream next:6.    "/ filler
+lowData := fetchINT value.
+hiData := fetchINT value.
+charSlots := fetchINT value.
+charTableSlots := fetchINT value.
 version >= 8 ifTrue:[
-fixMemStart := stream nextUnsignedLongMSB:msb.
+fixMemStart := fetchINT value.
-fixMemEnd := stream nextUnsignedLongMSB:msb.
+fixMemEnd := fetchINT value.
-symMemStart := stream nextUnsignedLongMSB:msb.
+symMemStart := fetchINT value.
-symMemEnd := stream nextUnsignedLongMSB:msb.
+symMemEnd := fetchINT value.
-vmDataAddr := stream nextUnsignedLongMSB:msb.
+vmDataAddr := fetchINT value.
 ].
 stream next:(128 * intSize).    "/ skip sharedMethodCode ptrs
 stream next:(128 * intSize).    "/ skip sharedBlockCode ptrs
-nContexts := stream nextUnsignedLongMSB:msb.
+nContexts := fetchINT value.
-contextSpace := stream nextUnsignedLongMSB:msb.
+contextSpace := fetchINT value.
-nRegistered := stream nextUnsignedLongMSB:msb.
+nRegistered := fetchINT value.
 version >= 8 ifTrue:[
 version >= 9 ifTrue:[
-symbolsSeqNr := stream nextUnsignedLongMSB:msb.
+symbolsSeqNr := fetchINT value.
 version >= 10 ifTrue:[
-numCharSlots := stream nextUnsignedLongMSB:msb.
+numCharSlots := fetchINT value.
 stream next:(intSize * 30).
 ] ifFalse:[
 stream next:(intSize * 31).
 ].
 ] ifFalse:[
 stream next:(intSize * 32).
 ]
 ].
-nSpaces := stream nextUnsignedLongMSB:msb.
+nSpaces := fetchINT value.
 spaceInfos := (1 to:nSpaces) collect:[:idx | SpaceInfo new].
 1 to:nSpaces do:[:i |
-(spaceInfos at:i) flags:(stream nextUnsignedLongMSB:msb).
+(spaceInfos at:i) flags:(fetchINT value).
 ].
-nSpaces+1 to:32 do:[:i | stream nextUnsignedLongMSB:msb].
+nSpaces+1 to:32 do:[:i | fetchINT value].
 1 to:nSpaces do:[:i |
-(spaceInfos at:i) start:(stream nextUnsignedLongMSB:msb).
+(spaceInfos at:i) start:(fetchINT value).
 ].
-nSpaces+1 to:32 do:[:i | stream nextUnsignedLongMSB:msb].
+nSpaces+1 to:32 do:[:i | fetchINT value].
 1 to:nSpaces do:[:i |
-(spaceInfos at:i) size:(stream nextUnsignedLongMSB:msb).
+(spaceInfos at:i) size:(fetchINT value).
 ].
-nSpaces+1 to:32 do:[:i | stream nextUnsignedLongMSB:msb].
+nSpaces+1 to:32 do:[:i | fetchINT value].
 version >= 8 ifTrue:[
 stream reset.
 stream skip:4096.
 ].
 |className flags moduleTimestamp signature nMethods nBlocks oldLitRefs nLitRefs
 oldConstTable nConsts|
 className := (stream next:classNameSize) asString.
 stream next. "/ 0-byte
-flags := stream nextUnsignedLongMSB:msb.
+flags := fetchINT value.
-moduleTimestamp := stream nextUnsignedLongMSB:msb.
+moduleTimestamp := fetchINT value.
-signature := stream nextUnsignedLongMSB:msb.
+signature := fetchINT value.
 nMethods := stream nextUnsignedLongMSB:msb.
-nMethods timesRepeat:[ stream nextUnsignedLongMSB:msb ].
+nMethods timesRepeat:[ fetchINT value ].
 nBlocks := stream nextUnsignedLongMSB:msb.
-nBlocks timesRepeat:[ stream nextUnsignedLongMSB:msb ].
+nBlocks timesRepeat:[ fetchINT value ].
-oldLitRefs := stream nextUnsignedLongMSB:msb.
+oldLitRefs := fetchINT value.
 nLitRefs := stream nextUnsignedLongMSB:msb.
-nLitRefs timesRepeat:[ stream nextUnsignedLongMSB:msb ].
+nLitRefs timesRepeat:[ fetchINT value ].
-stream nextUnsignedLongMSB:msb. "/ 0-litRef
+fetchINT value. "/ 0-litRef
-oldConstTable := stream nextUnsignedLongMSB:msb.
+oldConstTable := fetchINT value.
 nConsts := stream nextLongMSB:msb.
 nConsts > 0 ifTrue:[
-nConsts timesRepeat:[ stream nextUnsignedLongMSB:msb ].
+nConsts timesRepeat:[ fetchINT value ].
-]
+].
-"/ Transcript showCR:className.
+"/            Transcript show:className;
+"/                    show:' nconsts:'; show:nConsts;
+"/                    show:' nlits:'; show:nLitRefs;
+"/                    show:' nMethods:'; show:nMethods;
+"/                    show:' nBlocks:'; showCR:nBlocks.
 ].
 !
 readSymbolEntries
 |refPointer theSymbolPtr theSymbolRef pos|
 symbolEntries := OrderedCollection new.
 [
-refPointer := stream nextUnsignedLongMSB:msb.
+refPointer := fetchINT value.
-theSymbolPtr := stream nextUnsignedLongMSB:msb.
+theSymbolPtr := fetchINT value.
 theSymbolPtr ~~ 0
 ] whileTrue:[
 symbolEntries add:theSymbolPtr.
 ].
 symbolEntries := symbolEntries asArray.
 pos := stream position.
-symbolEntries := symbolEntries collect:[:theSymbolPtr |
+1 to:symbolEntries size do:[:i |
+|theSymbolPtr|
+"/ an inlined collect, to avoid allocating big array twice.
+theSymbolPtr := symbolEntries at:i.
 theSymbolRef := self fetchObjectAt:theSymbolPtr.
 theSymbolRef isImageSymbol ifFalse:[
 self halt
 ].
+symbolEntries at:i put:theSymbolRef.
 ].
 stream position:pos
 !
 readUGlobalEntries
 |refPointer theValue|
 [
-refPointer := stream nextUnsignedLongMSB:msb.
+refPointer := fetchINT value.
-theValue := stream nextUnsignedLongMSB:msb.
+theValue := fetchINT value.
 refPointer ~~ 0
 ] whileTrue
+! !
+!SnapShotImageMemory methodsFor:'queries'!
+metaClassByteSize
+^ Metaclass instSize * ptrSize + hdrSize
+!
+privateMetaClassByteSize
+^ PrivateMetaclass instSize * ptrSize + hdrSize
 ! !
 !SnapShotImageMemory::ImageHeader methodsFor:'accessing'!
 address:something
 comment := memory fetchStringFor:commentRef.
 ].
 ^ comment
 !
+commentOrDocumentationString
+"the classes documentation-method's comment, its plain
+comment or nil"
+|cls m s|
+cls := self theNonMetaclass.
+m := cls theMetaclass compiledMethodAt:#documentation.
+m notNil ifTrue:[
+"/ try documentation method's comment
+s := m comment.
+] ifFalse:[
+"try classes comment"
+s := cls comment.
+s isString ifTrue:[
+s isEmpty ifTrue:[
+s := nil
+] ifFalse:[
+(s includes:$") ifTrue:[
+s := s copyReplaceAll:$" with:$'.
+].
+s size > 80 ifTrue:[
+s := s asCollectionOfSubstringsSeparatedBy:$..
+s := s asStringCollection.
+s := s collect:[:each | (each startsWith:Character space) ifTrue:[
+each copyFrom:2
+] ifFalse:[
+each
+]
+].
+s := s asStringWith:('.' , Character cr).
+].
+]
+] ifFalse:[
+"/ class redefines comment ?
+s := nil
+].
+].
+s isEmptyOrNil ifTrue:[^ s].
+^ s withTabsExpanded
+"
+Array commentOrDocumentationString
+"
+!
 commentSlot
 ^ self at:(Class instVarOffsetOf:'comment')
 !
 flags
-|flags amount|
+|flags|
 cachedFlags isNil ifTrue:[
 flags := self flagsSlot.
 (SnapShotImageMemory isSmallIntegerOOP:flags) ifFalse:[
 self halt
 ].
-amount := -1.
+cachedFlags := flags bitShift:-1.
-cachedFlags := flags bitShift:amount.
 ].
 ^ cachedFlags
 !
 flagsSlot
 isMeta
 |clsName|
 thisContext isRecursive ifTrue:[^ false].
-byteSize = (Metaclass instSize * 4 + 12) ifFalse:[^ false].
+byteSize = memory metaClassByteSize ifFalse:[^ false].
 clsName := classRef name.
 ^ clsName = 'Metaclass' or:[clsName = 'PrivateMetaclass'].
 "/self halt.
 ^ classRef isPrivateMeta
 !
 isPrivateMeta
 thisContext isRecursive ifTrue:[^ false].
-byteSize = (PrivateMetaclass instSize * 4 + 12) ifFalse:[^ false].
+byteSize = memory privateMetaClassByteSize ifFalse:[^ false].
 ^ classRef name = 'PrivateMetaclass'
 !
 isSignedLongLongs
 ^ (self flags bitAnd:Behavior maskIndexType) == Behavior flagSignedLongLongs.
 !SnapShotImageMemory class methodsFor:'documentation'!
 version
 ^ '$Header$'
 ! !

changeset 3088	5a5e9b9b5138
parent 2164	3c5fe1d92046
child 3089	994863569542