[squeak-dev] The Trunk: System-ar.140.mcz

Andreas Raab uploaded a new version of System to project The Trunk:
http://source.squeak.org/trunk/System-ar.140.mcz

==================== Summary ====================

Name: System-ar.140
Author: ar
Time: 4 September 2009, 12:10:59 pm
UUID: f149b02b-e23d-fa48-b523-dfc2539b8878
Ancestors: System-ar.139

http://bugs.squeak.org/view.php?id=7301

Change Set: MessageTallyEnh-ar-jmv
Date: 4 March 2009
Author: Andreas Raab

Improve MessageTally to provide cross-process profiling.

=============== Diff against System-ar.139 ===============

Item was changed:
  ----- Method: MessageTally>>fullPrintOn:tallyExact:orThreshold: (in category 'printing') -----
  fullPrintOn: aStream tallyExact: isExact orThreshold: perCent
  | threshold |  
+ isExact ifFalse: [threshold _ (perCent asFloat / 100 * tally) rounded].
- isExact ifFalse: [threshold := (perCent asFloat / 100 * tally) rounded].
  aStream nextPutAll: '**Tree**'; cr.
+ self rootPrintOn: aStream
- self treePrintOn: aStream
- tabs: OrderedCollection new
- thisTab: ''
  total: tally
  totalTime: time
  tallyExact: isExact
  orThreshold: threshold.
  aStream nextPut: Character newPage; cr.
  aStream nextPutAll: '**Leaves**'; cr.
  self leavesPrintOn: aStream
  tallyExact: isExact
  orThreshold: threshold!

Item was changed:
  ----- Method: MessageTally>>sonsOver: (in category 'comparing') -----
  sonsOver: threshold
 
  | hereTally last sons |
  (receivers == nil or: [receivers size = 0]) ifTrue: [^#()].
+ hereTally _ tally.
+ sons _ receivers select:  "subtract subNode tallies for primitive hits here"
- hereTally := tally.
- sons := receivers select:  "subtract subNode tallies for primitive hits here"
  [:son |
+ hereTally _ hereTally - son tally.
- hereTally := hereTally - son tally.
  son tally > threshold].
  hereTally > threshold
  ifTrue:
+ [last _ MessageTally new class: class method: method.
+ last process: process.
- [last := MessageTally new class: class method: method.
  ^sons copyWith: (last primitives: hereTally)].
  ^sons!

Item was changed:
  ----- Method: MessageTally>>close (in category 'initialize-release') -----
  close
 
  (Timer isMemberOf: Process) ifTrue: [Timer terminate].
+ Timer := nil.
- Timer := ObservedProcess := nil.
  class := method := tally := receivers := nil!

Item was added:
+ ----- 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 startTime time0 observedProcess |
+ (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 := [
+ [true] whileTrue: [
+ startTime := Time millisecondClockValue.
+ myDelay wait.
+ observedProcess := Processor preemptedProcess.
+ self tally: observedProcess suspendedContext
+ in: (ShowProcesses ifTrue: [observedProcess])
+ "tally can be > 1 if ran a long primitive"
+ by: (Time millisecondClockValue - startTime) // millisecs].
+ nil] newProcess.
+ Timer priority: Processor timingPriority-1.
+ "activate the probe and evaluate the block"
+ Timer resume.
+ ^ aBlock ensure: [
+ "Collect gc statistics"
+ SmalltalkImage current getVMParameters keysAndValuesDo: [ :idx :gcVal |
+ gcStats at: idx put: (gcVal - (gcStats at: idx))].
+ "cancel the probe and return the value"
+ Timer terminate.
+ time := Time millisecondClockValue - time0]!

Item was changed:
  ----- Method: MessageTally>>tallyPath:by: (in category 'tallying') -----
  tallyPath: context by: count
  | aMethod path |
+ aMethod :=context method.
+
+ "Find the correct child (if there)"
+ receivers do: [ :oldTally |
+ oldTally method == aMethod ifTrue: [path := oldTally]].
+
+ "Add new child if needed"
+ path ifNil: [
+ path := MessageTally new class: context receiver class method: aMethod.
- aMethod := context method.
- receivers do:
- [:aMessageTally |
- aMessageTally method == aMethod ifTrue: [path := aMessageTally]].
- path == nil ifTrue:
- [path := MessageTally new class: context receiver class method: aMethod;
- maxClassNameSize: maxClassNameSize;
- maxClassPlusSelectorSize: maxClassPlusSelectorSize;
- maxTabs: maxTabs.
  receivers := receivers copyWith: path].
+
  ^ path bumpBy: count!

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 startTime time0 observedProcess |
+ (aBlock isMemberOf: BlockContext)
+ ifFalse: [self error: 'spy needs a block here'].
+ self class: aBlock receiver class method: aBlock method.
- | myDelay startTime time0 |
- aBlock isBlock
- ifTrue: [self class: aBlock receiver class method: aBlock method]
- ifFalse: [self class: aBlock class method: aBlock method].
  "set up the probe"
+ observedProcess _ Processor activeProcess.
- ObservedProcess := Processor activeProcess.
  myDelay := Delay forMilliseconds: millisecs.
  time0 := Time millisecondClockValue.
  gcStats := SmalltalkImage current getVMParameters.
+ Timer := [
+ [true] whileTrue: [
+ startTime := Time millisecondClockValue.
- Timer :=
- [[true] whileTrue:
- [startTime := Time millisecondClockValue.
  myDelay wait.
+ self tally: Processor preemptedProcess suspendedContext
+ in: (ShowProcesses ifTrue: [
+ observedProcess == Processor preemptedProcess ifTrue: [observedProcess] ifFalse: [nil]])
- self tally: ObservedProcess suspendedContext
  "tally can be > 1 if ran a long primitive"
  by: (Time millisecondClockValue - startTime) // millisecs].
  nil] newProcess.
+ Timer priority: Processor timingPriority-1.
- Timer priority: Processor userInterruptPriority.
  "activate the probe and evaluate the block"
  Timer resume.
+ ^ aBlock ensure: [
+ "Collect gc statistics"
+ SmalltalkImage current getVMParameters keysAndValuesDo: [ :idx :gcVal |
+ gcStats at: idx put: (gcVal - (gcStats at: idx))].
- ^ aBlock ensure:
- ["Collect gc statistics"
- SmalltalkImage current getVMParameters keysAndValuesDo:
- [:idx :gcVal| gcStats at: idx put: (gcVal - (gcStats at: idx))].
  "cancel the probe and return the value"
  Timer terminate.
  time := Time millisecondClockValue - time0]!

Item was added:
+ ----- Method: MessageTally>>rootPrintOn:total:totalTime:tallyExact:orThreshold: (in category 'printing') -----
+ rootPrintOn: aStream total: total totalTime: totalTime tallyExact: isExact orThreshold: threshold
+ | sons groups p |
+ ShowProcesses ifFalse:[
+ ^self treePrintOn: aStream
+ tabs: OrderedCollection new
+ thisTab: ''
+ total: total
+ totalTime: totalTime
+ tallyExact: isExact
+ orThreshold: threshold.
+ ].
+ sons := isExact ifTrue: [receivers] ifFalse: [self sonsOver: threshold].
+ groups := sons groupBy:[:aTally| aTally process] having:[:g| true].
+ groups do:[:g|
+ sons := g asSortedCollection.
+ p := g anyOne process.
+ "Do not show 'other processes' "
+ "Please keep consistency with #leavesInto:fromSender:
+ on showing them or not!!"
+ p ifNotNil: [
+ aStream nextPutAll: '--------------------------------'; cr.
+ aStream nextPutAll: 'Process: ',  (p ifNil: [ 'other processes'] ifNotNil: [ p browserPrintString]); cr.
+ aStream nextPutAll: '--------------------------------'; cr.
+ (1 to: sons size) do:[:i |
+ (sons at: i)
+ treePrintOn: aStream
+ tabs: OrderedCollection new
+ thisTab: ''
+ total: total
+ totalTime: totalTime
+ tallyExact: isExact
+ orThreshold: threshold]].
+ ].!

Item was changed:
  ----- Method: MessageTally>>report: (in category 'reporting') -----
  report: strm
  "Print a report, with cutoff percentage of each element of the tree
+ (leaves, roots, tree), on the stream, strm."
- (leaves, roots, tree)=2, on the stream, strm."
 
+ self report: strm cutoff: 1!
- self report: strm cutoff: 2!

Item was changed:
  Magnitude subclass: #MessageTally
+ instanceVariableNames: 'class method process tally receivers senders time gcStats maxClassNameSize maxClassPlusSelectorSize maxTabs'
+ classVariableNames: 'DefaultPollPeriod ShowProcesses Timer'
- instanceVariableNames: 'class method tally receivers senders time gcStats maxClassNameSize maxClassPlusSelectorSize maxTabs'
- classVariableNames: 'DefaultPollPeriod ObservedProcess Timer'
  poolDictionaries: ''
  category: 'System-Tools'!
 
  !MessageTally commentStamp: 'nk 3/8/2004 12:43' prior: 0!
  My instances observe and report the amount of time spent in methods.
 
  NOTE: a higher-level user interface (combining the MessageTally result tree with a method browser) is available from TimeProfileBrowser.
 
  MessageTally provides two different strategies available for profiling:
 
  * spyOn: and friends use a high-priority Process to interrupt the block or process being spied on at periodic intervals. The interrupted call stack is then examined for caller information.
 
  * tallySends: and friends use the interpreter simulator to run the block, recording every method call.
 
  The two give you different results:
 
  * spyOn: gives you a view of where the time is being spent in your program, at least on a rough statistical level (assuming you've run the block for long enough and have a high enough poll rate). If you're trying to optimize your code, start here and optimize the methods where most of the time is being spent first.
 
  * tallySends: gives you accurate counts of how many times methods get called, and by exactly which route. If you're debugging, or trying to figure out if a given method is getting called too many times, this is your tool.
 
  You can change the printing format (that is, the whitespace and string compression) by using these instance methods:
  maxClassNameSize:
  maxClassPlusSelectorSize:
  maxTabs:
 
  You can change the default polling period (initially set to 1) by calling
  MessageTally defaultPollPeriod: numberOfMilliseconds
 
  Q: How do you interpret MessageTally>>tallySends
  A: The methods #tallySends and #spyOn: measure two very different quantities, but broken down in the same who-called-who format.  #spyOn: is approximate, but more indicative of real time spent, whereas #tallySends is exact and a precise record of how many times each method got executed.!

Item was changed:
  ----- Method: MessageTally>>= (in category 'comparing') -----
  = aMessageTally
 
  self species == aMessageTally species ifFalse: [^ false].
+ ^ aMessageTally method == method and:[aMessageTally process == process]!
- ^ aMessageTally method == method!

Item was changed:
  ----- Method: MessageTally class>>defaultMaxTabs (in category 'defaults') -----
  defaultMaxTabs
  "Return the default number of tabs after which leading white space is compressed"
+ ^120!
- ^40!

Item was changed:
  ----- Method: MessageTally class>>spyOn: (in category 'spying') -----
+ spyOn: aBlock
+ "
+ [1000 timesRepeat: [
+ 100 timesRepeat: [120 factorial].
+ (Delay forMilliseconds: 10) wait
+ ]] forkAt: 45 named: '45'.
+ MessageTally spyOn: [10000 timesRepeat: [1.23 printString]]
+ "
- spyOn: aBlock    "MessageTally spyOn: [100 timesRepeat: [3.14159 printString]]"
  | node result |
+ node _ self new.
+ result _ node spyEvery: self defaultPollPeriod on: aBlock.
- node := self new.
- result := node spyEvery: self defaultPollPeriod on: aBlock.
  (StringHolder new contents: (String streamContents: [:s | node report: s; close]))
  openLabel: 'Spy Results'.
  ^ result!

Item was changed:
  ----- Method: MessageTally>>tally:by: (in category 'tallying') -----
  tally: context by: count
  "Explicitly tally the specified context and its stack."
+ | sender |
+
+ "Add to this node if appropriate"
- | root |
  context method == method ifTrue: [^self bumpBy: count].
+
+ "No sender? Add new branch to the tree."
+ (sender := context home sender)ifNil: [
+ ^ (self bumpBy: count) tallyPath: context by: count].
+
+ "Find the node for the sending context (or add it if necessary)"
+ ^ (self tally: sender by: count) tallyPath: context by: count!
- (root := context home sender) == nil
- ifTrue: [^ (self bumpBy: count) tallyPath: context by: count].
- ^ (self tally: root by: count) tallyPath: context by: count!

Item was changed:
  ----- Method: MessageTally>>leavesInto:fromSender: (in category 'collecting leaves') -----
  leavesInto: leafDict fromSender: senderTally
  | rcvrs |
+ rcvrs _ self sonsOver: 0.
- rcvrs := self sonsOver: 0.
  rcvrs size = 0
  ifTrue: [self into: leafDict fromSender: senderTally]
+ ifFalse: [
+
+ "Do not show 'other processes' "
+ "Please keep consistency with #rootPrintOn:total:totalTime:tallyExact:orThreshold:
+ on showing them or not!!"
+ rcvrs anyOne process ifNil: [^self].
+
+ rcvrs do:
- ifFalse: [rcvrs do:
  [:node |
  node isPrimitives
  ifTrue: [node leavesInto: leafDict fromSender: senderTally]
  ifFalse: [node leavesInto: leafDict fromSender: self]]]!

Item was added:
+ ----- Method: MessageTally class>>spyAllOn: (in category 'spying') -----
+ spyAllOn: aBlock
+ "Spy on all the processes in the system
+
+ [1000 timesRepeat: [3.14159 printString. Processor yield]] fork.
+ [1000 timesRepeat: [20 factorial. Processor yield]] fork.
+ [1000 timesRepeat: [20 factorial. Processor yield]] fork.
+ MessageTally spyAllOn: [ (Delay forMilliseconds: 100) wait]
+
+ "
+ | node result |
+ node := self new.
+ result := node spyAllEvery: self defaultPollPeriod on: aBlock.
+ (StringHolder new contents: (String streamContents: [:s | node report: s; close]))
+ openLabel: 'Spy Results'.
+ ^ result!

Item was changed:
  ----- Method: MessageTally class>>spyOnProcess:forMilliseconds: (in category 'spying') -----
  spyOnProcess: aProcess forMilliseconds: msecDuration
+ "
+ | p1 p2 |  
+ p1 _ [100000 timesRepeat: [3.14159 printString. Processor yield]] fork.  
+ p2 _ [100000 timesRepeat: [3.14159 printString. Processor yield]] fork.  
- "| p |  
- p := [100000 timesRepeat: [3.14159 printString]] fork.  
  (Delay forMilliseconds: 100) wait.  
+ MessageTally spyOnProcess: p1 forMilliseconds: 1000
+ "
- MessageTally spyOnProcess: p forMilliseconds: 1000"
  | node |
  node := self new.
  node
  spyEvery: self defaultPollPeriod
  onProcess: aProcess
  forMilliseconds: msecDuration.
  (StringHolder new
  contents: (String
  streamContents: [:s | node report: s;
  close]))
  openLabel: 'Spy Results'!

Item was changed:
  ----- Method: MessageTally>>into:fromSender: (in category 'collecting leaves') -----
  into: leafDict fromSender: senderTally
  | leafNode |
+ leafNode _ leafDict at: method
- leafNode := leafDict at: method
  ifAbsent: [leafDict at: method
+ put: ((MessageTally new class: class method: method)
+ process: process)].
- put: (MessageTally new class: class method: method)].
  leafNode bump: tally fromSender: senderTally!

Item was added:
+ ----- Method: MessageTally>>tallyPath:in:by: (in category 'tallying') -----
+ tallyPath: context in: aProcess by: count
+ | aMethod path |
+ aMethod := context method.
+
+ "Find the correct child (if there)"
+ receivers do: [ :oldTally |
+ (oldTally method == aMethod and: [oldTally process == aProcess])
+ ifTrue: [path := oldTally]].
+
+ "Add new child if needed"
+ path ifNil:[
+ path := MessageTally new class: context receiver class method: aMethod;
+ process: aProcess;
+ maxClassNameSize: maxClassNameSize;
+ maxClassPlusSelectorSize: maxClassPlusSelectorSize;
+ maxTabs: maxTabs.
+ receivers := receivers copyWith: path].
+
+ ^ path bumpBy: count!

Item was added:
+ ----- Method: MessageTally>>process: (in category 'private') -----
+ process: aProcess
+ process := aProcess!

Item was changed:
  ----- Method: MessageTally>>copyWithTally: (in category 'private') -----
  copyWithTally: hitCount
+ ^ (MessageTally new class: class method: method)
+ process: process;
+ bump: hitCount!
- ^ (MessageTally new class: class method: method) bump: hitCount!

Item was added:
+ ----- Method: MessageTally class>>showProcesses (in category 'defaults') -----
+ showProcesses
+ "Indicates whether to show each process separately or cumulatively.
+ For example, compare the spy results of the following with both values:
+
+ [1000 timesRepeat: [3.14159 printString. Processor yield]] fork.
+ [1000 timesRepeat: [30 factorial. Processor yield]] fork.
+ [1000 timesRepeat: [30 factorial. Processor yield]] fork.
+ MessageTally spyAllOn: [ (Delay forMilliseconds: 100) wait]
+
+ "
+ <preference: 'Show Tally Processes'
+ category: 'debug'
+ description: 'When true, show individual processes in MessageTally'
+ type: #Boolean>
+ ^ShowProcesses!

Item was added:
+ ----- Method: MessageTally class>>initialize (in category 'class initialization') -----
+ initialize
+ "MessageTally initialize"
+ "By default, show each process separately"
+ ShowProcesses := true!

Item was added:
+ ----- Method: MessageTally>>process (in category 'private') -----
+ process
+ ^process!

Item was added:
+ ----- Method: MessageTally class>>showProcesses: (in category 'defaults') -----
+ showProcesses: aBool
+ "Indicates whether to show each process separately or cumulatively.
+ For example, compare the spy results of the following with both values:
+
+ [1000 timesRepeat: [3.14159 printString. Processor yield]] fork.
+ [1000 timesRepeat: [30 factorial. Processor yield]] fork.
+ [1000 timesRepeat: [30 factorial. Processor yield]] fork.
+ MessageTally spyAllOn: [ (Delay forMilliseconds: 100) wait]
+
+ "
+ ShowProcesses := aBool.!

Item was added:
+ ----- Method: MessageTally>>tally:in:by: (in category 'tallying') -----
+ tally: context in: aProcess by: count
+ "Explicitly tally the specified context and its stack."
+ | sender |
+
+ "Add to this node if appropriate"
+ context method == method ifTrue: [^self bumpBy: count].
+
+ "No sender? Add new branch to the tree."
+ (sender := context home sender) ifNil: [
+ ^ (self bumpBy: count) tallyPath: context in: aProcess by: count].
+
+ "Find the node for the sending context (or add it if necessary)"
+ ^ (self tally: sender in: aProcess by: count) tallyPath: context in: aProcess by: count!

Item was changed:
  ----- Method: MessageTally>>spyEvery:onProcess:forMilliseconds: (in category 'initialize-release') -----
  spyEvery: millisecs onProcess: aProcess forMilliseconds: msecDuration
  "Create a spy and spy on the given process at the specified rate."
+ | myDelay startTime time0 endTime sem observedProcess |
- | myDelay time0 endTime sem |
  (aProcess isKindOf: Process)
  ifFalse: [self error: 'spy needs a Process here'].
  self class: aProcess suspendedContext receiver class method: aProcess suspendedContext method.
  "set up the probe"
+ observedProcess := aProcess.
- ObservedProcess := aProcess.
  myDelay := Delay forMilliseconds: millisecs.
  time0 := Time millisecondClockValue.
  endTime := time0 + msecDuration.
  sem := Semaphore new.
+ gcStats := SmalltalkImage current getVMParameters.
+ Timer := [
+ [
+ startTime := Time millisecondClockValue.
+ myDelay wait.
+ self tally: Processor preemptedProcess suspendedContext
+ in: (ShowProcesses ifTrue: [
+ observedProcess == Processor preemptedProcess ifTrue: [observedProcess] ifFalse: [nil]])
+ "tally can be > 1 if ran a long primitive"
+ by: (Time millisecondClockValue - startTime) // millisecs.
+ startTime < endTime
+ ] whileTrue.
+ sem signal.
+ ] newProcess.
+ Timer priority: Processor timingPriority-1.
+ "activate the probe and evaluate the block"
+ Timer resume.
- gcStats := SmalltalkImage current  getVMParameters.
- Timer := [[| startTime |
- startTime := Time millisecondClockValue.
- myDelay wait.
- self tally: ObservedProcess suspendedContext by: Time millisecondClockValue - startTime // millisecs.
- startTime < endTime] whileTrue.
- sem signal]
- forkAt: (ObservedProcess priority + 1 min: Processor highestPriority).
  "activate the probe and wait for it to finish"
  sem wait.
  "Collect gc statistics"
+ SmalltalkImage current getVMParameters keysAndValuesDo: [ :idx :gcVal |
+ gcStats at: idx put: (gcVal - gcStats at: idx)].
- SmalltalkImage current  getVMParameters keysAndValuesDo:
- [:idx :gcVal| gcStats at: idx put: (gcVal - gcStats at: idx)].
  time := Time millisecondClockValue - time0!