[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