[Pkg] The Trunk: System-nice.234.mcz
commits at source.squeak.org
commits at source.squeak.org
Fri Jan 15 22:20:01 UTC 2010
Nicolas Cellier uploaded a new version of System to project The Trunk:
http://source.squeak.org/trunk/System-nice.234.mcz
==================== Summary ====================
Name: System-nice.234
Author: nice
Time: 15 January 2010, 11:19:25.276 pm
UUID: f3790ea9-06df-4250-a6a6-08aaf019eacc
Ancestors: System-bf.233
use methodsDo: or selectorsAndMethodsDo: to fast up some browsing
=============== Diff against System-bf.233 ===============
Item was changed:
----- Method: SystemNavigation>>allUnimplementedCalls (in category 'query') -----
allUnimplementedCalls
"Answer an Array of each message that is sent by an expression in a
method but is not implemented by any object in the system."
| aStream all |
all := self allImplementedMessages.
aStream := WriteStream
on: (Array new: 50).
Cursor execute
showWhile: [self
allBehaviorsDo: [:cl | cl
+ selectorsAndMethodsDo: [:sel :method |
+ | secondStream |
- selectorsDo: [:sel | | secondStream |
secondStream := WriteStream
on: (String new: 5).
+ method messages
- (cl compiledMethodAt: sel) messages
do: [:m | (all includes: m)
ifFalse: [secondStream nextPutAll: m;
space]].
secondStream position = 0
ifFalse: [aStream nextPut: cl name , ' ' , sel , ' calls: ' , secondStream contents]]]].
^ aStream contents!
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 |
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 methodsDo: [:m |
- allBehaviorsDo: [:cl | cl selectorsDo: [:sel | | m |
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!
Item was changed:
----- Method: SystemNavigation>>allUnimplementedNonPrimitiveCalls (in category 'query') -----
allUnimplementedNonPrimitiveCalls
"Answer an Array of each message that is sent by an expression in a
method but is not implemented by any object in the system."
| aStream all |
all := self systemNavigation allImplementedMessages.
aStream := WriteStream
on: (Array new: 50).
Cursor execute
showWhile: [self systemNavigation
allBehaviorsDo: [:cl | cl
+ selectorsAndMethodsDo: [:sel :meth |
+ | secondStream |
- selectorsDo: [:sel | | secondStream meth |
secondStream := WriteStream
on: (String new: 5).
- meth := cl compiledMethodAt: sel.
meth primitive = 0 ifTrue: [
meth messages
do: [:m | (all includes: m)
ifFalse: [secondStream nextPutAll: m;
space]].
secondStream position = 0
ifFalse: [aStream nextPut: cl name , ' ' , sel , ' calls: ' , secondStream contents]]]]].
^ aStream contents!
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 selectorsAndMethodsDo:
+ [:selector :m |
+ | oldCodeString methodNode |
- cl selectorsDo:
- [: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: SystemNavigation>>allPrimitiveMethodsInCategories: (in category 'query') -----
allPrimitiveMethodsInCategories: aList
"Answer an OrderedCollection of all the methods that are implemented by
primitives in the given categories. 1/26/96 sw"
"SystemNavigation new allPrimitiveMethodsInCategories:
#('Collections-Streams' 'Files-Streams' 'Files-Abstract' 'Files-Macintosh')"
| aColl |
aColl := OrderedCollection new: 200.
Cursor execute
showWhile: [self
allBehaviorsDo: [:aClass | (aList includes: (SystemOrganization categoryOfElement: aClass theNonMetaClass name asString) asString)
ifTrue: [aClass
+ selectorsAndMethodsDo: [:sel :method |
- selectorsDo: [:sel | | method |
- method := aClass compiledMethodAt: sel.
method primitive ~= 0
ifTrue: [aColl addLast: aClass name , ' ' , sel , ' ' , method primitive printString]]]]].
^ aColl!
Item was changed:
----- Method: SystemNavigation>>unimplemented (in category 'query') -----
unimplemented
"Answer an Array of each message that is sent by an expression in a method but is not implemented by any object in the system."
| all unimplemented |
all := IdentitySet new: Symbol instanceCount * 2.
Cursor wait showWhile:
[self allBehaviorsDo: [:cl | cl selectorsDo: [:aSelector | all add: aSelector]]].
unimplemented := IdentityDictionary new.
Cursor execute showWhile: [
self allBehaviorsDo: [:cl |
+ cl selectorsAndMethodsDo: [:sel :meth |
+ meth messages do: [:m | | entry |
- cl selectorsDo: [:sel |
- (cl compiledMethodAt: sel) messages do: [:m | | entry |
(all includes: m) ifFalse: [
entry := unimplemented at: m ifAbsent: [Array new].
entry := entry copyWith: (cl name, '>', sel).
unimplemented at: m put: entry]]]]].
^ unimplemented
!
Item was changed:
----- Method: SystemNavigation>>selectAllMethodsNoDoits: (in category 'query') -----
selectAllMethodsNoDoits: aBlock
"Like allSelect:, but strip out Doits"
| aCollection |
aCollection := SortedCollection new.
Cursor execute
showWhile: [self
allBehaviorsDo: [:class | class
+ selectorsAndMethodsDo: [:sel :m | (sel isDoIt not
+ and: [aBlock value: m])
- selectorsDo: [:sel | (sel isDoIt not
- and: [aBlock
- value: (class compiledMethodAt: sel)])
ifTrue: [aCollection
add: (MethodReference new setStandardClass: class methodSymbol: sel)]]]].
^ aCollection!
Item was changed:
----- Method: ImageSegment>>rootsIncludingBlockMethods (in category 'read/write segment') -----
rootsIncludingBlockMethods
"Return a new roots array with more objects. (Caller should store into rootArray.) Any CompiledMethods that create blocks will be in outPointers if the block is held outside of this segment. Put such methods into the roots list. Then ask for the segment again."
| myClasses extras |
userRootCnt ifNil: [userRootCnt := arrayOfRoots size].
extras := OrderedCollection new.
myClasses := OrderedCollection new.
arrayOfRoots do: [:aRoot | aRoot class class == Metaclass ifTrue: [
myClasses add: aRoot]].
myClasses isEmpty ifTrue: [^ nil]. "no change"
outPointers do: [:anOut | | gotIt |
anOut class == CompiledMethod ifTrue: [
"specialized version of who"
gotIt := false.
myClasses detect: [:class |
+ class methodsDo: [:m |
+ m == anOut
- class selectorsDo: [:sel |
- (class compiledMethodAt: sel) == anOut
ifTrue: [extras add: anOut. gotIt := true]].
gotIt]
ifNone: []
].
].
extras := extras select: [:ea | (arrayOfRoots includes: ea) not].
extras isEmpty ifTrue: [^ nil]. "no change"
^ arrayOfRoots, extras!
Item was changed:
----- Method: SystemNavigation>>allMethodsSelect: (in category 'query') -----
allMethodsSelect: aBlock
"Answer a SortedCollection of each method that, when used as the block
argument to aBlock, gives a true result."
| aCollection |
aCollection := SortedCollection new.
Cursor execute
showWhile: [self
allBehaviorsDo: [:class | class
+ selectorsAndMethodsDo: [:sel :m | (aBlock value: m)
- selectorsDo: [:sel | (aBlock
- value: (class compiledMethodAt: sel))
ifTrue: [aCollection
add: (MethodReference new setStandardClass: class methodSymbol: sel)]]]].
^ aCollection!
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 selectorsAndMethodsDo:
+ [:selector :m |
+ | oldCodeString methodNode |
- cl selectorsDo:
- [: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: SystemNavigation>>allMethodsNoDoitsSelect: (in category 'query') -----
allMethodsNoDoitsSelect: aBlock
"Like allSelect:, but strip out Doits"
| aCollection |
aCollection := SortedCollection new.
Cursor execute
showWhile: [self
allBehaviorsDo: [:class | class
+ selectorsAndMethodsDo: [:sel :m | (sel isDoIt not
+ and: [aBlock value: m])
- selectorsDo: [:sel | (sel isDoIt not
- and: [aBlock
- value: (class compiledMethodAt: sel)])
ifTrue: [aCollection
add: (MethodReference new setStandardClass: class methodSymbol: sel)]]]].
^ aCollection!
Item was changed:
----- Method: SystemNavigation>>allPrimitiveMethods (in category 'query') -----
allPrimitiveMethods
"Answer an OrderedCollection of all the methods that are implemented by primitives."
| aColl |
aColl := OrderedCollection new: 200.
Cursor execute
showWhile: [self allBehaviorsDo: [:class | class
+ selectorsAndMethodsDo: [:sel :method |
- selectorsDo: [:sel | | method |
- method := class compiledMethodAt: sel.
method primitive ~= 0
ifTrue: [aColl addLast: class name , ' ' , sel , ' ' , method primitive printString]]]].
^ aColl!
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"
| badOnes |
badOnes := OrderedCollection new.
self forgetDoIts.
'Formatting all classes...'
displayProgressAt: Sensor cursorPoint
from: 0
to: CompiledMethod instanceCount
during:
[:bar | | n |
n := 0.
self systemNavigation allBehaviorsDo:
[:cls |
"Transcript cr; show: cls name."
+ cls selectorsAndMethodsDo:
+ [:selector :oldMethod |
+ | newMethod newCodeString methodNode |
- cls selectorsDo:
- [:selector | | newMethod newCodeString methodNode oldMethod |
(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.
- 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: DeepCopier>>mapUniClasses (in category 'like fullCopy') -----
mapUniClasses
"For new Uniclasses, map their class vars to the new objects. And their additional class instance vars. (scripts slotInfo) and cross references like (player321)."
"Players also refer to each other using associations in the References dictionary. Search the methods of our Players for those. Make new entries in References and point to them."
| pp newKey |
newUniClasses ifFalse: [^ self]. "All will be siblings. uniClasses is empty"
"Uniclasses use class vars to hold onto siblings who are referred to in code"
pp := (Smalltalk at: #Player ifAbsent:[^self]) class superclass instSize.
uniClasses do: [:playersClass | "values = new ones"
playersClass classPool associationsDo: [:assoc |
assoc value: (assoc value veryDeepCopyWith: self)].
playersClass scripts: (playersClass privateScripts veryDeepCopyWith: self). "pp+1"
"(pp+2) slotInfo was deepCopied in copyUniClass and that's all it needs"
pp+3 to: playersClass class instSize do: [:ii |
playersClass instVarAt: ii put:
((playersClass instVarAt: ii) veryDeepCopyWith: self)].
].
"Make new entries in References and point to them."
References keys "copy" do: [:playerName | | oldPlayer |
oldPlayer := References at: playerName.
(references includesKey: oldPlayer) ifTrue: [
newKey := (references at: oldPlayer) "new player" uniqueNameForReference.
"now installed in References"
(references at: oldPlayer) renameTo: newKey]].
uniClasses "values" do: [:newClass | | newSelList oldSelList |
oldSelList := OrderedCollection new. newSelList := OrderedCollection new.
+ newClass selectorsAndMethodsDo: [:sel :m |
+ m literals do: [:assoc | | newAssoc |
- newClass selectorsDo: [:sel |
- (newClass compiledMethodAt: sel) literals do: [:assoc | | newAssoc |
assoc isVariableBinding ifTrue: [
(References associationAt: assoc key ifAbsent: [nil]) == assoc ifTrue: [
newKey := (references at: assoc value ifAbsent: [assoc value])
externalName asSymbol.
(assoc key ~= newKey) & (References includesKey: newKey) ifTrue: [
newAssoc := References associationAt: newKey.
newClass methodDictionary at: sel put:
(newClass compiledMethodAt: sel) clone. "were sharing it"
(newClass compiledMethodAt: sel)
literalAt: ((newClass compiledMethodAt: sel) literals indexOf: assoc)
put: newAssoc.
(oldSelList includes: assoc key) ifFalse: [
oldSelList add: assoc key. newSelList add: newKey]]]]]].
oldSelList with: newSelList do: [:old :new |
newClass replaceSilently: old to: new]]. "This is text replacement and can be wrong"!
Item was changed:
----- Method: SystemNavigation>>selectAllMethods: (in category 'query') -----
selectAllMethods: aBlock
"Answer a SortedCollection of each method that, when used as the block
argument to aBlock, gives a true result."
| aCollection |
aCollection := SortedCollection new.
Cursor execute
showWhile: [self
allBehaviorsDo: [:class | class
+ selectorsAndMethodsDo: [:sel :m | (aBlock value: m)
- selectorsDo: [:sel | (aBlock
- value: (class compiledMethodAt: sel))
ifTrue: [aCollection
add: (MethodReference new setStandardClass: class methodSymbol: sel)]]]].
^ aCollection!
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']"
| methodReferences |
methodReferences := OrderedCollection new.
self allBehaviorsDo:
+ [:aClass | aClass selectorsDo: [:sel :cm |
+ | timeStamp initials |
- [:aClass | aClass selectorsDo: [:sel | | timeStamp initials cm |
- 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!
More information about the Packages
mailing list