[Pkg] The Trunk: System-ul.441.mcz
commits at source.squeak.org
commits at source.squeak.org
Sat Jun 18 08:46:33 UTC 2011
Levente Uzonyi uploaded a new version of System to project The Trunk:
http://source.squeak.org/trunk/System-ul.441.mcz
==================== Summary ====================
Name: System-ul.441
Author: ul
Time: 17 June 2011, 4:28:10.269 pm
UUID: 0170f8e1-2323-c849-beec-6707d7f3315b
Ancestors: System-ul.440
- Removed invisible line feed characters from the source code of the Trunk image in the preamble.
- Don't send #forgetDoIts, because it's not needed anymore. Evaluate it one last time in the preamble.
- Deprecated SmalltalkImage >> #forgetDoIts.
- Use #repeat instead of [ true ] whileTrue and friends.
- Use #displayProgressFrom:to:during: instead of #displayProgressAt:from:to:during:
- Removed closure bootstap code from Utilities
=============== Diff against System-ul.440 ===============
Item was changed:
+ (PackageInfo named: 'System') preamble: 'Smalltalk forgetDoIts. "Just to be sure we don''t have any behind."
+
+ "Remove line feed characters from methods. MC doesn''t see them changed, so it''s not possible to fix them without changing their timestamp."
+ {{BlockContext . #durationToRun} . {BlockContext . #forkAt:named:} . {BlockContext . #forkNamed:} . {BreakpointManager class . #clear} . {CompiledMethodInspector . #contentsIsString} . {CompiledMethodInspector . #selectionUnmodifiable} . {Delay class . #forDuration:} . {DigitalSignatureAlgorithm . #initRandomNonInteractively} . {DummySoundSystem . #randomBitsFromSoundInput:} . {EToyVocabulary . #categoryListForInstance:ofClass:limitClass:} . {FormCanvas class . #extent:depth:origin:clipRect:} . {HTTPClient class . #isRunningInBrowser:} . {Integer . #asYear} . {KeyedSet . #addAll:} . {KeyedSet . #at:ifAbsentPut:} . {KeyedSet . #keysDo:} . {KeyedSet class . #keyBlock:} . {MCMcmReader . #configuration} . {MCMcmReader . #loadConfiguration} . {MCMcmReader . #loadVersionInfo} . {MCMcmReader . #version} . {MethodWithInterface . #allScriptActivationButtons} . {Month class . #indexOfMonth:} . {Number . #asDuration} . {Number . #day} . {Number . #days} . {Number . #hour} . {Number . #hours} . {Number . #milliSecond} . {Number . #milliSeconds} . {Number . #minute} . {Number . #minutes} . {Number . #nanoSecond} . {Number . #nanoSeconds} . {Number . #second} . {Number . #seconds} . {Number . #week} . {Number . #weeks} . {Object . #fixUponLoad:seg:} . {Object class . #categoryForUniclasses} . {PasteUpMorph . #drawSubmorphsOn:} . {PasteUpMorph . #handsDo:} . {PasteUpMorph . #handsReverseDo:} . {PasteUpMorph . #morphsInFrontOf:overlapping:do:} . {PasteUpMorph . #putUpNewMorphMenu} . {PasteUpMorph . #undoOrRedoCommand} . {Pen . #putDotOfDiameter:at:} . {Player . #getCount} . {Player . #getDotSize} . {Player . #getStringContents} . {Player . #getTrailStyle} . {Player . #insertCharacters:} . {Player . #insertContentsOf:} . {Player . #setDotSize:} . {Player . #setTrailStyle:} . {Player . #tellAllContents:} . {Player . #trailStyleForAllPens:} . {PreDebugWindow . #storeLog} . {Preferences class . #standaloneSecurityChecksEnabled} . {Process . #name} . {RecordingControlsMorph . #playback} . {RecordingControlsMorph . #trim} . {RunArray . #reversed} . {SampledSound class . #assimilateSoundsFrom:} . {SampledSound class . #universalSoundKeys} . {ScriptActivationButton . #addCustomMenuItems:hand:} . {SearchingViewer . #doSearchFrom:} . {SecurityManager . #printStateOn:} . {SoundReadoutTile . #handlerForMouseDown:} . {SoundReadoutTile . #setLiteral:} . {SoundReadoutTile . #updateLiteralLabel} . {SoundRecorder . #hasRecordedSound} . {SoundRecorder . #verifyExistenceOfRecordedSound} . {SoundTile . #handlerForMouseDown:} . {StackMorph . #addPageControlMorph:} . {StackMorph . #naturalPaneOrder} . {Stream . #isTypeHTTP} . {String . #asDateAndTime} . {String . #asDuration} . {String . #asTimeStamp} . {String . #asVersion} . {StringMorphEditor . #initialize} . {TextMorph . #cursorWrapped:} . {TextMorph . #elementCount} . {VersionHistory . #addNewVersionBasedOn:} . {VersionHistory . #allVersionsAfter:} . {VersionHistory . #allVersionsBefore:} . {VersionHistory . #canRemove:} . {VersionHistory . #firstVersion} . {VersionHistory . #includesVersion:} . {VersionHistory . #initializeVersionsAt:} . {VersionHistory . #mainLineStartingAt:} . {VersionHistory . #remove:} . {VersionHistory . #remove:ifAbsent:} . {VersionHistory . #removeBranch:} . {VersionHistory . #treeString} . {VersionHistory . #treeStringOn:startingAt:} . {VersionHistory . #treeStringStartingAt:} . {VersionHistory . #versionBefore:} . {VersionHistory . #versionsAfter:} . {VersionHistory class . #startingAt1} . {VersionHistory class . #startingAt:} . {VersionNumber . #<} . {VersionNumber . #=} . {VersionNumber . #branchNext} . {VersionNumber . #commonBase:} . {VersionNumber . #hash} . {VersionNumber . #inSameBranchAs:} . {VersionNumber . #initializeNumbers:} . {VersionNumber . #next} . {VersionNumber . #numbers} . {VersionNumber . #previous} . {VersionNumber . #printOn:} . {VersionNumber . #storeOn:} . {VersionNumber class . #first} . {VersionNumber class . #fromCollection:} . {VersionNumber class . #fromString:} . {ViewerLine . #removeGetterFeedback} . {ViewerLine . #removeHighlightFeedback} . {ViewerLine . #removeSetterFeedback} . {Vocabulary class . #initializeSilently}} do: [ :each |
+ | class selector method |
+ class := each first.
+ selector := each second.
+ method := class >> selector.
+ class
+ compile: method getSource asString withSqueakLineEndings
+ classified: (class organization categoryOfElement: selector)
+ withStamp: method timeStamp
+ notifying: nil ].'!
- (PackageInfo named: 'System') preamble: 'nil'!
Item was changed:
----- Method: ChangeSet class>>scanFile:from:to: (in category 'scanning') -----
scanFile: file from: startPosition to: stopPosition
| changeList |
changeList := OrderedCollection new.
file position: startPosition.
'Scanning ', file localName, '...'
+ displayProgressFrom: startPosition to: stopPosition
- displayProgressAt: Sensor cursorPoint
- from: startPosition to: stopPosition
during: [:bar | | itemPosition item prevChar |
[file position < stopPosition] whileTrue:[
bar value: file position.
[file atEnd not and: [file peek isSeparator]]
whileTrue: [prevChar := file next].
(file peekFor: $!!) ifTrue:[
(prevChar = Character cr or: [prevChar = Character lf])
ifTrue: [changeList addAll: (self scanCategory: file)].
] ifFalse:[
itemPosition := file position.
item := file nextChunk.
file skipStyleChunk.
item size > 0 ifTrue:[
changeList add: (ChangeRecord new file: file position: itemPosition type: #doIt).
].
].
]].
^changeList!
Item was changed:
----- Method: CodeLoader class>>compressFileNamed:in: (in category 'utilities') -----
compressFileNamed: aFileName in: aDirectory
"Compress the currently selected file"
| zipped buffer unzipped zipFileName |
unzipped := aDirectory readOnlyFileNamed: (aDirectory fullNameFor: aFileName).
unzipped binary.
zipFileName := aFileName copyUpToLast: $. .
zipped := aDirectory newFileNamed: (zipFileName, FileDirectory dot, ImageSegment compressedFileExtension).
zipped binary.
zipped := GZipWriteStream on: zipped.
buffer := ByteArray new: 50000.
+ 'Compressing ', zipFileName
+ displayProgressFrom: 0 to: unzipped size
- 'Compressing ', zipFileName displayProgressAt: Sensor cursorPoint
- from: 0 to: unzipped size
during:[:bar|
[unzipped atEnd] whileFalse:[
bar value: unzipped position.
zipped nextPutAll: (unzipped nextInto: buffer)].
zipped close.
unzipped close].
!
Item was changed:
----- Method: CodeLoader class>>signFilesFrom:to:key: (in category 'utilities') -----
signFilesFrom: sourceNames to: destNames key: privateKey
"Sign all the given files using the private key.
This will add an 's' to the extension of the file."
"| fd oldNames newNames |
fd := FileDirectory default directoryNamed:'unsigned'.
oldNames := fd fileNames.
newNames := oldNames collect:[:name| 'signed', FileDirectory slash, name].
oldNames := oldNames collect:[:name| 'unsigned', FileDirectory slash, name].
CodeLoader
signFilesFrom: oldNames
to: newNames
key: DOLPrivateKey."
| dsa |
dsa := DigitalSignatureAlgorithm new.
dsa initRandomNonInteractively.
+ 'Signing files...'
+ displayProgressFrom: 1 to: sourceNames size during:[:bar|
- 'Signing files...' displayProgressAt: Sensor cursorPoint
- from: 1 to: sourceNames size during:[:bar|
1 to: sourceNames size do:[:i|
bar value: i.
self signFile: (sourceNames at: i) renameAs: (destNames at: i) key: privateKey dsa: dsa]].
!
Item was changed:
----- Method: FilePackage>>fileInFrom: (in category 'reading') -----
fileInFrom: aStream
| changes |
changes := ChangeSet scanFile: aStream from: 0 to: aStream size.
aStream close.
('Processing ', self packageName)
+ displayProgressFrom: 1
- displayProgressAt: Sensor cursorPoint
- from: 1
to: changes size
during:[:bar| | chgRec |
1 to: changes size do:[:i|
bar value: i.
chgRec := changes at: i.
self perform: (chgRec type copyWith: $:) asSymbol
with: chgRec.
].
].!
Item was changed:
----- Method: FilePackage>>fromStream:named: (in category 'reading') -----
fromStream: aStream named: aName
| changes |
changes := ChangeSet scanFile: aStream from: 0 to: aStream size.
aStream close.
('Processing ', aName)
+ displayProgressFrom: 1
- displayProgressAt: Sensor cursorPoint
- from: 1
to: changes size
during:[:bar| | chgRec |
1 to: changes size do:[:i|
bar value: i.
chgRec := changes at: i.
self perform: (chgRec type copyWith: $:) asSymbol
with: chgRec.
].
].!
Item was changed:
----- Method: ImageSegment>>copyFromRootsForExport: (in category 'read/write segment') -----
copyFromRootsForExport: rootArray
"When possible, use copySmartRootsExport:. This way may not copy a complete tree of objects. Add to roots: all of the methods pointed to from the outside by blocks."
| newRoots list segSize symbolHolder |
arrayOfRoots := rootArray.
- Smalltalk forgetDoIts.
"self halt."
symbolHolder := Symbol allSymbols. "Hold onto Symbols with strong pointers,
so they will be in outPointers"
(newRoots := self rootsIncludingPlayers) ifNotNil: [
arrayOfRoots := newRoots]. "world, presenter, and all Player classes"
"Creation of the segment happens here"
self copyFromRoots: arrayOfRoots sizeHint: 0.
segSize := segment size.
[(newRoots := self rootsIncludingBlockMethods) == nil] whileFalse: [
arrayOfRoots := newRoots.
self copyFromRoots: arrayOfRoots sizeHint: segSize].
"with methods pointed at from outside"
[(newRoots := self rootsIncludingBlocks) == nil] whileFalse: [
arrayOfRoots := newRoots.
self copyFromRoots: arrayOfRoots sizeHint: segSize].
"with methods, blocks from outPointers"
"classes of receivers of blocks"
list := self compactClassesArray.
outPointers := outPointers, ((list select: [:cls | cls ~~ nil]), (Array with: 1717 with: list)).
"Zap sender of a homeContext. Can't send live stacks out."
1 to: outPointers size do: [:ii |
(outPointers at: ii) isBlock ifTrue: [outPointers at: ii put: nil].
(outPointers at: ii) class == MethodContext ifTrue: [outPointers at: ii put: nil]].
symbolHolder.!
Item was changed:
----- Method: ImageSegment>>copyFromRootsLocalFileFor:sizeHint: (in category 'read/write segment') -----
copyFromRootsLocalFileFor: rootArray sizeHint: segSize
"If the roots include a World, add its Player classes to the roots."
| newRoots |
arrayOfRoots := rootArray.
[(newRoots := self rootsIncludingPlayers) == nil] whileFalse: [
arrayOfRoots := newRoots]. "world, presenter, and all Player classes"
- Smalltalk forgetDoIts.
self copyFromRoots: arrayOfRoots sizeHint: segSize.
!
Item was changed:
----- Method: ImageSegment>>copySmartRootsExport: (in category 'read/write segment') -----
copySmartRootsExport: rootArray
"Use SmartRefStream to find the object. Make them all roots. Create the segment in memory. Project should be in first five objects in rootArray."
| newRoots list segSize symbolHolder replacements naughtyBlocks allClasses sizeHint proj dummy |
- Smalltalk forgetDoIts.
"self halt."
symbolHolder := Symbol allSymbols. "Hold onto Symbols with strong pointers,
so they will be in outPointers"
dummy := ReferenceStream on: (DummyStream on: nil).
"Write to a fake Stream, not a file"
"Collect all objects"
dummy insideASegment: true. "So Uniclasses will be traced"
dummy rootObject: rootArray. "inform him about the root"
dummy nextPut: rootArray.
(proj :=dummy project) ifNotNil: [self dependentsSave: dummy].
allClasses := SmartRefStream new uniClassInstVarsRefs: dummy.
"catalog the extra objects in UniClass inst vars. Put into dummy"
allClasses do: [:cls |
dummy references at: cls class put: false. "put Player5 class in roots"
dummy blockers removeKey: cls class ifAbsent: []].
"refs := dummy references."
arrayOfRoots := self smartFillRoots: dummy. "guaranteed none repeat"
self savePlayerReferences: dummy references. "for shared References table"
replacements := dummy blockers.
dummy project "recompute it" ifNil: [self error: 'lost the project!!'].
dummy project class == DiskProxy ifTrue: [self error: 'saving the wrong project'].
dummy := nil. "force GC?"
naughtyBlocks := arrayOfRoots select: [ :each |
(each isKindOf: ContextPart) and: [each hasInstVarRef]
].
"since the caller switched ActiveWorld, put the real one back temporarily"
naughtyBlocks isEmpty ifFalse: [
World becomeActiveDuring: [ | goodToGo |
goodToGo := (UIManager default
chooseFrom: #('keep going' 'stop and take a look')
title:
'Some block(s) which reference instance variables
are included in this segment. These may fail when
the segment is loaded if the class has been reshaped.
What would you like to do?') = 1.
goodToGo ifFalse: [
naughtyBlocks inspect.
self error: 'Here are the bad blocks'].
].
].
"Creation of the segment happens here"
"try using one-quarter of memory min: four megs to publish (will get bumped later)"
sizeHint := (Smalltalk garbageCollect // 4 // 4) min: 1024*1024.
self copyFromRoots: arrayOfRoots sizeHint: sizeHint areUnique: true.
segSize := segment size.
[(newRoots := self rootsIncludingBlockMethods) == nil] whileFalse: [
arrayOfRoots := newRoots.
self copyFromRoots: arrayOfRoots sizeHint: segSize areUnique: true].
"with methods pointed at from outside"
[(newRoots := self rootsIncludingBlocks) == nil] whileFalse: [
arrayOfRoots := newRoots.
self copyFromRoots: arrayOfRoots sizeHint: segSize areUnique: true].
"with methods, blocks from outPointers"
list := self compactClassesArray.
outPointers := outPointers, ((list select: [:cls | cls ~~ nil]), (Array with: 1717 with: list)).
1 to: outPointers size do: [:ii |
(outPointers at: ii) isBlock ifTrue: [outPointers at: ii put: nil].
(outPointers at: ii) class == MethodContext ifTrue: [outPointers at: ii put: nil].
"substitute new object in outPointers"
(replacements includesKey: (outPointers at: ii)) ifTrue: [
outPointers at: ii put: (replacements at: (outPointers at: ii))]].
proj ifNotNil: [self dependentsCancel: proj].
symbolHolder.!
Item was changed:
----- Method: ImageSegment>>findRogueRootsImSeg: (in category 'testing') -----
findRogueRootsImSeg: 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) Break all owner pointers in submorphs and all scripts.
2) Create the segment and look at outPointers.
3) Remove those we expect.
4) Remember to quit without saving -- the owner pointers are smashed."
| newRoots suspects bag1 bag2 |
arrayOfRoots := rootArray.
[(newRoots := self rootsIncludingPlayers) == nil] whileFalse: [
arrayOfRoots := newRoots]. "world, presenter, and all Player classes"
self findRogueRootsPrep. "and free that context!!"
- Smalltalk forgetDoIts.
Smalltalk garbageCollect.
self copyFromRoots: arrayOfRoots sizeHint: 0.
suspects := outPointers select: [:oo | oo isMorph].
suspects size > 0 ifTrue: [suspects inspect].
bag1 := Bag new. bag2 := Bag new.
outPointers do: [:key |
(key isKindOf: Class)
ifTrue: [bag2 add: key class name]
ifFalse: [(#(Symbol Point Rectangle True False String Float Color Form ColorForm StrikeFont Metaclass UndefinedObject TranslucentColor) includes: key class name)
ifTrue: [bag2 add: key class name]
ifFalse: [bag1 add: key class name]]].
"(bag sortedCounts) is the SortedCollection"
(StringHolder new contents: bag1 sortedCounts printString, '
', bag2 sortedCounts printString)
openLabel: 'Objects pointed at by the outside'.
self halt: 'Examine local variables pointIn and inSeg'.
"Use this in inspectors:
outPointers select: [:oo | oo class == <a Class>]. "
!
Item was changed:
----- Method: MessageTally>>spyAllEvery:on: (in category 'initialize-release') -----
spyAllEvery: millisecs on: aBlock
"Create a spy and spy on the given block at the specified rate."
"Spy all the system processes"
| myDelay time0 |
aBlock isBlock
ifFalse: [ self error: 'spy needs a block here' ].
self class: aBlock receiver class method: aBlock method.
"set up the probe"
myDelay := Delay forMilliseconds: millisecs.
time0 := Time millisecondClockValue.
gcStats := SmalltalkImage current getVMParameters.
Timer ifNotNil: [ self error: 'it seems a tally is already running' ].
Timer := [
+ [
- [true] whileTrue: [
| observedProcess startTime |
startTime := Time millisecondClockValue.
myDelay wait.
observedProcess := Processor preemptedProcess.
self
tally: observedProcess suspendedContext
in: observedProcess
"tally can be > 1 if ran a long primitive"
+ by: (Time millisecondClockValue - startTime) // millisecs] repeat.
- by: (Time millisecondClockValue - startTime) // millisecs].
nil] newProcess.
Timer priority: Processor timingPriority-1.
"activate the probe and evaluate the block"
Timer resume.
^ aBlock ensure: [
"cancel the probe and return the value"
"Could have already been terminated. See #terminateTimerProcess"
Timer ifNotNil: [
Timer terminate.
Timer := nil ].
"Collect gc statistics"
SmalltalkImage current getVMParameters keysAndValuesDo: [ :idx :gcVal |
gcVal ifNotNil: [ gcStats at: idx put: (gcVal - (gcStats at: idx)) ] ].
time := Time millisecondClockValue - time0]!
Item was changed:
----- Method: MessageTally>>spyEvery:on: (in category 'initialize-release') -----
spyEvery: millisecs on: aBlock
"Create a spy and spy on the given block at the specified rate."
"Spy only on the active process (in which aBlock is run)"
| myDelay time0 observedProcess |
aBlock isBlock
ifFalse: [ self error: 'spy needs a block here' ].
self class: aBlock receiver class method: aBlock method.
"set up the probe"
observedProcess := Processor activeProcess.
myDelay := Delay forMilliseconds: millisecs.
time0 := Time millisecondClockValue.
gcStats := SmalltalkImage current getVMParameters.
Timer ifNotNil: [ self error: 'it seems a tally is already running' ].
Timer := [
+ [
- [ true ] whileTrue: [
| startTime |
startTime := Time millisecondClockValue.
myDelay wait.
self
tally: Processor preemptedProcess suspendedContext
in: (observedProcess == Processor preemptedProcess ifTrue: [observedProcess] ifFalse: [nil])
"tally can be > 1 if ran a long primitive"
+ by: (Time millisecondClockValue - startTime) // millisecs] repeat.
- by: (Time millisecondClockValue - startTime) // millisecs].
nil] newProcess.
Timer priority: Processor timingPriority-1.
"activate the probe and evaluate the block"
Timer resume.
^ aBlock ensure: [
"cancel the probe and return the value"
"Could have already been terminated. See #terminateTimerProcess"
Timer ifNotNil: [
Timer terminate.
Timer := nil ].
"Collect gc statistics"
SmalltalkImage current getVMParameters keysAndValuesDo: [ :idx :gcVal |
gcVal ifNotNil: [ gcStats at: idx put: (gcVal - (gcStats at: idx)) ] ].
time := Time millisecondClockValue - time0 ]!
Item was changed:
----- Method: Project class>>spawnNewProcess (in category 'utilities') -----
spawnNewProcess
UIProcess := [
+ [World doOneCycle. Processor yield ] repeat.
- [World doOneCycle. Processor yield. false] whileFalse: [].
] newProcess priority: Processor userSchedulingPriority.
UIProcess resume!
Item was changed:
----- Method: ReferenceStream>>statisticsOfRefs (in category 'statistics') -----
statisticsOfRefs
"Analyze the information in references, the objects being written out"
| parents ownerBags tallies n nm owners |
parents := IdentityDictionary new: references size * 2.
n := 0.
'Finding Owners...'
+ displayProgressFrom: 0 to: references size
- displayProgressAt: Sensor cursorPoint
- from: 0 to: references size
during: [:bar |
references keysDo:
[:parent | | kids |
bar value: (n := n+1).
kids := parent class isFixed
ifTrue: [(1 to: parent class instSize) collect: [:i | parent
instVarAt: i]]
ifFalse: [parent class isBits ifTrue: [Array new]
ifFalse: [(1 to: parent basicSize) collect: [:i | parent basicAt:
i]]].
(kids select: [:x | references includesKey: x])
do: [:child | parents at: child put: parent]]].
ownerBags := Dictionary new.
tallies := Bag new.
n := 0.
'Tallying Owners...'
+ displayProgressFrom: 0 to: references size
- displayProgressAt: Sensor cursorPoint
- from: 0 to: references size
during: [:bar |
references keysDo: "For each class of obj, tally a bag of owner
classes"
[:obj | | objParent | bar value: (n := n+1).
nm := obj class name.
tallies add: nm.
owners := ownerBags at: nm ifAbsent: [ownerBags at: nm put: Bag new].
(objParent := parents at: obj ifAbsent: [nil]) == nil
ifFalse: [owners add: objParent class name]]].
^ String streamContents:
[:strm | tallies sortedCounts do:
[:assn | n := assn key. nm := assn value.
owners := ownerBags at: nm.
strm cr; nextPutAll: nm; space; print: n.
owners size > 0 ifTrue:
[strm cr; tab; print: owners sortedCounts]]]!
Item was changed:
----- Method: SmalltalkImage class>>cleanUp (in category 'class initialization') -----
cleanUp
"Flush caches"
Smalltalk flushClassNameCache.
Undeclared removeUnreferencedKeys.
- Smalltalk forgetDoIts.
Smalltalk removeObsoleteClassesFromCompactClassesArray!
Item was changed:
----- Method: SmalltalkImage>>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...'
+ displayProgressFrom: 0
- 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 |
m fileIndex > 0 ifTrue:
[oldCodeString := cl sourceCodeAt: selector.
methodNode := cl newCompiler
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: SmalltalkImage>>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 garbageCollect.
- self forgetDoIts; garbageCollect.
oldMethods := OrderedCollection new.
newMethods := OrderedCollection new.
n := 0.
'Removing temp names to save space...'
+ displayProgressFrom: 0
- displayProgressAt: Sensor cursorPoint
- from: 0
to: CompiledMethod instanceCount "This is just a rough guess."
during: [:bar | self systemNavigation
allBehaviorsDo: [:cl | cl methodsDo: [:m |
bar value: (n := n + 1).
oldMethods addLast: m.
newMethods
addLast: (m copyWithTrailerBytes: CompiledMethodTrailer empty)]]].
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: SmalltalkImage>>appendChangesTo: (in category 'housekeeping') -----
appendChangesTo: sourcesName
"Condense changes to the end of the given sources file.
If the file is the same as Smalltalk sourcesName, then just append
the changes. If the file is different, then copy the sources file and
append the changes afterwards."
"Smalltalk appendChangesTo: 'test123.sources'"
"To verify correctness of the operation run the following code:
[ | sourceMap |
sourceMap := Dictionary new.
(CompiledMethod allInstances select:[:cm| cm isInstalled]) do:[:cm|
sourceMap at: cm methodReference put:
(cm getSourceFor: cm selector in: cm methodClass)].
Smalltalk allClassesAndTraitsDo:[:aClass|
sourceMap at: aClass put: aClass comment].
Smalltalk appendChangesTo: 'verify.sources'.
(CompiledMethod allInstances select:[:cm| cm isInstalled]) do:[:cm|
self assert: (sourceMap at: cm methodReference) =
(cm getSourceFor: cm selector in: cm methodClass)].
Smalltalk allClassesAndTraitsDo:[:aClass|
self assert: (sourceMap at: aClass) = aClass comment].
]"
| fullName sourcesFile |
fullName := FileDirectory default fullNameFor: sourcesName.
(fullName endsWith: '.sources') ifFalse:[self error: 'New name must end with .sources'].
fullName = Smalltalk sourcesName ifFalse:[
"Copy sources file; change file name accordingly"
FileStream forceNewFileNamed: fullName do:[:newFile| | bufSize |
bufSize := 16r10000.
sourcesFile := (SourceFiles at: 1) readOnlyCopy.
sourcesFile position: 0.
+ 'Copying sources...'
+ displayProgressFrom: 0 to: sourcesFile size during:[:bar|
- 'Copying sources...' displayProgressAt: Sensor cursorPoint
- from: 0 to: sourcesFile size during:[:bar|
[sourcesFile atEnd] whileFalse:[
bar value: sourcesFile position.
newFile nextPutAll: (sourcesFile next: bufSize)]].
newFile position = sourcesFile size ifFalse:[self error: 'File copy failed'].
].
self setMacFileInfoOn: fullName.
"Change to the new sources file and reopen"
self closeSourceFiles.
SourceFileVersionString := (FileDirectory localNameFor: fullName)
allButLast: '.sources' size.
self openSourceFiles.
].
"We've copied the old to the new sources file; reopen the sources file read/write"
sourcesFile := SourceFiles at: 1.
sourcesFile close; open: sourcesFile fullName forWrite: true. "should be openReadWrite"
sourcesFile setToEnd; timeStamp. "remember when we did this"
"Copy method sources from changes to sources"
CompiledMethod allInstances do:[:method|
(method isInstalled and:[method fileIndex = 2]) ifTrue:[
| class selector category preamble changeList index chgRec string source |
class := method methodClass.
selector := method selector.
source := class sourceCodeAt: selector.
category := class organization categoryOfElement: selector.
preamble := class name, ' methodsFor: ', category asString printString,
' stamp: ', method timeStamp printString.
"Find the last version in the sources file; link up the prior: version"
changeList := ChangeSet scanVersionsOf: method
class: class meta: class isMeta category: category selector: selector.
index := changeList findLast:[:any| any fileIndex = 1].
index > 0 ifTrue:[
chgRec := changeList at: index.
preamble := preamble, ' prior: ', (SourceFiles
sourcePointerFromFileIndex: chgRec fileIndex
andPosition: chgRec position) printString].
"append to sources file"
sourcesFile setToEnd; cr; nextPut: $!!; nextChunkPut: preamble; cr.
string := RemoteString newString: source onFileNumber: 1 toFile: sourcesFile.
sourcesFile nextChunkPut: ' '.
method setSourcePosition: string position inFile: 1
].
] displayingProgress: 'Moving changes...'.
"Copy class comments from changes to sources"
self allClassesAndTraitsDo: [:classOrTrait |
classOrTrait moveClassCommentTo: sourcesFile fileIndex: 1.
].
"We've moved everything; reopen the source files"
self closeSourceFiles; openSourceFiles.
"Finally, run condenseChanges -- they *should* be empty
but it's better to be safe than sorry"
self condenseChanges.
!
Item was changed:
----- Method: SmalltalkImage>>compressSources (in category 'housekeeping') -----
compressSources
"Copy all the source file to a compressed file. Usually preceded by Smalltalk condenseSources."
"The new file will be created in the default directory, and the code in openSources
will try to open it if it is there, otherwise it will look for normal sources."
"Smalltalk compressSources"
| f cfName cf |
f := SourceFiles first readOnlyCopy binary. "binary to preserve utf8 encoding"
(f localName endsWith: 'sources')
ifTrue: [cfName := (f localName allButLast: 7) , 'stc']
ifFalse: [self error: 'Hey, I thought the sources name ended with ''.sources''.'].
cf := (CompressedSourceStream on: (FileStream newFileNamed: cfName))
segmentSize: 65536 maxSize: f size.
"Copy the sources"
'Compressing Sources File...'
+ displayProgressFrom: 0 to: f size
- displayProgressAt: Sensor cursorPoint
- from: 0 to: f size
during:
[:bar | f position: 0.
[f atEnd] whileFalse:
[cf nextPutAll: (f next: 65536).
bar value: f position]].
cf close.
self setMacFileInfoOn: cfName.
self inform: 'You now have a compressed sources file!!
Squeak will use it the next time you start.'!
Item was changed:
----- Method: SmalltalkImage>>condenseChanges (in category 'housekeeping') -----
condenseChanges
"Move all the changes onto a compacted sources file."
"Smalltalk condenseChanges"
| f oldChanges |
f := FileStream fileNamed: 'ST80.temp'.
f header; timeStamp.
'Condensing Changes File...'
+ displayProgressFrom: 0
- displayProgressAt: Sensor cursorPoint
- from: 0
to: self classNames size + self traitNames size
during: [:bar | | count |
count := 0.
self
allClassesAndTraitsDo: [:classOrTrait |
bar value: (count := count + 1).
classOrTrait moveChangesTo: f.
classOrTrait putClassCommentToCondensedChangesFile: f.
classOrTrait classSide moveChangesTo: f]].
SmalltalkImage current lastQuitLogPosition: f position.
f trailer; close.
oldChanges := SourceFiles at: 2.
oldChanges close.
FileDirectory default deleteFileNamed: oldChanges name , '.old';
rename: oldChanges name toBe: oldChanges name , '.old';
rename: f name toBe: oldChanges name.
self setMacFileInfoOn: oldChanges name.
SourceFiles
at: 2
put: (FileStream oldFileNamed: oldChanges name)!
Item was changed:
----- Method: SmalltalkImage>>condenseSources (in category 'housekeeping') -----
condenseSources
"Move all the changes onto a compacted sources file."
"Smalltalk condenseSources"
| newSourcesFile defaultDirectory newVersion currentVersion |
Utilities fixUpProblemsWithAllCategory.
"The above removes any concrete, spurious '-- all --' categories, which mess up the process."
defaultDirectory := FileDirectory default.
currentVersion := SmalltalkImage current sourceFileVersionString.
newVersion := UIManager default
request: 'Please designate the version\for the new source code file...' withCRs
initialAnswer: currentVersion.
newVersion ifEmpty: [ ^ self ].
newVersion = currentVersion ifTrue: [ ^ self error: 'The new source file must not be the same as the old.' ].
SmalltalkImage current sourceFileVersionString: newVersion.
"Write all sources with fileIndex 1"
newSourcesFile := defaultDirectory newFileNamed: (defaultDirectory localNameFor: SmalltalkImage current sourcesName).
newSourcesFile ifNil: [ ^ self error: 'Couldn''t create source code file in\' withCRs, defaultDirectory name].
newSourcesFile
header;
timeStamp.
'Condensing Sources File...'
+ displayProgressFrom: 0
- displayProgressAt: Sensor cursorPoint
- from: 0
to: self classNames size + self traitNames size
during:
[ :bar |
| count |
count := 0.
Smalltalk allClassesAndTraitsDo:
[ :classOrTrait |
bar value: (count := count + 1).
classOrTrait
fileOutOn: newSourcesFile
moveSource: true
toFile: 1 ] ].
newSourcesFile
trailer;
close.
"Make a new empty changes file"
SmalltalkImage current closeSourceFiles.
defaultDirectory
rename: SmalltalkImage current changesName
toBe: SmalltalkImage current changesName , '.old'.
(FileStream newFileNamed: SmalltalkImage current changesName)
header;
timeStamp;
close.
SmalltalkImage current lastQuitLogPosition: 0.
self setMacFileInfoOn: SmalltalkImage current changesName.
self setMacFileInfoOn: newSourcesFile name.
SmalltalkImage current openSourceFiles.
self inform: 'Source files have been rewritten to\' withCRs, newSourcesFile name, '\Check that all is well,\and then save/quit.' withCRs!
Item was changed:
----- Method: SmalltalkImage>>forgetDoIts (in category 'housekeeping') -----
forgetDoIts
+
+ self deprecated: 'This method does not have to be sent anymore!!'
- "Smalltalk forgetDoIts"
- "get rid of old DoIt methods"
-
- self systemNavigation allBehaviorsDo:
- [:cl | cl forgetDoIts]
-
!
Item was changed:
----- Method: SmalltalkImage>>listBuiltinModules (in category 'modules') -----
listBuiltinModules
"SmalltalkImage current listBuiltinModules"
"Return a list of all builtin modules (e.g., plugins). Builtin plugins are those that are compiled with the VM directly, as opposed to plugins residing in an external shared library. The list will include all builtin plugins regardless of whether they are currently loaded
or not. Note that the list returned is not sorted!!"
| modules index name |
+ modules := WriteStream on: (Array new: 20).
- modules := WriteStream on: Array new.
index := 1.
+ [
- [true] whileTrue:[
name := self listBuiltinModule: index.
name ifNil:[^modules contents].
modules nextPut: name.
+ index := index + 1 ] repeat!
- index := index + 1.
- ].!
Item was changed:
----- Method: SmalltalkImage>>listLoadedModules (in category 'modules') -----
listLoadedModules
"SmalltalkImage current listLoadedModules"
"Return a list of all currently loaded modules (e.g., plugins). Loaded modules are those that currently in use (e.g., active). The list returned will contain all currently active modules regardless of whether they're builtin (that is compiled with the VM) or external (e.g., residing in some external shared library). Note that the returned list is not sorted!!"
| modules index name |
+ modules := WriteStream on: (Array new: 20).
- modules := WriteStream on: Array new.
index := 1.
+ [
- [true] whileTrue:[
name := self listLoadedModule: index.
name ifNil:[^modules contents].
modules nextPut: name.
+ index := index + 1 ] repeat!
- index := index + 1.
- ].!
Item was changed:
----- Method: SmalltalkImage>>presumedSentMessages (in category 'shrinking') -----
presumedSentMessages | sent |
"Smalltalk presumedSentMessages"
"The following should be preserved for doIts, etc"
sent := IdentitySet new.
#( rehashWithoutBecome compactSymbolTable rebuildAllProjects
browseAllSelect: lastRemoval
scrollBarValue: vScrollBarValue: scrollBarMenuButtonPressed:
withSelectionFrom: to: removeClassNamed:
dragon: hilberts: mandala: web test3 factorial tinyBenchmarks benchFib
+ newDepth: restoreAfter: zapAllMethods obsoleteClasses
- 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..."
(Smalltalk at: #ParagraphEditor) ifNotNilDo: [:paragraphEditor |
(paragraphEditor classPool at: #CmdActions) asSet do:
[:sel | sent add: sel].
(paragraphEditor classPool at: #ShiftCmdActions) asSet do:
[:sel | sent add: sel]].
^ sent!
Item was changed:
----- Method: SmalltalkImage>>removeAllUnSentMessages (in category 'shrinking') -----
removeAllUnSentMessages
"Smalltalk removeAllUnSentMessages"
"[Smalltalk unusedClasses do: [:c | (Smalltalk at: c) removeFromSystem].
Smalltalk removeAllUnSentMessages > 0] whileTrue."
"Remove all implementations of unsent messages."
| sels n |
sels := self systemNavigation allUnSentMessages.
"The following should be preserved for doIts, etc"
"needed even after #majorShrink is pulled"
+ #(#rehashWithoutBecome #compactSymbolTable #rebuildAllProjects #browseAllSelect: #lastRemoval #scrollBarValue: vScrollBarValue: #scrollBarMenuButtonPressed: #withSelectionFrom: #to: #removeClassNamed: #dragon: #hilberts: #mandala: #web #test3 #factorial #tinyBenchmarks #benchFib #newDepth: #restoreAfter: #zapAllMethods #obsoleteClasses #removeAllUnSentMessages #abandonSources #removeUnreferencedKeys #reclaimDependents #zapOrganization #condenseChanges #browseObsoleteReferences #subclass:instanceVariableNames:classVariableNames:poolDictionaries:category: #methodsFor:stamp: #methodsFor:stamp:prior: #instanceVariableNames: #startTimerInterruptWatcher #unusedClasses )
- #(#rehashWithoutBecome #compactSymbolTable #rebuildAllProjects #browseAllSelect: #lastRemoval #scrollBarValue: vScrollBarValue: #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 | sels
remove: sel
ifAbsent: []].
"The following may be sent by perform: in dispatchOnChar..."
(Smalltalk at: #ParagraphEditor) ifNotNilDo: [:paragraphEditor |
(paragraphEditor classPool at: #CmdActions) asSet
do: [:sel | sels
remove: sel
ifAbsent: []].
(paragraphEditor classPool at: #ShiftCmdActions) asSet
do: [:sel | sels
remove: sel
ifAbsent: []]].
sels size = 0
ifTrue: [^ 0].
n := 0.
self systemNavigation
allBehaviorsDo: [:x | n := n + 1].
'Removing ' , sels size printString , ' messages . . .'
+ displayProgressFrom: 0
- displayProgressAt: Sensor cursorPoint
- from: 0
to: n
during: [:bar |
n := 0.
self systemNavigation
allBehaviorsDo: [:class |
bar value: (n := n + 1).
sels
do: [:sel | class basicRemoveSelector: sel]]].
^ sels size!
Item was changed:
----- Method: SmalltalkImage>>unloadAllKnownPackages (in category 'shrinking') -----
unloadAllKnownPackages
"Unload all packages we know how to unload and reload"
"Prepare unloading"
Smalltalk zapMVCprojects.
Flaps disableGlobalFlaps: false.
StandardScriptingSystem removeUnreferencedPlayers.
Project removeAllButCurrent.
#('Morphic-UserObjects' 'EToy-UserObjects' 'Morphic-Imported' )
do: [:each | SystemOrganization removeSystemCategory: each].
Smalltalk at: #ServiceRegistry ifPresent:[:aClass|
SystemChangeNotifier uniqueInstance
noMoreNotificationsFor: aClass.
].
World removeAllMorphs.
"Go unloading"
#( 'ReleaseBuilder' 'ScriptLoader'
'311Deprecated' '39Deprecated'
'Universes' 'SMLoader' 'SMBase' 'Installer-Core'
'VersionNumberTests' 'VersionNumber'
'Services-Base' 'PreferenceBrowser' 'Nebraska'
'ToolBuilder-MVC' 'ST80'
'CollectionsTests' 'GraphicsTests' 'KernelTests' 'MorphicTests'
'MultilingualTests' 'NetworkTests' 'ToolsTests' 'TraitsTests'
'SystemChangeNotification-Tests' 'FlexibleVocabularies'
'EToys' 'Protocols' 'XML-Parser' 'Tests' 'SUnitGUI'
'Help-Squeak' 'HelpSystem' 'SystemReporter'
) do: [:pkgName|
(MCPackage named: pkgName) unload.
MCMcmUpdater disableUpdatesOfPackage: pkgName.
].
"Traits use custom unload"
Smalltalk at: #Trait ifPresent:[:aClass| aClass unloadTraits].
"Post-unload cleanup"
MCWorkingCopy flushObsoletePackageInfos.
SystemOrganization removeSystemCategory: 'UserObjects'.
Presenter defaultPresenterClass: nil.
World dumpPresenter.
ScheduledControllers := nil.
Preferences removePreference: #allowEtoyUserCustomEvents.
SystemOrganization removeEmptyCategories.
ChangeSet removeChangeSetsNamedSuchThat:[:cs | (cs == ChangeSet current) not].
Undeclared removeUnreferencedKeys.
StandardScriptingSystem initialize.
MCFileBasedRepository flushAllCaches.
MCDefinition clearInstances.
Behavior flushObsoleteSubclasses.
ChangeSet current clear.
ChangeSet current name: 'Unnamed1'.
Smalltalk flushClassNameCache.
Smalltalk at: #Browser ifPresent:[:br| br initialize].
DebuggerMethodMap voidMapCache.
DataStream initialize.
- Smalltalk forgetDoIts.
AppRegistry removeObsolete.
FileServices removeObsolete.
Preferences removeObsolete.
TheWorldMenu removeObsolete.
Smalltalk garbageCollect.
Symbol compactSymbolTable.
TheWorldMainDockingBar updateInstances.
MorphicProject defaultFill: (Color gray: 0.9).
World color: (Color gray: 0.9).
!
Item was changed:
----- Method: SmalltalkImage>>useUpMemory (in category 'memory space') -----
useUpMemory
"For testing the low space handler..."
"Smalltalk installLowSpaceWatcher; useUpMemory"
| lst |
lst := nil.
+ [ lst := Link nextLink: lst ] repeat!
- [true] whileTrue: [
- lst := Link nextLink: lst.
- ].!
Item was changed:
----- Method: SmartRefStream>>nextPut: (in category 'read write') -----
nextPut: anObject
"Really write three objects: (version, class structure, object). But only when called from the outside. If any instance-specific classes are present, prepend their source code. byteStream will be in fileOut format.
You can see an analysis of which objects are written out by doing:
(SmartRefStream statsOfSubObjects: anObject)
(SmartRefStream tallyOfSubObjects: anObject)
(SmartRefStream subObjects: anObject ofClass: aClass)"
| info |
topCall == nil
ifTrue:
[topCall := anObject.
'Please wait while objects are counted'
+ displayProgressFrom: 0 to: 10
- displayProgressAt: Sensor cursorPoint
- from: 0 to: 10
during: [:bar | info := self instVarInfo: anObject].
self appendClassDefns. "For instance-specific classes"
+ 'Writing an object file'
+ displayProgressFrom: 0 to: objCount*4 "estimate"
- 'Writing an object file' displayProgressAt: Sensor cursorPoint
- from: 0 to: objCount*4 "estimate"
during: [:bar |
objCount := 0.
progressBar := bar.
self setStream: byteStream reading: false.
"set basePos, but keep any class renames"
super nextPut: ReferenceStream versionCode.
super nextPut: info.
super nextPut: anObject. "<- the real writing"
classInstVars size > 0 ifTrue: [super nextPut: classInstVars]].
"Note: the terminator, $!!, is not doubled inside object data"
"references is an IDict of every object that got written"
byteStream ascii.
byteStream nextPutAll: '!!'; cr; cr.
byteStream padToEndWith: $ . "really want to truncate file, but can't"
topCall := progressBar := nil] "reset it"
ifFalse:
[super nextPut: anObject.
progressBar ifNotNil: [progressBar value: (objCount := objCount + 1)]].
"return the argument - added by kwl"
^ anObject
!
Item was changed:
----- Method: SmartRefStream>>nextPutObjOnly: (in category 'read write') -----
nextPutObjOnly: anObject
"Really write three objects: (version, class structure, object). But only when called from the outside. Not in fileOut format. No class definitions will be written for instance-specific classes. Error if find one. (Use nextPut: instead)"
| info |
topCall == nil
ifTrue:
[topCall := anObject.
super nextPut: ReferenceStream versionCode.
+ 'Please wait while objects are counted'
+ displayProgressFrom: 0 to: 10
- 'Please wait while objects are counted' displayProgressAt: Sensor cursorPoint
- from: 0 to: 10
during: [:bar |
info := self instVarInfo: anObject].
self uniClasesDo: [:cls | cls error: 'Class defn not written out. Proceed?'].
+ 'Writing an object file'
+ displayProgressFrom: 0 to: objCount*4 "estimate"
- 'Writing an object file' displayProgressAt: Sensor cursorPoint
- from: 0 to: objCount*4 "estimate"
during: [:bar |
objCount := 0.
progressBar := bar.
super nextPut: info.
super nextPut: anObject. "<- the real writing"
"Class inst vars not written here!!"].
"references is an IDict of every object that got written
(in case you want to take statistics)"
"Transcript cr; show: structures keys printString." "debug"
topCall := progressBar := nil] "reset it"
ifFalse:
[super nextPut: anObject.
progressBar ifNotNil: [progressBar value: (objCount := objCount + 1)]].!
Item was changed:
----- Method: SpaceTally>>printSpaceAnalysis:on: (in category 'fileOut') -----
printSpaceAnalysis: threshold on: fileName
"SpaceTally new printSpaceAnalysis: 1000 on: 'STspace.text1'"
"sd-This method should be rewrote to be more coherent within the rest of the class
ie using preAllocate and spaceForInstanceOf:"
"If threshold > 0, then only those classes with more than that number
of instances will be shown, and they will be sorted by total instance space.
If threshold = 0, then all classes will appear, sorted by name."
| f totalCodeSpace totalInstCount totalInstSpace n totalPercent |
Smalltalk garbageCollect.
totalCodeSpace := totalInstCount := totalInstSpace := n := 0.
results := OrderedCollection new: Smalltalk classNames size.
'Taking statistics...'
+ displayProgressFrom: 0
+ to: Smalltalk classNames size
- displayProgressAt: Sensor cursorPoint
- from: 0 to: Smalltalk classNames size
during: [:bar |
Smalltalk allClassesDo:
[:cl | | instSpace eltSize instCount codeSpace | codeSpace := cl spaceUsed.
bar value: (n := n+1).
Smalltalk garbageCollectMost.
instCount := cl instanceCount.
instSpace := (cl indexIfCompact > 0 ifTrue: [4] ifFalse: [8])*instCount. "Object headers"
cl isVariable
ifTrue: [eltSize := cl isBytes ifTrue: [1] ifFalse: [4].
cl allInstancesDo: [:x | instSpace := instSpace + (x basicSize*eltSize)]]
ifFalse: [instSpace := instSpace + (cl instSize*instCount*4)].
results add: (SpaceTallyItem analyzedClassName: cl name codeSize: codeSpace instanceCount: instCount spaceForInstances: instSpace).
totalCodeSpace := totalCodeSpace + codeSpace.
totalInstCount := totalInstCount + instCount.
totalInstSpace := totalInstSpace + instSpace]].
totalPercent := 0.0.
f := FileStream newFileNamed: fileName.
f timeStamp.
f nextPutAll: ('Class' padded: #right to: 30 with: $ );
nextPutAll: ('code space' padded: #left to: 12 with: $ );
nextPutAll: ('# instances' padded: #left to: 12 with: $ );
nextPutAll: ('inst space' padded: #left to: 12 with: $ );
nextPutAll: ('percent' padded: #left to: 8 with: $ ); cr.
threshold > 0 ifTrue:
["If inst count threshold > 0, then sort by space"
results := (results select: [:s | s instanceCount >= threshold or: [s spaceForInstances > (totalInstSpace // 500)]])
asSortedCollection: [:s :s2 | s spaceForInstances > s2 spaceForInstances]].
results do:
[:s | | percent | f nextPutAll: (s analyzedClassName padded: #right to: 30 with: $ );
nextPutAll: (s codeSize printString padded: #left to: 12 with: $ );
nextPutAll: (s instanceCount printString padded: #left to: 12 with: $ );
nextPutAll: (s spaceForInstances printString padded: #left to: 14 with: $ ).
percent := s spaceForInstances*100.0/totalInstSpace roundTo: 0.1.
totalPercent := totalPercent + percent.
percent >= 0.1 ifTrue:
[f nextPutAll: (percent printString padded: #left to: 8 with: $ )].
f cr].
f cr; nextPutAll: ('Total' padded: #right to: 30 with: $ );
nextPutAll: (totalCodeSpace printString padded: #left to: 12 with: $ );
nextPutAll: (totalInstCount printString padded: #left to: 12 with: $ );
nextPutAll: (totalInstSpace printString padded: #left to: 14 with: $ );
nextPutAll: ((totalPercent roundTo: 0.1) printString padded: #left to: 8 with: $ ).
f close!
Item was changed:
----- Method: SystemNavigation>>allMethodsWithSourceString:matchCase: (in category 'query') -----
allMethodsWithSourceString: aString matchCase: caseSensitive
"Answer a SortedCollection of all the methods that contain, in source code, aString as a substring. Search the class comments also"
| list adder |
list := Set new.
adder := [ :mrClass :mrSel | list add: ( MethodReference new
setStandardClass: mrClass
methodSymbol: mrSel)].
'Searching all source code...'
+ displayProgressFrom: 0 to: Smalltalk classNames size
- displayProgressAt: Sensor cursorPoint
- from: 0 to: Smalltalk classNames size
during: [:bar | | count |
count := 0.
SystemNavigation default allBehaviorsDo: [:each |
bar value: (count := count + 1).
each selectorsDo: [:sel |
((each sourceCodeAt: sel) findString: aString
startingAt: 1 caseSensitive: caseSensitive) > 0 ifTrue: [
sel isDoIt ifFalse: [adder value: each value: sel]]].
(each organization classComment asString findString: aString
startingAt: 1 caseSensitive: caseSensitive) > 0 ifTrue: [
adder value: each value: #Comment] ]].
^ list asSortedCollection!
Item was changed:
----- Method: SystemNavigation>>obsoleteMethodReferences (in category 'query') -----
obsoleteMethodReferences
"SystemNavigation default obsoleteMethodReferences"
"Open a browser on all referenced behaviors that are obsolete"
| obsClasses references |
references := WriteStream on: Array new.
obsClasses := self obsoleteBehaviors.
'Scanning for methods referencing obsolete classes'
+ displayProgressFrom: 1
- displayProgressAt: Sensor cursorPoint
- from: 1
to: obsClasses size
during:
[:bar |
obsClasses keysAndValuesDo:
[:index :each | | obsRefs |
bar value: index.
obsRefs := Utilities pointersTo: each except: obsClasses.
obsRefs do:
[:ref |
"Figure out if it may be a global"
(ref isVariableBinding and: [ref key isString "or Symbol"])
ifTrue:
[(Utilities pointersTo: ref) do:
[:meth |
(meth isKindOf: CompiledMethod)
ifTrue: [meth methodReference ifNotNil: [:mref | references nextPut: mref]]]]]]].
^references contents!
Item was removed:
- ----- Method: Utilities class>>compileUsingClosures (in category 'closure support') -----
- compileUsingClosures "Utilities compileUsingClosures"
- "Recompile the system and do some minimal clean-ups"
- | classes compilationErrors |
- Preferences setPreference: #allowBlockArgumentAssignment toValue: true.
- compilationErrors := Set new.
- classes := Smalltalk forgetDoIts allClasses reject: [:c| c name == #GeniePlugin].
-
- 'Recompiling The System' displayProgressAt: Sensor cursorPoint
- from: 0 to: classes size during:[:bar |
- classes withIndexDo:[:c :i|
- bar value: i.
- { c. c class } do:[:b|
- "Transcript cr; print: b; endEntry."
- b selectors "asSortedCollection" do:[:s|
- "Transcript cr; show: b asString, '>>', s."
- [b recompile: s from: b] on: Error do:[:ex|
- Transcript
- cr; nextPutAll: 'COMPILATION ERROR: ';
- print: b; nextPutAll: '>>'; nextPutAll: s; flush.
- compilationErrors add: (MethodReference class: b selector: s)]]]]].
-
- (Smalltalk respondsTo: #allTraits) ifTrue:[
- 'Recompiling Traits' displayProgressAt: Sensor cursorPoint
- from: 0 to: Smalltalk allTraits size during:[:bar |
- Smalltalk allTraits do:[:t|
- t selectors do:[:s|
- [t recompile: s] on: Error do:[:ex|
- Transcript
- cr; nextPutAll: 'COMPILATION ERROR: ';
- print: t; nextPutAll: '>>'; nextPutAll: s; flush.
- compilationErrors add: (MethodReference class: t selector: s)]]]]].
-
- compilationErrors notEmpty ifTrue:[
- SystemNavigation default
- browseMessageList: compilationErrors asSortedCollection
- name: 'Compilation Errors'].!
Item was removed:
- ----- 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)
- 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 removed:
- ----- Method: Utilities class>>postRecompileCleanup (in category 'closure support') -----
- postRecompileCleanup "Utilities postRecompileCleanup"
- "Cleanup after loading closure bootstrap"
- | unboundMethods contexts |
- ProcessorScheduler startUp.
- WeakArray restartFinalizationProcess.
- MethodChangeRecord allInstancesDo:[:x| x noteNewMethod: nil].
- Undeclared removeUnreferencedKeys.
- Delay startTimerEventLoop.
- EventSensor install.
- WorldState allInstancesDo:[:ws| ws convertAlarms; convertStepList].
- (Workspace canUnderstand: #initializeBindings)
- ifTrue:[Workspace allInstancesDo:[:ws| ws initializeBindings]].
- ExternalDropHandler initialize.
- ScrollBar initializeImagesCache.
- Smalltalk at: #Vocabulary ifPresent:[:aClass| aClass initialize].
- Smalltalk garbageCollect.
- GradientFillStyle initPixelRampCache.
- Smalltalk at: #ServiceGui ifPresent:[:sg| sg initialize].
- Smalltalk
- at: #SokobanMorph
- ifPresent: [:sm| sm initFields].
- Smalltalk
- at: #DebuggerMethodMap
- ifPresent: [:dmm| dmm voidMapCache].
- Smalltalk
- at: #KClipboard
- ifPresent: [:kcb| kcb clearDefault].
- Smalltalk
- at: #ServiceRegistry
- ifPresent: [:sr| sr rebuild].
- (ProcessBrowser respondsTo: #registerWellKnownProcesses) ifTrue:
- [ProcessBrowser registerWellKnownProcesses].
- Smalltalk
- at: #DebuggerMethodMap
- ifPresent: [:dmm| dmm voidMapCache].
- Smalltalk at: #ServiceRegistry ifPresent:[:cls| cls rebuild].
- Smalltalk forgetDoIts.
- Smalltalk garbageCollect.
- unboundMethods := CompiledMethod allInstances select:[:m|
- m methodClass isNil or: [m ~~ (m methodClass compiledMethodAt: m selector ifAbsent: nil)]].
- unboundMethods := unboundMethods reject:[:m| m selector isDoIt].
- unboundMethods notEmpty ifTrue:
- [(ToolSet inspect: unboundMethods) setLabel: 'Unbound Methods'].
- contexts := BlockContext allInstances.
- contexts ifNotEmpty:[contexts inspect. self inform: 'There are left-over BlockContexts'].
- (unboundMethods isEmpty and:[contexts isEmpty]) ifTrue:[
- self inform:'Congratulations - The bootstrap is now complete.'.
- ].
- !
Item was changed:
----- Method: Utilities class>>readServer:special:updatesThrough:saveLocally:updateImage: (in category 'fetching updates') -----
readServer: serverList special: indexPrefix updatesThrough: maxNumber saveLocally: saveLocally updateImage: updateImage
"Scan the update server(s) for unassimilated updates. If maxNumber is not nil, it represents the highest-numbered update to load. This makes it possible to update only up to a particular point. If saveLocally is true, then save local copies of the update files on disc. If updateImage is true, then absorb the updates into the current image."
"Utilities readServer: Utilities serverUrls updatesThrough: 828 saveLocally: true updateImage: true"
| str urls failed loaded |
Cursor wait showWhile: [ | docQueue docQueueSema |
urls := self newUpdatesOn: (serverList collect: [:url | url, 'updates/'])
special: indexPrefix
throughNumber: maxNumber.
loaded := 0.
failed := nil.
"send downloaded documents throuh this queue"
docQueue := SharedQueue new.
"this semaphore keeps too many documents from beeing queueed up at a time"
docQueueSema := Semaphore new.
5 timesRepeat: [ docQueueSema signal ].
"fork a process to download the updates"
self retrieveUrls: urls ontoQueue: docQueue withWaitSema: docQueueSema.
"process downloaded updates in the foreground"
+ 'Processing updates' displayProgressFrom: 0 to: urls size during: [:bar | | nextDoc this updateName |
- 'Processing updates' displayProgressAt: Sensor cursorPoint from: 0 to: urls size during: [:bar | | nextDoc this updateName |
[ this := docQueue next.
nextDoc := docQueue next.
nextDoc = #failed ifTrue: [ failed := this ].
(failed isNil and: [ nextDoc ~= #finished ])
] whileTrue: [
failed ifNil: [
nextDoc reset; text.
nextDoc size = 0 ifTrue: [ failed := this ]. ].
failed ifNil: [
nextDoc peek asciiValue = 4 "pure object file"
ifTrue: [failed := this]]. "Must be fileIn, not pure object file"
failed ifNil: [
"(this endsWith: '.html') ifTrue: [doc := doc asHtml]."
"HTML source code not supported here yet"
updateImage
ifTrue: [
updateName := (this findTokens: '/') last.
ChangeSet newChangesFromStream: nextDoc named: updateName.
SystemVersion current registerUpdate: updateName initialIntegerOrNil].
saveLocally ifTrue:
[self saveUpdate: nextDoc onFile: (this findTokens: '/') last]. "if wanted"
loaded := loaded + 1.
bar value: loaded].
docQueueSema signal].
]].
failed ~~ nil & (urls size - loaded > 0) ifTrue: [
str := loaded printString ,' new update file(s) processed.'.
str := str, '\Could not load ' withCRs,
(urls size - loaded) printString ,' update file(s).',
'\Starting with "' withCRs, failed, '".'.
self inform: str].
^ Array with: failed with: loaded
!
Item was changed:
----- Method: Utilities class>>retrieveUrls:ontoQueue:withWaitSema: (in category 'fetching updates') -----
retrieveUrls: urls ontoQueue: queue withWaitSema: waitSema
"download the given list of URLs. The queue will be loaded alternately
with url's and with the retrieved contents. If a download fails, the
contents will be #failed. If all goes well, a special pair with an empty
URL and the contents #finished will be put on the queue. waitSema is
waited on every time before a new document is downloaded; this keeps
the downloader from getting too far ahead of the main process"
"kill the existing downloader if there is one"
| updateCounter |
UpdateDownloader
ifNotNil: [UpdateDownloader terminate].
updateCounter := 0.
"fork a new downloading process"
UpdateDownloader := [
+ 'Downloading updates' displayProgressFrom: 0 to: urls size during: [:bar |
- 'Downloading updates' displayProgressAt: Sensor cursorPoint from: 0 to: urls size during: [:bar |
urls
do: [:url | | front canPeek doc |
waitSema wait.
queue nextPut: url.
doc := HTTPClient httpGet: url.
doc isString
ifTrue: [queue nextPut: #failed.
UpdateDownloader := nil.
Processor activeProcess terminate]
ifFalse: [canPeek := 120 min: doc size.
front := doc next: canPeek. doc skip: -1 * canPeek.
(front beginsWith: '<!!DOCTYPE') ifTrue: [
(front includesSubString: 'Not Found') ifTrue: [
queue nextPut: #failed.
UpdateDownloader := nil.
Processor activeProcess terminate]]].
UpdateDownloader ifNotNil: [queue nextPut: doc. updateCounter := updateCounter + 1. bar value: updateCounter]]].
queue nextPut: ''.
queue nextPut: #finished.
UpdateDownloader := nil] newProcess.
UpdateDownloader priority: Processor userInterruptPriority.
"start the process running"
UpdateDownloader resume!
More information about the Packages
mailing list