[squeak-dev] The Trunk: System-nice.157.mczcommits at source.squeak.org commits at source.squeak.orgTue Oct 20 21:06:22 UTC 2009
Nicolas Cellier uploaded a new version of System to project The Trunk: http://source.squeak.org/trunk/System-nice.157.mcz ==================== Summary ==================== Name: System-nice.157 Author: nice Time: 20 October 2009, 10:24:12 am UUID: c49326c7-8b6f-44a2-9a04-970b30fcd15a Ancestors: System-nice.156 Track keys and selectors usage, use #includesSelector: #selectorsDo: and #asSet where due + make #classVarNames a sorted Array =============== Diff against System-nice.156 =============== Item was changed: ----- Method: SystemNavigation>>browseUncommentedMethodsWithInitials: (in category 'browse') ----- browseUncommentedMethodsWithInitials: targetInitials "Browse uncommented methods whose initials (in the time-stamp, as logged to disk) match the given initials. Present them in chronological order. CAUTION: It will take several minutes for this to complete." "Time millisecondsToRun: [SystemNavigation default browseUncommentedMethodsWithInitials: 'jm']" | initials timeStamp methodReferences cm | methodReferences := OrderedCollection new. self allBehaviorsDo: + [:aClass | aClass selectorsDo: [:sel | - [:aClass | aClass selectors do: [:sel | cm := aClass compiledMethodAt: sel. timeStamp := Utilities timeStampForMethod: cm. timeStamp isEmpty ifFalse: [initials := timeStamp substrings first. initials first isDigit ifFalse: [((initials = targetInitials) and: [(aClass firstPrecodeCommentFor: sel) isNil]) ifTrue: [methodReferences add: (MethodReference new setStandardClass: aClass methodSymbol: sel)]]]]]. ToolSet browseMessageSet: methodReferences name: 'Uncommented methods with initials ', targetInitials autoSelect: nil! Item was changed: ----- Method: ChangeSet>>methodsWithoutClassifications (in category 'testing') ----- methodsWithoutClassifications "Return a collection representing methods in the receiver which have not been categorized" | slips notClassified aSelector | notClassified := {'as yet unclassified' asSymbol. #all}. slips := OrderedCollection new. self changedClasses do: [:aClass | (self methodChangesAtClass: aClass name) associationsDo: + [:mAssoc | (aClass includesSelector: (aSelector := mAssoc key)) ifTrue: - [:mAssoc | (aClass selectors includes: (aSelector := mAssoc key)) ifTrue: [(notClassified includes: (aClass organization categoryOfElement: aSelector)) ifTrue: [slips add: aClass name , ' ' , aSelector]]]]. ^ slips "Smalltalk browseMessageList: (ChangeSet current methodsWithoutClassifications) name: 'unclassified methods'"! Item was changed: ----- Method: SystemDictionary>>testFormatter2 (in category 'housekeeping') ----- testFormatter2 "Smalltalk testFormatter2" "Reformats the source for every method in the system, and then verifies that the order of source tokens is unchanged. The formatting used will be either classic monochrome or fancy polychrome, depending on the setting of the preference #colorWhenPrettyPrinting. " "Note: removed references to Preferences colorWhenPrettyPrinting and replaced them simply with false, as I've been removing this preference lately. --Ron Spengler 8/23/09" | newCodeString badOnes n oldCodeString oldTokens newTokens | badOnes := OrderedCollection new. self forgetDoIts. 'Formatting all classes...' displayProgressAt: Sensor cursorPoint from: 0 to: CompiledMethod instanceCount during: [:bar | n := 0. self systemNavigation allBehaviorsDo: [:cls | "Transcript cr; show: cls name." + cls selectorsDo: - cls selectors do: [:selector | (n := n + 1) \\ 100 = 0 ifTrue: [bar value: n]. oldCodeString := (cls sourceCodeAt: selector) asString. newCodeString := cls prettyPrinterClass format: oldCodeString in: cls notifying: nil decorated: false. oldTokens := oldCodeString findTokens: Character separators. newTokens := newCodeString findTokens: Character separators. oldTokens = newTokens ifFalse: [Transcript cr; show: '***' , cls name , ' ' , selector. badOnes add: cls name , ' ' , selector]]]]. self systemNavigation browseMessageList: badOnes asSortedCollection name: 'Formatter Discrepancies'! Item was changed: ----- Method: ChangeSet>>methodsWithoutComments (in category 'moving changes') ----- methodsWithoutComments "Return a collection representing methods in the receiver which have no precode comments" | slips | slips := OrderedCollection new. self changedClasses do: [:aClass | (self methodChangesAtClass: aClass name) associationsDo: [:mAssoc | (#(remove addedThenRemoved) includes: mAssoc value) ifFalse: + [(aClass includesSelector: mAssoc key) ifTrue: - [(aClass selectors includes: mAssoc key) ifTrue: [(aClass firstPrecodeCommentFor: mAssoc key) isEmptyOrNil ifTrue: [slips add: aClass name , ' ' , mAssoc key]]]]]. ^ slips "Smalltalk browseMessageList: (ChangeSet current methodsWithoutComments) name: 'methods lacking comments'"! Item was changed: ----- Method: Utilities class>>initializeClosures (in category 'closure support') ----- initializeClosures "Utilities initializeClosures" "Eliminate the prototype BlockContext from the specialObjectsArray. The VM doesn't use it. This paves the way for removing BlockCOntext altogether and merging ContextPart and MethodContext into e.g. Context." (Smalltalk specialObjectsArray at: 38) class == BlockContext ifTrue:[Smalltalk specialObjectsArray at: 38 put: nil]. "Remove unused class vars from CompiledMethod since we can't redefine its class definition directly. Add the new BlockClosure to the specialObjectsArray" (#( BlockNodeCache MethodProperties SpecialConstants) + intersection: CompiledMethod classPool keys asSet) - intersection: CompiledMethod classPool keys) do:[:classVarName| CompiledMethod removeClassVarName: classVarName]. Smalltalk recreateSpecialObjectsArray. "Recompile methods in ContextPart, superclasses and subclasses that access inst vars" ContextPart withAllSuperclasses, ContextPart allSubclasses asArray do:[:class| class instSize > 0 ifTrue:[ class allInstVarNames do:[:ivn| (class whichSelectorsAccess: ivn) do:[:sel| class recompile: sel]]]]! Item was changed: ----- Method: CodeLoader class>>exportCodeSegment:classes:keepSource: (in category 'utilities') ----- exportCodeSegment: exportName classes: aClassList keepSource: keepSources "Code for writing out a specific category of classes as an external image segment. Perhaps this should be a method." | is oldMethods newMethods classList symbolHolder fileName | keepSources ifTrue: [ self confirm: 'We are going to abandon sources. Quit without saving after this has run.' orCancel: [^self]]. classList := aClassList asArray. "Strong pointers to symbols" symbolHolder := Symbol allSymbols. oldMethods := OrderedCollection new: classList size * 150. newMethods := OrderedCollection new: classList size * 150. keepSources ifTrue: [ classList do: [:cl | + cl selectorsDo: - cl selectors do: [:selector | | m oldCodeString methodNode | m := cl compiledMethodAt: selector. m fileIndex > 0 ifTrue: [oldCodeString := cl sourceCodeAt: selector. methodNode := cl compilerClass new parse: oldCodeString in: cl notifying: nil. oldMethods addLast: m. newMethods addLast: (m copyWithTempsFromMethodNode: methodNode)]]]]. oldMethods asArray elementsExchangeIdentityWith: newMethods asArray. oldMethods := newMethods := nil. Smalltalk garbageCollect. is := ImageSegment new copyFromRootsForExport: classList. "Classes and MetaClasses" fileName := FileDirectory fileName: exportName extension: ImageSegment fileExtension. is writeForExport: fileName. self compressFileNamed: fileName ! Item was changed: ----- Method: ImageSegment>>findRogueRootsRefStrm: (in category 'testing') ----- findRogueRootsRefStrm: rootArray "This is a tool to track down unwanted pointers into the segment. If we don't deal with these pointers, the segment turns out much smaller than it should. These pointers keep a subtree of objects out of the segment. 1) assemble all objects that should be in the segment by using SmartReference Stream and a dummyReference Stream. Put in a Set. 2) Remove the roots from this list. Ask for senders of each. Of the senders, forget the ones that are in the segment already. Keep others. The list is now all the 'incorrect' pointers into the segment." | dummy goodInSeg inSeg ok pointIn | dummy := ReferenceStream on: (DummyStream on: nil). "Write to a fake Stream, not a file" rootArray do: [:root | dummy rootObject: root. "inform him about the root" dummy nextPut: root]. + inSeg := dummy references keys asSet. - inSeg := dummy references keys. dummy := nil. Smalltalk garbageCollect. "dump refs dictionary" rootArray do: [:each | inSeg remove: each ifAbsent: []]. "want them to be pointed at from outside" pointIn := IdentitySet new: 500. goodInSeg := IdentitySet new: 2000. inSeg do: [:obj | ok := obj class isPointers. obj class == Color ifTrue: [ok := false]. obj class == TranslucentColor ifTrue: [ok := false]. obj class == Array ifTrue: [obj size = 0 ifTrue: [ok := false]]. "shared #() in submorphs of all Morphs" ok ifTrue: [goodInSeg add: obj]]. goodInSeg do: [:ob | pointIn addAll: (Utilities pointersTo: ob except: #())]. inSeg do: [:each | pointIn remove: each ifAbsent: []]. rootArray do: [:each | pointIn remove: each ifAbsent: []]. pointIn remove: inSeg array ifAbsent: []. pointIn remove: goodInSeg array ifAbsent: []. pointIn remove: pointIn array ifAbsent: []. self halt: 'Examine local variables pointIn and inSeg'. ^pointIn! Item was changed: ----- Method: SystemNavigation>>browseClassVarRefs: (in category 'browse') ----- browseClassVarRefs: aClass "Put up a menu offering all class variable names; if the user chooses one, open up a message-list browser on all methods that refer to the selected class variable" | lines labelStream vars allVars index owningClasses | lines := OrderedCollection new. allVars := OrderedCollection new. owningClasses := OrderedCollection new. labelStream := WriteStream on: (String new: 200). aClass withAllSuperclasses reverseDo: [:class | + vars := class classVarNames. - vars := class classVarNames asSortedCollection. vars do: [:var | labelStream nextPutAll: var; cr. allVars add: var. owningClasses add: class]. vars isEmpty ifFalse: [lines add: allVars size]]. labelStream contents isEmpty ifTrue: [^Beeper beep]. "handle nil superclass better" labelStream skip: -1 "cut last CR". index := (UIManager default chooseFrom: (labelStream contents substrings) lines: lines). index = 0 ifTrue: [^ self]. self browseAllCallsOn: ((owningClasses at: index) classPool associationAt: (allVars at: index))! Item was changed: ----- Method: SystemDictionary>>abandonSources (in category 'shrinking') ----- abandonSources "Smalltalk abandonSources" "Replaces every method by a copy with the 4-byte source pointer replaced by a string of all arg and temp names, followed by its length. These names can then be used to inform the decompiler." "wod 11/3/1998: zap the organization before rather than after condensing changes." "eem 7/1/2009 13:59 update for the closure schematic temp names regime" | oldMethods newMethods bTotal bCount | (self confirm: 'This method will preserve most temp names (up to about 15k characters of temporaries) while allowing the sources file to be discarded. -- CAUTION -- If you have backed up your system and are prepared to face the consequences of abandoning source code files, choose Yes. If you have any doubts, you may choose No to back out with no harm done.') == true ifFalse: [^ self inform: 'Okay - no harm done']. self forgetDoIts. oldMethods := OrderedCollection new: CompiledMethod instanceCount. newMethods := OrderedCollection new: CompiledMethod instanceCount. bTotal := 0. bCount := 0. self systemNavigation allBehaviorsDo: [:b | bTotal := bTotal + 1]. 'Saving temp names for better decompilation...' displayProgressAt: Sensor cursorPoint from: 0 to: bTotal during: [:bar | self systemNavigation allBehaviorsDo: [:cl | "for test: (Array with: Arc with: Arc class) do:" bar value: (bCount := bCount + 1). + cl selectorsDo: - cl selectors do: [:selector | | m oldCodeString methodNode | m := cl compiledMethodAt: selector. m fileIndex > 0 ifTrue: [oldCodeString := cl sourceCodeAt: selector. methodNode := cl compilerClass new parse: oldCodeString in: cl notifying: nil. oldMethods addLast: m. newMethods addLast: (m copyWithTempsFromMethodNode: methodNode)]]]]. oldMethods asArray elementsExchangeIdentityWith: newMethods asArray. self systemNavigation allBehaviorsDo: [:b | b zapOrganization]. self condenseChanges. Preferences disable: #warnIfNoSourcesFile! Item was changed: ----- Method: ModifiedClassDefinitionEvent>>classVarNames (in category 'accessing') ----- classVarNames + ^ item classVarNames! - ^ item classVarNames asSet! Item was changed: ----- Method: ModifiedClassDefinitionEvent>>oldClassVarNames (in category 'accessing') ----- oldClassVarNames + ^ oldItem classVarNames! - ^ oldItem classVarNames asSet! Item was changed: ----- Method: FilePackage>>conflictsWithUpdatedMethods (in category 'conflict checker') ----- conflictsWithUpdatedMethods "Check this package for conflicts with methods in the image which are in newer updates." | localFileName stream updateNumberString updateNumber imageUpdateNumber updateNumberChangeSet conflicts fileStream | localFileName := FileDirectory localNameFor: fullName. stream := ReadStream on: sourceSystem. stream upToAll: 'latest update: #'. updateNumberString := stream upTo: $]. stream close. fileStream := FileStream readOnlyFileNamed: fullName. (fileStream contentsOfEntireFile includes: Character linefeed) ifTrue: [self notifyWithLabel: 'The changeset file ', localFileName, ' contains linefeeds. Proceed if... you know that this is okay (e.g. the file contains raw binary data).']. fileStream close. updateNumberString isEmpty ifFalse: "remove prepended junk, if any" [updateNumberString := (updateNumberString findTokens: Character space) last]. updateNumberString asInteger ifNil: [(self confirm: 'Error: ', localFileName, ' has no valid Latest Update number in its header. Do you want to enter an update number for this file?') ifFalse: [^ self] ifTrue: [updateNumberString := UIManager default request: 'Please enter the estimated update number (e.g. 4332).']]. updateNumberString asInteger ifNil: [self inform: 'Conflict check cancelled.'. ^ self]. updateNumber := updateNumberString asInteger. imageUpdateNumber := SystemVersion current highestUpdate. updateNumber > imageUpdateNumber ifTrue: [(self confirm: 'Warning: The update number for this file (#', updateNumberString, ') is greater than the highest update number for this image (#', imageUpdateNumber asString, '). This probably means you need to update your image. Should we proceed anyway as if the file update number is #', imageUpdateNumber asString, '?') ifTrue: [updateNumber := imageUpdateNumber. updateNumberString := imageUpdateNumber asString] ifFalse: [^ self]]. updateNumberChangeSet := self findUpdateChangeSetMatching: updateNumber. updateNumberChangeSet ifNil: [^ self]. Smalltalk isMorphic ifTrue: [self currentWorld findATranscript: self currentEvent]. self class logCr; logCr; log: 'Checking ', localFileName, ' (#', updateNumberString, ') for method conflicts with changesets after ', updateNumberChangeSet name, ' ...'. conflicts := OrderedCollection new. self classes do: [:pseudoClass | (Array with: pseudoClass with: pseudoClass metaClass) do: [:classOrMeta | + classOrMeta selectorsDo: [:selector | | conflict | - classOrMeta selectors do: [:selector | | conflict | conflict := self checkForMoreRecentUpdateThanChangeSet: updateNumberChangeSet pseudoClass: classOrMeta selector: selector. conflict ifNotNil: [conflicts add: conflict]. ]. ]. ]. self class logCr; log: conflicts size asString, (' conflict' asPluralBasedOn: conflicts), ' found.'; logCr. self class closeLog. ^ conflicts! Item was changed: ----- Method: PseudoClass>>needsInitialize (in category 'testing') ----- needsInitialize ^self hasMetaclass and:[ + self metaClass includesSelector: #initialize]! - self metaClass selectors includes: #initialize]! Item was changed: ----- Method: SystemDictionary>>testFormatter (in category 'housekeeping') ----- testFormatter "Smalltalk testFormatter" "Reformats the source for every method in the system, and then compiles that source and verifies that it generates identical code. The formatting used will be either classic monochrome or fancy polychrome, depending on the setting of the preference #colorWhenPrettyPrinting." "Note: removed references to Preferences colorWhenPrettyPrinting and replaced them simply with false, as I've been removing this preference lately. --Ron Spengler 8/23/09" | newCodeString methodNode oldMethod newMethod badOnes n | badOnes := OrderedCollection new. self forgetDoIts. 'Formatting all classes...' displayProgressAt: Sensor cursorPoint from: 0 to: CompiledMethod instanceCount during: [:bar | n := 0. self systemNavigation allBehaviorsDo: [:cls | "Transcript cr; show: cls name." + cls selectorsDo: - cls selectors do: [:selector | (n := n + 1) \\ 100 = 0 ifTrue: [bar value: n]. newCodeString := cls prettyPrinterClass format: (cls sourceCodeAt: selector) in: cls notifying: nil decorated: false. methodNode := cls compilerClass new compile: newCodeString in: cls notifying: nil ifFail: []. newMethod := methodNode generate: #(0 0 0 0). oldMethod := cls compiledMethodAt: selector. oldMethod = newMethod ifFalse: [Transcript cr; show: '***' , cls name , ' ' , selector. badOnes add: cls name , ' ' , selector]]]]. self systemNavigation browseMessageList: badOnes asSortedCollection name: 'Formatter Discrepancies'! Item was changed: ----- Method: SystemDictionary>>abandonTempNames (in category 'shrinking') ----- abandonTempNames "Replaces every method by a copy with no source pointer or encoded temp names." "Smalltalk abandonTempNames" | continue oldMethods newMethods n m | continue := self confirm: '-- CAUTION -- If you have backed up your system and are prepared to face the consequences of abandoning all source code, hit Yes. If you have any doubts, hit No, to back out with no harm done.'. continue ifFalse: [^ self inform: 'Okay - no harm done']. self forgetDoIts; garbageCollect. oldMethods := OrderedCollection new. newMethods := OrderedCollection new. n := 0. 'Removing temp names to save space...' displayProgressAt: Sensor cursorPoint from: 0 to: CompiledMethod instanceCount during: [:bar | self systemNavigation + allBehaviorsDo: [:cl | cl selectorsDo: [:sel | - allBehaviorsDo: [:cl | cl selectors - do: [:sel | bar value: (n := n + 1). m := cl compiledMethodAt: sel. oldMethods addLast: m. newMethods addLast: (m copyWithTrailerBytes: #(0 ))]]]. oldMethods asArray elementsExchangeIdentityWith: newMethods asArray. SmalltalkImage current closeSourceFiles. self flag: #shouldUseAEnsureBlockToBeSureThatTheFileIsClosed. "sd: 17 April 2003" Preferences disable: #warnIfNoChangesFile. Preferences disable: #warnIfNoSourcesFile!
More information about the Squeak-dev mailing list |