# HG changeset patch # User Claus Gittinger # Date 999708304 -7200 # Node ID 13fe76a0986b3410e98f75ce45c1f34d67b890cf # Parent 32f1fd9d0f15d85581083ce748e1f3338bbb9666 more caching (faster now) diff -r 32f1fd9d0f15 -r 13fe76a0986b SnapShotImage.st --- a/SnapShotImage.st Thu Aug 23 10:33:10 2001 +0200 +++ b/SnapShotImage.st Wed Sep 05 18:45:04 2001 +0200 @@ -1,7 +1,7 @@ "{ Package: 'stx:libtool2' }" Object subclass:#SnapShotImage - instanceVariableNames:'memory globals' + instanceVariableNames:'memory globals cachedBehaviors' classVariableNames:'' poolDictionaries:'' category:'System-Support' @@ -71,19 +71,24 @@ !SnapShotImage methodsFor:'smalltalk protocol'! allClassesDo:aBlock - self keysAndValuesDo:[:key :valRef | - valRef isInteger ifFalse:[ - valRef ~~ true ifTrue:[ - valRef ~~ false ifTrue:[ - valRef notNil ifTrue:[ - valRef isImageBehavior ifTrue:[ - aBlock value:valRef + cachedBehaviors isNil ifTrue:[ + cachedBehaviors := OrderedCollection new. + + self keysAndValuesDo:[:key :valRef | + valRef isInteger ifFalse:[ + valRef ~~ true ifTrue:[ + valRef ~~ false ifTrue:[ + valRef notNil ifTrue:[ + valRef isImageBehavior ifTrue:[ + cachedBehaviors add:valRef + ] ] ] ] ] - ] + ]. ]. + cachedBehaviors do:aBlock ! allClassesInCategory:aCategory diff -r 32f1fd9d0f15 -r 13fe76a0986b SnapShotImageMemory.st --- a/SnapShotImageMemory.st Thu Aug 23 10:33:10 2001 +0200 +++ b/SnapShotImageMemory.st Wed Sep 05 18:45:04 2001 +0200 @@ -29,8 +29,15 @@ privateIn:SnapShotImageMemory ! +SnapShotImageMemory::ImageObject variableSubclass:#ImageMethodObject + instanceVariableNames:'cachedPackage' + classVariableNames:'' + poolDictionaries:'' + privateIn:SnapShotImageMemory +! + SnapShotImageMemory::ImageObject variableSubclass:#ImageClassObject - instanceVariableNames:'' + instanceVariableNames:'cachedCategory cachedFlags cachedName' classVariableNames:'' poolDictionaries:'' privateIn:SnapShotImageMemory @@ -166,7 +173,8 @@ ! fetchObjectAt:baseAddr - |addr classPtr classRef size bits o nBytes nInsts flags 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:[ @@ -194,8 +202,9 @@ classRef := self fetchClassObjectAt:classPtr. - flags := classRef flags bitAnd:Behavior maskIndexType. - (flags = Behavior flagBytes) ifTrue:[ + flags := classRef flags. + indexTypeFlags := flags bitAnd:Behavior maskIndexType. + (indexTypeFlags = Behavior flagBytes) ifTrue:[ nBytes := (size - (intSize * 3)). o := ImageByteObject new:nBytes. o classRef:classRef. @@ -216,21 +225,25 @@ "/Transcript cr. ] ifFalse:[ - (flags = Behavior flagNotIndexed) ifFalse:[ - (flags ~= Behavior flagPointers) ifTrue:[ - (flags ~= Behavior flagWeakPointers) ifTrue:[ + (indexTypeFlags = Behavior flagNotIndexed) ifFalse:[ + (indexTypeFlags ~= Behavior flagPointers) ifTrue:[ + (indexTypeFlags ~= Behavior flagWeakPointers) ifTrue:[ self halt ] ]. ]. nInsts := (size - (intSize * 3)) // intSize. - (classRef flags bitTest:Behavior flagBehavior) + (flags bitTest:Behavior flagBehavior) "/ classRef isImageBehavior ifTrue:[ o := ImageClassObject new:nInsts. ] ifFalse:[ - o := ImageObject new:nInsts. + (flags bitTest:Behavior flagMethod) ifTrue:[ + o := ImageMethodObject new:nInsts. + ] ifFalse:[ + o := ImageObject new:nInsts. + ] ]. o classRef:classRef. size > 8000 ifTrue:[self halt]. @@ -937,6 +950,10 @@ ^ false ! +isObsolete + ^ false +! + isPrivate ^ false ! @@ -1071,35 +1088,7 @@ ! source - |sourcePosition sourcePositionPtr sourcePtr sourceRef source aStream junk| - - self isMethodOrLazyMethod ifTrue:[ - sourcePositionPtr := self at:(Method instVarOffsetOf:'sourcePosition'). - sourcePtr := self at:(Method instVarOffsetOf:'source'). - sourceRef := memory fetchObjectAt:sourcePtr. - sourceRef isString ifFalse:[ - self halt. - ]. - source := memory printStringOfString:sourceRef. - sourcePosition := memory fetchObjectAt:sourcePositionPtr. - sourcePosition isNil ifTrue:[ - ^ source - ]. - - aStream := self sourceStream. - aStream notNil ifTrue:[ - Stream positionErrorSignal handle:[:ex | - ^ nil - ] do:[ - aStream position:sourcePosition abs. - ]. - junk := aStream nextChunk. - - aStream close. - ^ junk - ]. - ]. - self halt. + self halt:'unimplemented'. ! sourceFilename @@ -1337,19 +1326,81 @@ ^ byteSize ! ! +!SnapShotImageMemory::ImageMethodObject methodsFor:'method protocol'! + +package + |packageSlotOffset packagePtr packageRef package| + + cachedPackage isNil ifTrue:[ + packageSlotOffset := Method instVarOffsetOf:'package'. + + packagePtr := self at:packageSlotOffset. + packageRef := memory fetchObjectAt:packagePtr. + packageRef isNil ifTrue:[^ nil]. + + packageRef isImageSymbol ifFalse:[ + packageRef isImageBytes ifFalse:[ + self halt. + ]. + "/ mhmh - can be a string sometimes ... + ]. + package := memory fetchStringFor:packageRef. + cachedPackage := package asSymbol + ]. + ^ cachedPackage +! + +source + |sourcePosition sourcePositionPtr sourcePtr sourceRef source aStream junk| + + sourcePositionPtr := self at:(Method instVarOffsetOf:'sourcePosition'). + sourcePtr := self at:(Method instVarOffsetOf:'source'). + sourceRef := memory fetchObjectAt:sourcePtr. + sourceRef isString ifFalse:[ + self halt. + ]. + source := memory printStringOfString:sourceRef. + sourcePosition := memory fetchObjectAt:sourcePositionPtr. + sourcePosition isNil ifTrue:[ + ^ source + ]. + + aStream := self sourceStream. + aStream notNil ifTrue:[ + Stream positionErrorSignal handle:[:ex | + ^ nil + ] do:[ + aStream position:sourcePosition abs. + ]. + junk := aStream nextChunk. + + aStream close. + ^ junk + ]. + self halt. +! ! + +!SnapShotImageMemory::ImageMethodObject methodsFor:'queries'! + +isMethod + ^ true +! ! + !SnapShotImageMemory::ImageClassObject methodsFor:'accessing - slots'! category - |categoryRef category| - - categoryRef := self categorySlot. - categoryRef isInteger ifTrue:[ - categoryRef := memory fetchObjectAt:categoryRef. + |categoryRef| + + cachedCategory isNil ifTrue:[ + categoryRef := self categorySlot. + categoryRef isInteger ifTrue:[ + categoryRef := memory fetchObjectAt:categoryRef. + ]. + categoryRef notNil ifTrue:[ + cachedCategory := memory fetchStringFor:categoryRef. + ]. ]. - categoryRef notNil ifTrue:[ - category := memory fetchStringFor:categoryRef. - ]. - ^ category + ^ cachedCategory ! categorySlot @@ -1396,7 +1447,7 @@ ]. ]. ]. - ^ classVarNames + ^ classVarNames ? #() ! classVariableString @@ -1436,13 +1487,16 @@ flags |flags amount| - flags := self flagsSlot. - - (SnapShotImageMemory isSmallIntegerOOP:flags) ifFalse:[ - self halt + cachedFlags isNil ifTrue:[ + flags := self flagsSlot. + + (SnapShotImageMemory isSmallIntegerOOP:flags) ifFalse:[ + self halt + ]. + amount := -1. + cachedFlags := flags bitShift:amount. ]. - amount := -1. - ^ flags bitShift:amount. + ^ cachedFlags ! flagsSlot @@ -1506,23 +1560,23 @@ ! name - |nameRef name| - - self isMeta ifTrue:[ - ^ self theNonMetaclass name , ' class' + |nameRef| + + cachedName isNil ifTrue:[ + self isMeta ifTrue:[ + cachedName := self theNonMetaclass name , ' class' + ] ifFalse:[ + nameRef := self nameSlot. + nameRef isInteger ifTrue:[ + nameRef := memory fetchObjectAt:nameRef. + ]. + nameRef notNil ifTrue:[ + cachedName := memory fetchStringFor:nameRef. + cachedName := cachedName asSymbol + ]. + ]. ]. - - nameRef := self nameSlot. - nameRef isInteger ifTrue:[ - nameRef := memory fetchObjectAt:nameRef. - ]. - nameRef notNil ifTrue:[ - name := memory fetchStringFor:nameRef. - ]. - nameRef notNil ifTrue:[ - name := name asSymbol. - ]. - ^ name + ^ cachedName ! nameSlot @@ -1634,7 +1688,7 @@ "/ metaclasses are not found via Smalltalk allClassesDo: "/ here, walk over classes and enumerate corresponding metas. self soleInstance allSubclassesDo:[:aSubClass | - aBlock value:(aSubClass class) + aBlock value:(aSubClass theMetaclass) ]. ] ifFalse:[ Smalltalk allClassesDo:[:aClass | @@ -2313,14 +2367,14 @@ self printClassNameOn:aStream. ]. aStream nextPutAll:' class instanceVariableNames:'''. - self class printInstVarNamesOn:aStream indent:8. + self theMetaclass printInstVarNamesOn:aStream indent:8. aStream nextPutAll:''''. "mhmh - good idea; saw this in SmallDraw sourcecode ..." anySuperClassInstVar := false. self allSuperclassesDo:[:aSuperClass | - aSuperClass class instVarNames do:[:ignored | anySuperClassInstVar := true]. + aSuperClass theMetaclass instVarNames do:[:ignored | anySuperClassInstVar := true]. ]. aStream cr; cr; nextPut:(Character doubleQuote); cr; space. @@ -2333,7 +2387,7 @@ aStream cr. self allSuperclassesDo:[:aSuperClass | aStream tab; nextPutAll:aSuperClass name; nextPutAll:' - '. - aStream nextPutLine:(aSuperClass class instanceVariableString). + aStream nextPutLine:(aSuperClass theMetaclass instanceVariableString). ]. ]. @@ -2783,8 +2837,19 @@ "Modified: 22.8.1997 / 14:59:14 / cg" ! -isObsolete - ^ false +isObsolete + "return true, if the receiver is obsolete + (i.e. has been replaced by a different class or was removed, + but is still referenced by instanced)" + + |cat| + + cat := self category. + + ^ cat = 'obsolete' + or:[cat = 'removed' + or:[cat = '* removed *' + or:[cat = '* obsolete *']]] ! isSubclassOf:aClass @@ -2914,6 +2979,24 @@ "Modified: / 18.7.1998 / 22:53:19 / cg" ! +lookupMethodFor:aSelector + "return the method, which would be executed if aSelector was sent to + an instance of the receiver. I.e. the selector arrays of the receiver + and all of its superclasses are searched for aSelector. + Return the method, or nil if instances do not understand aSelector. + EXPERIMENTAL: take care of multiple superclasses." + + |m cls| + + cls := self. + [cls notNil] whileTrue:[ + m := cls compiledMethodAt:aSelector. + m notNil ifTrue:[^ m]. + cls := cls superclass + ]. + ^ nil +! + nameWithoutNameSpacePrefix |nm owner| @@ -3590,7 +3673,7 @@ "/ metaclasses are not found via Smalltalk allClassesDo: "/ here, walk over classes and enumerate corresponding metas. self soleInstance subclassesDo:[:aSubClass | - aBlock value:(aSubClass class) + aBlock value:(aSubClass theMetaclass) ]. ^ self ]. @@ -3648,6 +3731,36 @@ ^ true ! +whichClassDefinesClassVar:aVariableName + "return the class which defines the class variable + named aVariableName. This method should not be used for + repeated searches (i.e. in the compiler/parser), since it creates + many throw away intermediate objects." + + |cls| + + cls := self. + [cls notNil] whileTrue:[ + (cls classVarNames includes:aVariableName) ifTrue:[ ^ cls]. + cls := cls superclass + ]. + ^ nil +! + +whichClassIncludesSelector:aSelector + "return the class in the inheritance chain, which implements the method + for aSelector; return nil if none." + + |cls| + + cls := self. + [cls notNil] whileTrue:[ + (cls includesSelector:aSelector) ifTrue:[^ cls]. + cls := cls superclass + ]. + ^ nil +! + withAllSuperclasses "return a collection containing the receiver and all of the receivers accumulated superclasses" @@ -3661,10 +3774,6 @@ theSuperClass := theSuperClass superclass ]. ^ aCollection - - " - String withAllSuperclasses - " ! withAllSuperclassesDo:aBlock @@ -3707,6 +3816,10 @@ ^ (self flags bitAnd:Behavior maskIndexType) == Behavior flagFloats. ! +isImageBehavior + ^ true +! + isLoaded |superclass|