The Trunk: System-nice.234.mcz

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!