'From Squeak3.3alpha of 30 January 2002 [latest update: #4798] on 8 May 2002 at 11:29:03 am'! "Change Set: ClassBuilderFix for 3.3a Date: 08 May 2002 Author: Nathanael SchŠrli & Andreas Raab Fixes various problems in both ClassBuilder and the handling of obsolete subclasses. Updated for modules."! Object subclass: #ClassBuilder2 instanceVariableNames: 'environ blah classMap instVarMap progress maxClassIndex currentClassIndex module ' classVariableNames: 'QuietMode ' module: #(Squeak Language Core Classes)! !Behavior methodsFor: 'obsolete subclasses' stamp: 'NS 2/19/2002 11:13'! removeAllObsoleteSubclasses "Remove all the obsolete subclasses of the receiver" ObsoleteSubclasses finalizeValues. "clean up if need be" ObsoleteSubclasses removeKey: self ifAbsent: []. ! ! !Behavior methodsFor: 'obsolete subclasses' stamp: 'NS 2/19/2002 11:16'! removeObsoleteSubclass: aClass "Remove aClass from the weakly remembered obsolete subclasses" | obs | ObsoleteSubclasses finalizeValues. "clean up if need be" obs _ ObsoleteSubclasses at: self ifAbsent:[^ self]. (obs includes: aClass) ifFalse:[^self]. obs _ obs copyWithout: aClass. obs _ obs copyWithout: nil. obs isEmpty ifTrue: [ObsoleteSubclasses removeKey: self ifAbsent: []] ifFalse: [ObsoleteSubclasses at: self put: obs].! ! !ClassBuilder methodsFor: 'class definition' stamp: 'ar 2/15/2002 00:46'! newSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass unsafe: unsafe "Create a new subclass of the given superclass. Note: The new class may be meta." | newFormat newClass meta | "Compute the format of the new class" newFormat _ self computeFormat: type instSize: instVars size forSuper: newSuper ccIndex: (oldClass ifNil:[0] ifNotNil:[oldClass indexIfCompact]). newFormat == nil ifTrue:[^nil]. "Check if we really need a new subclass" (oldClass ~~ nil and:[ newSuper == oldClass superclass and:[ newFormat = oldClass format and:[ instVars = oldClass instVarNames]]]) ifTrue:[^oldClass]. unsafe ifFalse:[ "Make sure we don't redefine any dangerous classes" (self tooDangerousClasses includes: oldClass name) ifTrue:[ self error: oldClass name, ' cannot be changed'. ]. "Check if the receiver should not be redefined" (oldClass ~~ nil and:[oldClass shouldNotBeRedefined]) ifTrue:[ self notify: oldClass name asText allBold, ' should not be redefined!! \Proceed to store over it.' withCRs]]. (oldClass == nil or:[oldClass isMeta not]) ifTrue:["Requires new metaclass" meta _ Metaclass new. meta superclass: (newSuper ifNil:[Class] ifNotNil:[newSuper class]) methodDictionary: MethodDictionary new format: (newSuper ifNil:[Class format] ifNotNil:[newSuper class format]). meta superclass addSubclass: meta. "In case of Class" newClass _ meta new. ] ifFalse:[ newClass _ oldClass clone]. newClass superclass: newSuper methodDictionary: MethodDictionary new format: newFormat; setInstVarNames: instVars; organization: (oldClass ifNotNil:[oldClass organization]). ^newClass! ! !ClassBuilder methodsFor: 'class definition' stamp: 'NS 5/2/2002 11:18'! reshapeClass: aClass to: templateClass super: newSuper "Reshape the given class to the new super class. If templateClass is not nil then it defines the shape of the new class" | fmt newClass newMeta newSuperMeta oldMeta instVars oldClass aClassIsObsolete | aClassIsObsolete _ aClass isObsolete. templateClass == nil ifTrue:[oldClass _ aClass] ifFalse:[oldClass _ templateClass]. aClass becomeUncompact. "Compute the new format of the class" instVars _ instVarMap at: aClass name ifAbsent:[oldClass instVarNames]. fmt _ self computeFormat: oldClass typeOfClass instSize: instVars size forSuper: newSuper ccIndex: 0."Known to be 0 since we uncompacted aClass first" fmt == nil ifTrue:[^nil]. aClass isMeta ifFalse:["Create a new meta class" oldMeta _ aClass class. newMeta _ oldMeta clone. newSuperMeta _ newSuper ifNil:[Class] ifNotNil:[newSuper class]. newMeta superclass: newSuperMeta methodDictionary: MethodDictionary new format: (self computeFormat: oldMeta typeOfClass instSize: oldMeta instVarNames size forSuper: newSuperMeta ccIndex: 0); setInstVarNames: oldMeta instVarNames; organization: oldMeta organization. "Recompile the meta class" oldMeta hasMethods ifTrue:[newMeta compileAllFrom: oldMeta]. "Fix up meta class structure" oldMeta superclass addObsoleteSubclass: oldMeta. (oldMeta superclass subclasses includes: oldMeta) ifTrue:[ oldMeta superclass removeSubclass: oldMeta. newMeta superclass addSubclass: newMeta]. "And record the change so we can fix global refs later" self recordClass: oldMeta replacedBy: newMeta. ]. newClass _ newMeta == nil ifTrue:[oldClass clone] ifFalse:[newMeta adoptInstance: aClass from: oldMeta]. newClass superclass: newSuper methodDictionary: MethodDictionary new format: fmt; setInstVarNames: instVars; organization: aClass organization. "Recompile the new class" aClass hasMethods ifTrue:[newClass compileAllFrom: aClass]. "Export the new class into the environment" aClass isMeta ifFalse:[ "Derefence super sends in the old class" self fixSuperSendsFrom: aClass. "Export the class" aClassIsObsolete ifFalse: [ [newClass module redefineName: newClass name as: newClass export: true] on: AttemptToWriteReadOnlyGlobal do:[:ex| ex resume: true]]. "And use the ST association in the new class" self fixSuperSendsTo: newClass]. "Fix up the class hierarchy" aClassIsObsolete ifFalse: [ (aClass superclass subclasses includes: aClass) ifTrue:[ aClass superclass removeSubclass: aClass. "NOTE: aClass is added as an obsoleteSubclass of its superclass in the method ClassBuilder>>update:to:" newClass superclass addSubclass: newClass]. ] ifTrue: [ "If aClass is obsolete, also newClass is obsolete and therefore it has to be added to the obsolete subclasses of its superclass" newClass superclass addObsoleteSubclass: newClass ]. "And record the change" self recordClass: aClass replacedBy: newClass. ^newClass! ! !ClassBuilder methodsFor: 'private' stamp: 'ar 4/23/2002 15:57'! update: oldClass to: newClass "Convert oldClass and all its instances into newClass. The process is to do a two-way #become of the old vs. new instances, then we map the old instances into a temporary class and then we do a one-way become of the old into the new class. The entire process must be run unpreemptively so that a) nobody can create any more instances of oldClass (which may happen in a process switch), and b) in case we don't #primitiveChangeClassTo: nobody can hold on to any of the old instances (which would #become instances of the new class later on). The return value of this method is the temporary class we used for converting instances so that the senders still have a handle on the 'old' class." | oldInstances someLeft tmp tmpClass | [ someLeft _ false. tmpClass _ oldClass clone. oldInstances _ newClass updateInstancesFrom: oldClass. oldInstances size > 0 ifTrue:[ "need to map instances" self hasPrimitiveChangeClassTo ifTrue:[ "Much easier, faster, and better that way" tmp _ tmpClass basicNew. oldInstances do:[:inst| inst primitiveChangeClassTo: tmp. inst class == tmpClass ifFalse:[self error:'Ouch']]. ] ifFalse:[ "Do it the hard way. We need to make sure that there are no instances of oldClass anymore. Thus we're #becoming the old instances into temp instances and do a big GC afterwards. This is sloooooow (a bulk become + full GC for any class having instances) but it's most definitely a way to get the required result." tmpClass updateInstances: oldInstances from: oldClass isMeta: oldClass isMeta. Smalltalk garbageCollect. ]. ]. "It's better to be sure than sorry..." someLeft _ oldClass isMeta not and:[oldClass someInstance notNil]. "NOTE: The above is a sanity check to see if there are any left-over instances from the old class. The reason why we exclude meta classes here is that in some places within the class builder (most noticably right on top of this method) temporary instances of meta classes are created. E.g., when we have a non-meta class the code on top saying: tmpClass _ oldClass clone. will create a new instance of oldClass' class (e.g., a copy of oldClass). If - for any reason - both a class and its meta class are modified without the garbage collector cleaning up these temporary instances the test above will report left-over instances of the meta class (this is because Metaclass>>updateInstancesFrom: assumes that there is only one instance of the meta class). In a way, the error is correct but fixing the problem short of having Metaclass enumerate the entire object memory is hard. It would mean to make sure that at no place in the class builder (or anywhere else in the system) a class is created without creating the appropriate metaclass. For our example of 'tmpClass := oldClass clone' this would lead to code like: oldClass isMeta ifTrue:[tmpClass := oldClass clone] ifFalse:[tmpClass := oldClass class clone adoptInstance: oldClass from: oldClass class]. And now you can see why we haven't fixed this problem for real yet ;-) Also, there are some other places in the class builder which need to be fixed in order to get it right." someLeft ifFalse:[ "remap obsolete subclasses in case they have instances" oldClass obsoleteSubclasses do: [:obs| obs ifNotNil: [ obs superclass: tmpClass. "Since obsolete subclasses are stored outside the class, we have to add them manually to tmpClass" tmpClass addObsoleteSubclass: obs]. ]. "Removing of obsolete subclasses is necessary in order to prevent having two entries with obsolete subclasses in the ObsoleteSubclasses dictionary (after we did the becomeForward)" oldClass removeAllObsoleteSubclasses. oldClass becomeForward: newClass. tmpClass isMeta ifFalse: [tmpClass class replaceObsoleteInstanceWith: tmpClass]]. ] valueUnpreemptively. someLeft ifTrue:[self error:'Illegal pointers to obsolete instances found']. "If the old (resp. the new) class is obsolete, we have to remove it from the obsolete subclasses of tmpClass' superclass. NOTE: If it is not obsolete, it gets removed from the set of subclasses in ClassBuilder>>reshapeClass:to:super:" oldClass isObsolete ifTrue: [tmpClass superclass removeObsoleteSubclass: oldClass]. tmpClass superclass addObsoleteSubclass: tmpClass. tmpClass obsolete. ^tmpClass! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'ar 4/23/2002 16:04'! checkClassHierarchyConsistency "Check the consistency of the class hierarchy. The class hierarchy is consistent if the following two logical equivalences hold for classes A and B: - B is obsolete and 'B superclass' yields A <--> 'A obsoleteSubclasses' contains B - B is not obsolete and 'B superclass' yields A <--> 'A subclasses' contains B" Utilities informUserDuring:[:bar| self checkClassHierarchyConsistency: bar. ].! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'ar 4/23/2002 16:03'! checkClassHierarchyConsistency: informer "Check the consistency of the class hierarchy. The class hierarchy is consistent if the following two logical equivalences hold for classes A and B: - B is obsolete and 'B superclass' yields A <--> 'A obsoleteSubclasses' contains B - B is not obsolete and 'B superclass' yields A <--> 'A subclasses' contains B" | classes | Transcript cr; show: 'Start checking the class hierarchy...'. Smalltalk garbageCollect. classes := Metaclass allInstances. classes keysAndValuesDo: [:index :meta | informer value:'Validating class hierarchy ', (index * 100 // classes size) printString,'%'. meta allInstances do: [:each | self checkClassHierarchyConsistencyFor: each]. self checkClassHierarchyConsistencyFor: meta. ]. Transcript show: 'OK'.! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 2/19/2002 11:48'! checkClassHierarchyConsistencyFor: aClassDescription "Check whether aClassDescription has a consistent superclass and consistent regular and obsolete subclasses" | mySuperclass | mySuperclass _ aClassDescription superclass. (mySuperclass subclasses includes: aClassDescription) = aClassDescription isObsolete ifTrue: [self error: 'Something wrong!!']. mySuperclass ifNil: [^ self]. "Obsolete subclasses of nil cannot be stored" (mySuperclass obsoleteSubclasses includes: aClassDescription) = aClassDescription isObsolete ifFalse: [self error: 'Something wrong!!']. aClassDescription subclasses do: [:each | each isObsolete ifTrue: [self error: 'Something wrong!!']. each superclass == aClassDescription ifFalse: [self error: 'Something wrong!!'] ]. aClassDescription obsoleteSubclasses do: [:each | each isObsolete ifFalse: [self error: 'Something wrong!!']. each superclass == aClassDescription ifFalse: [self error: 'Something wrong!!'] ].! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'ar 4/23/2002 16:00'! cleanupAndCheckClassHierarchy "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary. Afterwards it checks whether the hierarchy is really consistent." Utilities informUserDuring:[:bar| self cleanupAndCheckClassHierarchy: bar. ]. ! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'ar 4/23/2002 15:58'! cleanupAndCheckClassHierarchy: informer "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary. Afterwards it checks whether the hierarchy is really consistent." Transcript cr; show: '*** Before cleaning up ***'. self countReallyObsoleteClassesAndMetaclasses. self cleanupClassHierarchy: informer. self checkClassHierarchyConsistency: informer. Transcript cr; cr; show: '*** After cleaning up ***'. self countReallyObsoleteClassesAndMetaclasses.! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'ar 4/23/2002 16:04'! cleanupClassHierarchy "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary." Utilities informUserDuring:[:bar| self cleanupClassHierarchy: bar. ].! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'ar 4/23/2002 16:02'! cleanupClassHierarchy: informer "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary." | classes | Transcript cr; show: 'Start fixing the class hierarchy and cleaning up...'. Smalltalk garbageCollect. classes := Metaclass allInstances. classes keysAndValuesDo: [:index :meta | informer value:'Fixing class hierarchy ', (index * 100 // classes size) printString,'%'. "Check classes before metaclasses (because Metaclass>>isObsolete checks whether the related class is obsolete)" meta allInstances do: [:each | self cleanupClassHierarchyFor: each]. self cleanupClassHierarchyFor: meta. ]. Transcript show: 'DONE'.! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 5/8/2002 11:47'! cleanupClassHierarchyFor: aClassDescription | myName mySuperclass | mySuperclass _ aClassDescription superclass. (self isReallyObsolete: aClassDescription) ifTrue: [ "Remove class >>>from SystemDictionary if it is obsolete" myName _ aClassDescription name asString. "myName is a String in an IdentityDictionary, take care!!!!" Module root deepSubmodulesDo: [:mod | (mod definedNames keys asArray detect: [:key | key = myName and: [(mod definedNames at: key) == aClassDescription]] ifNone: []) ifNotNilDo: [:key | mod privateDefinedNames removeKey: key. mod privateExportedNames removeKey: key ifAbsent: []]]. "Make class officially obsolete if it is not" (aClassDescription name asString beginsWith: 'AnObsolete') ifFalse: [aClassDescription obsolete]. aClassDescription isObsolete ifFalse: [self error: 'Something wrong!!']. "Add class to obsoleteSubclasses of its superclass" mySuperclass ifNil: [self error: 'Obsolete subclasses of nil cannot be stored']. (mySuperclass obsoleteSubclasses includes: aClassDescription) ifFalse: [mySuperclass addObsoleteSubclass: aClassDescription]. ] ifFalse:[ "check if superclass has aClassDescription in its obsolete subclasses" mySuperclass ifNil:[mySuperclass _ Class]. "nil subclasses" mySuperclass removeObsoleteSubclass: aClassDescription. ]. "And remove its obsolete subclasses if not actual superclass" aClassDescription obsoleteSubclasses do:[:obs| obs superclass == aClassDescription ifFalse:[ aClassDescription removeObsoleteSubclass: obs]]. ! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 2/19/2002 11:49'! countReallyObsoleteClassesAndMetaclasses "Counting really obsolete classes and metaclasses" | metaSize classSize | Smalltalk garbageCollect. metaSize _ self reallyObsoleteMetaclasses size. Transcript cr; show: 'Really obsolete metaclasses: ', metaSize printString. classSize _ self reallyObsoleteClasses size. Transcript cr; show: 'Really obsolete classes: ', classSize printString; cr. "Metaclasses must correspond to classes!!" metaSize ~= classSize ifTrue: [self error: 'Serious metalevel inconsistency!!!!'].! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 2/19/2002 11:49'! isReallyObsolete: aClassDescription "Returns whether the argument class is *really* obsolete. (Due to a bug, the method isObsolete isObsolete does not always return the right answer" ^ aClassDescription isObsolete or: [(aClassDescription superclass subclasses includes: aClassDescription) not]! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 2/15/2002 16:52'! reallyObsoleteClasses | obsoleteClasses | obsoleteClasses _ OrderedCollection new. Metaclass allInstances do: [:meta | meta allInstances do: [:each | (self isReallyObsolete: each) ifTrue: [obsoleteClasses add: each]]]. ^ obsoleteClasses! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 2/15/2002 16:52'! reallyObsoleteMetaclasses ^ Metaclass allInstances select: [:each | self isReallyObsolete: each].! ! "Postscript: Clean up the class hierarchy." Utilities informUserDuring:[:bar| bar value:'Repairing the class hierarchy -- please stand by'. (Object respondsTo: #module) ifTrue:[ "Necessary cleanup for 3.3alpha" Smalltalk allObjectsDo:[:o| ((o isBehavior and: [o isMeta not]) and: [o module == Smalltalk]) ifTrue:[o module: Module smalltalk." Transcript show: o; space"]]]. ClassBuilder cleanupAndCheckClassHierarchy: bar. ]. !