'From Squeak3.1alpha of 5 February 2001 [latest update: #3726] on 27 February 2001 at 10:39:37 am'! "Change Set: BetterShrink Date: 27 February 2001 Author: Dan Ingalls Introduces a new image partitioning tool that is essentially a local version of majorShrink. The idea is to pick some application like Scamper, or some cluster like all the 3D classes, and remove it, and also remove everything that is solely referred to by it. The way it works is: Record all unsent messages and unused classes at the outset Mark the application or cluster as removed Note all *newly* unreferenced methods and unused classes and iteratively remove them as well For example, the expression Smalltalk reportClassAndMethodRemovalsFor: #(Celeste Scamper MailMessage) reports 63 classes and 155 other messages that can be removed. Also, introduces a new method, fileOutAndRemove:... that will take such results, build a changeSet from them, fileOut everything that is about to be removed, and then remove all of the classes and related messages as well. For the above example, this method produces a 290k fileOut, and saves about 104k from the system. More importantly, if you fileIn the changeSet afterward, the system returns to approximately its former size, and you can run Scamper again. It's a way to fileOut a package that never existed. Tools for Pools yet to come. "! !SystemDictionary methodsFor: 'retrieving' stamp: 'di 2/25/2001 21:03'! allGlobalRefs "Answer a set of symbols that may be refs to Global names. In some sense we should only need the associations, but this will also catch, eg, HTML tag types." ^ self allGlobalRefsWithout: {{}. {}}! ! !SystemDictionary methodsFor: 'retrieving' stamp: 'di 2/27/2001 09:52'! allGlobalRefsWithout: classesAndMessagesPair "Answer a set of symbols that may be refs to Global names. In some sense we should only need the associations, but this will also catch, eg, HTML tag types. This method computes its result in the absence of specified classes and messages." | globalRefs absentClasses absentSelectors | globalRefs _ IdentitySet new: CompiledMethod instanceCount. absentClasses _ classesAndMessagesPair first. absentSelectors _ classesAndMessagesPair second. Cursor execute showWhile: [self classNames do: [:cName | ((absentClasses includes: cName) ifTrue: [{}] ifFalse: [{(self at: cName). (self at: cName) class}]) do: [:cl | (absentSelectors isEmpty ifTrue: [cl selectors] ifFalse: [cl selectors copyWithoutAll: absentSelectors]) do: [:sel | "Include all capitalized symbols for good measure" (cl compiledMethodAt: sel) literals do: [:m | ((m isMemberOf: Symbol) and: [m size > 0 and: [m first isUppercase]]) ifTrue: [globalRefs add: m]. (m isMemberOf: Array) ifTrue: [m do: [:x | ((x isMemberOf: Symbol) and: [x size > 0 and: [x first isUppercase]]) ifTrue: [globalRefs add: x]]]. (m isMemberOf: Association) ifTrue: [m key ifNotNil: [globalRefs add: m key]]]]]]]. ^ globalRefs! ! !SystemDictionary methodsFor: 'retrieving' stamp: 'di 2/25/2001 23:17'! allImplementedMessages "Answer a Set of all the messages that are implemented in the system." ^ self allImplementedMessagesWithout: {{}. {}}! ! !SystemDictionary methodsFor: 'retrieving' stamp: 'di 2/25/2001 23:24'! allImplementedMessagesWithout: classesAndMessagesPair "Answer a Set of all the messages that are implemented in the system, computed in the absence of the supplied classes and messages. Note this reports messages that are in the absent selectors set." | messages absentClasses | messages _ IdentitySet new: CompiledMethod instanceCount. absentClasses _ classesAndMessagesPair first. Cursor execute showWhile: [self classNames do: [:cName | ((absentClasses includes: cName) ifTrue: [{}] ifFalse: [{(self at: cName). (self at: cName) class}]) do: [:cl | messages addAll: cl selectors]]]. ^ messages! ! !SystemDictionary methodsFor: 'retrieving' stamp: 'di 2/25/2001 20:53'! allSentMessages "Answer the set of selectors which are sent somewhere in the system." ^ self allSentMessagesWithout: {{}. {}}! ! !SystemDictionary methodsFor: 'retrieving' stamp: 'di 2/25/2001 22:03'! allSentMessagesWithout: classesAndMessagesPair "Answer the set of selectors which are sent somewhere in the system, computed in the absence of the supplied classes and messages." | sent absentClasses absentSelectors | sent _ IdentitySet new: CompiledMethod instanceCount. absentClasses _ classesAndMessagesPair first. absentSelectors _ classesAndMessagesPair second. Cursor execute showWhile: [self classNames do: [:cName | ((absentClasses includes: cName) ifTrue: [{}] ifFalse: [{(self at: cName). (self at: cName) class}]) do: [:cl | (absentSelectors isEmpty ifTrue: [cl selectors] ifFalse: [cl selectors copyWithoutAll: absentSelectors]) do: [:sel | "Include all sels, but not if sent by self" (cl compiledMethodAt: sel) literals do: [:m | (m isMemberOf: Symbol) ifTrue: "might be sent" [m == sel ifFalse: [sent add: m]]. (m isMemberOf: Array) ifTrue: "might be performed" [m do: [:x | (x isMemberOf: Symbol) ifTrue: [x == sel ifFalse: [sent add: x]]]]]]]]. "The following may be sent without being in any literal frame" 1 to: self specialSelectorSize do: [:index | sent add: (self specialSelectorAt: index)]]. Smalltalk presumedSentMessages do: [:sel | sent add: sel]. ^ sent! ! !SystemDictionary methodsFor: 'retrieving' stamp: 'di 2/25/2001 20:53'! allUnSentMessages "Smalltalk allUnSentMessages" "Answer the set of selectors that are implemented by some object in the system but not sent by any." ^ self allUnSentMessagesWithout: {{}. {}}! ! !SystemDictionary methodsFor: 'retrieving' stamp: 'di 2/25/2001 21:51'! allUnSentMessagesIn: selectorSet "Answer the subset of selectorSet which are not sent anywhere in the system." ^ selectorSet copyWithoutAll: self allSentMessages! ! !SystemDictionary methodsFor: 'retrieving' stamp: 'di 2/25/2001 23:17'! allUnSentMessagesWithout: classesAndMessagesPair "Answer the set of selectors that are implemented but not sent, computed in the absence of the supplied classes and messages." ^ (self allImplementedMessagesWithout: classesAndMessagesPair) copyWithoutAll: (self allSentMessagesWithout: classesAndMessagesPair)! ! !SystemDictionary methodsFor: 'retrieving' stamp: 'di 2/25/2001 21:58'! allUnusedClassesWithout: classesAndMessagesPair "Enumerates all classes in the system and returns a list of those that are apparently unused. A class is considered in use if it (a) has subclasses or (b) is referred to by some method or (c) has its name in use as a literal." "Smalltalk unusedClasses" | unused cl | unused _ Smalltalk classNames asIdentitySet copyWithoutAll: (self allGlobalRefsWithout: classesAndMessagesPair). ^ unused reject: [:cName | cl _ Smalltalk at: cName. cl subclasses isEmpty not or: [cl inheritsFrom: FileDirectory]]! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'di 2/26/2001 09:30'! fileOutAndRemove: classesAndMethodsPair "classesAndMethodsPair is {set of class names. set of selectors}." | classNames messageNames changeSet cl | classNames _ classesAndMethodsPair first. messageNames _ classesAndMethodsPair second. changeSet _ ChangeSet new initialize name: classNames first, 'EtAl'. classNames do: [:n | changeSet addClass: (cl _ Smalltalk at: n). {cl. cl class} do: [:cls | cls selectors do: [:sel | changeSet atSelector: sel class: cls put: #add]]]. Smalltalk classNames do: [:n | cl _ Smalltalk at: n. {cl. cl class} do: [:cls | cls selectors do: [:sel | (messageNames includes: sel) ifTrue: [changeSet atSelector: sel class: cls put: #add]]]]. Preferences checkForSlips ifTrue: [Preferences disable: #checkForSlips. changeSet fileOut. Preferences enable: #checkForSlips] ifFalse: [changeSet fileOut].! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'di 2/26/2001 09:35'! fileOutAndRemove: classesAndMethodsPair retainingRoots: rootClassNames "classesAndMethodsPair is {set of class names. set of selectors}." | classNames messageNames changeSet cl | "First fileOut all classes and methods..." classNames _ classesAndMethodsPair first. messageNames _ classesAndMethodsPair second. changeSet _ ChangeSet new initialize name: classNames first, 'EtAl'. classNames do: [:n | changeSet addClass: (cl _ Smalltalk at: n). {cl. cl class} do: [:cls | cls selectors do: [:sel | changeSet atSelector: sel class: cls put: #add]]]. Smalltalk classNames do: [:n | cl _ Smalltalk at: n. {cl. cl class} do: [:cls | cls selectors do: [:sel | (messageNames includes: sel) ifTrue: [changeSet atSelector: sel class: cls put: #add]]]]. Preferences checkForSlips ifTrue: [Preferences disable: #checkForSlips. changeSet fileOut. Preferences enable: #checkForSlips] ifFalse: [changeSet fileOut]. "Now remove all classes and methods..." classNames do: [:n | changeSet addClass: (cl _ Smalltalk at: n). {cl. cl class} do: [:cls | cls selectors do: [:sel | changeSet atSelector: sel class: cls put: #add]]]. Smalltalk classNames do: [:n | cl _ Smalltalk at: n. {cl. cl class} do: [:cls | cls selectors do: [:sel | (messageNames includes: sel) ifTrue: [changeSet atSelector: sel class: cls put: #add]]]]. ! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'di 2/26/2001 10:43'! fileOutAndRemove: rootClasses withOtherClasses: otherClasses andOtherMessages: otherMessages "classesAndMethodsPair is {set of class names. set of selectors}." | changeSet cl priorChanges | "First fileOut all classes and methods..." changeSet _ ChangeSet new initialize name: rootClasses first, 'EtAl'. rootClasses , otherClasses do: [:n | changeSet addClass: (cl _ Smalltalk at: n). {cl. cl class} do: [:cls | cls selectors do: [:sel | changeSet atSelector: sel class: cls put: #add]]]. Smalltalk classNames do: [:n | cl _ Smalltalk at: n. {cl. cl class} do: [:cls | cls selectors do: [:sel | (otherMessages includes: sel) ifTrue: [changeSet atSelector: sel class: cls put: #add]]]]. Preferences checkForSlips ifTrue: [Preferences disable: #checkForSlips. changeSet fileOut. Preferences enable: #checkForSlips] ifFalse: [changeSet fileOut]. "Now remove all classes and methods..." priorChanges _ Smalltalk changes. "Save current changeSet" Smalltalk newChanges: changeSet. "just a place to dump removals" rootClasses do: [:n | cl _ Smalltalk at: n. "Root classes get left, but all methods removed." {cl. cl class} do: [:cls | cls zapOrganization. cls selectors do: [:sel | cls removeSelectorSimply: sel]]]. (ChangeSet superclassOrder: (otherClasses collect: [:n | (Smalltalk at: n)])) reverseDo: [:cls | cls removeFromSystem]. Smalltalk classNames do: [:n | cl _ Smalltalk at: n. {cl. cl class} do: [:cls | cls selectors do: [:sel | (otherMessages includes: sel) ifTrue: [cls removeSelectorSimply: sel]]]]. Smalltalk newChanges: priorChanges. "Restore current changeSet" ChangeSorter gatherChangeSets remove: changeSet. changeSet _ nil. "Try to avoid registering this as a normal changeSet." Smalltalk garbageCollect! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'di 2/25/2001 14:47'! presumedSentMessages | sent | "Smalltalk presumedSentMessages" "The following should be preserved for doIts, etc" sent _ IdentitySet new. #( rehashWithoutBecome compactSymbolTable rebuildAllProjects browseAllSelect: printSpaceAnalysis lastRemoval scrollBarValue: scrollBarMenuButtonPressed: withSelectionFrom: to: removeClassNamed: dragon: hilberts: mandala: web test3 factorial tinyBenchmarks benchFib newDepth: restoreAfter: forgetDoIts zapAllMethods obsoleteClasses removeAllUnSentMessages abandonSources removeUnreferencedKeys reclaimDependents zapOrganization condenseChanges browseObsoleteReferences subclass:instanceVariableNames:classVariableNames:poolDictionaries:category: methodsFor:stamp: methodsFor:stamp:prior: instanceVariableNames: startTimerInterruptWatcher unusedClasses) do: [:sel | sent add: sel]. "The following may be sent by perform: in dispatchOnChar..." (ParagraphEditor classPool at: #CmdActions) asSet do: [:sel | sent add: sel]. (ParagraphEditor classPool at: #ShiftCmdActions) asSet do: [:sel | sent add: sel]. ^ sent! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'di 2/26/2001 22:39'! removeNormalCruft "Smalltalk removeNormalCruft" ScriptingSystem stripGraphicsForExternalRelease. References keys do: [:k | References removeKey: k]. Smalltalk classNames do: [:cName | #( 'Player' 'Component' 'WonderlandActor' 'MorphicModel' 'PlayWithMe') do: [:superName | ((cName ~= superName and: [cName beginsWith: superName]) and: [(cName allButFirst: superName size) allSatisfy: [:ch | ch isDigit]]) ifTrue: [Smalltalk removeClassNamed: cName]]]. Smalltalk at: #Wonderland ifPresent:[:cls | cls removeActorPrototypesFromSystem]. Smalltalk changes clear. ! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'di 2/25/2001 22:34'! reportClassAndMethodRemovalsFor: collectionOfClassNames | initialClassesAndMethods finalClassesAndMethods | "Smalltalk reportClassAndMethodRemovalsFor: #(Celeste Scamper MailMessage)" initialClassesAndMethods _ self unusedClassesAndMethodsWithout: {{}. {}}. finalClassesAndMethods _ self unusedClassesAndMethodsWithout: {collectionOfClassNames. {}}. ^ {finalClassesAndMethods first copyWithoutAll: initialClassesAndMethods first. finalClassesAndMethods second copyWithoutAll: initialClassesAndMethods second}! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'di 2/25/2001 21:18'! unusedClasses "Enumerates all classes in the system and returns a list of those that are apparently unused. A class is considered in use if it (a) has subclasses or (b) is referred to by some method or (c) has its name in use as a literal." "Smalltalk unusedClasses asSortedCollection" ^ self allUnusedClassesWithout: {{}. {}}! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'di 2/27/2001 10:38'! unusedClassesAndMethodsWithout: classesAndMessagesPair | classRemovals messageRemovals nClasses nMessages | "Accepts and returns a pair: {set of class names. set of selectors}. It is expected these results will be diff'd with the normally unused results." (classRemovals _ IdentitySet new) addAll: classesAndMessagesPair first. (messageRemovals _ IdentitySet new) addAll: classesAndMessagesPair second. nClasses _ nMessages _ -1. ["As long as we keep making progress..." classRemovals size > nClasses or: [messageRemovals size > nMessages]] whileTrue: ["...keep trying for bigger sets of unused classes and selectors." nClasses _ classRemovals size. nMessages _ messageRemovals size. Utilities informUser: 'Iterating removals ' , (classesAndMessagesPair first isEmpty ifTrue: ['for baseline...'] ifFalse: ['for ', classesAndMessagesPair first first, ' etc...']) , Character cr asString , nClasses printString , ' classes, ' , nMessages printString , ' messages. | |' "spacers move menu off cursor" during: [classRemovals addAll: (self allUnusedClassesWithout: {classRemovals. messageRemovals}). messageRemovals addAll: (self allUnSentMessagesWithout: {classRemovals. messageRemovals})]]. ^ {classRemovals. self allUnSentMessagesWithout: {classRemovals. messageRemovals}}! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'di 2/26/2001 22:40'! zapAllOtherProjects "Smalltalk zapAllOtherProjects" Project allInstancesDo: [:p | p setParent: nil]. Project current setParent: Project current. Project current isMorphic ifTrue: [ScheduledControllers _ nil]. TheWorldMenu allInstancesDo: [:m | 1 to: m class instSize do: [:i | m instVarAt: i put: nil]]. ChangeSorter classPool at: #AllChangeSets put: nil. Project classPool at: #AllProjects put: nil. Smalltalk garbageCollect. ChangeSorter initialize. Project rebuildAllProjects. Project allProjects size > 1 ifTrue: [Project allProjects inspect]! !