Initial revision
authorclaus
Fri, 16 Jul 1993 11:38:06 +0200
changeset 0 470788421600
child 1 bc909674c348
Initial revision
Change.st
ChangeSet.st
ClassChange.st
ClassChg.st
ClassCommentChange.st
ClassDefinitionChange.st
ClsComChg.st
ClsDefChg.st
MessageTally.st
MethodChange.st
MethodChg.st
MsgTally.st
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Change.st	Fri Jul 16 11:38:06 1993 +0200
@@ -0,0 +1,15 @@
+'From Smalltalk/X, Version:2.6.4 on 29-Apr-1993 at 19:31:37'!
+
+Object subclass:#Change
+	 instanceVariableNames:'source'
+	 classVariableNames:''
+	 poolDictionaries:''
+	 category:'System-Changes'
+!
+
+!Change methodsFor:'source'!
+
+source
+    ^ source
+! !
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/ChangeSet.st	Fri Jul 16 11:38:06 1993 +0200
@@ -0,0 +1,20 @@
+'From Smalltalk/X, Version:2.6.4 on 29-Apr-1993 at 19:31:37'!
+
+OrderedCollection subclass:#ChangeSet
+	 instanceVariableNames:''
+	 classVariableNames:''
+	 poolDictionaries:''
+	 category:'System-Changes'
+!
+
+!ChangeSet methodsFor:'change management'!
+
+addMethodChange:aMethod in:aClass
+    |newChange|
+
+    newChange := MethodChange class:aClass
+                           selector:(aClass selectorForMethod:aMethod)
+                             source:aMethod source.
+    self add:newChange
+! !
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/ClassChange.st	Fri Jul 16 11:38:06 1993 +0200
@@ -0,0 +1,15 @@
+'From Smalltalk/X, Version:2.6.4 on 29-Apr-1993 at 19:31:37'!
+
+Change subclass:#ClassChange
+	 instanceVariableNames:'className'
+	 classVariableNames:''
+	 poolDictionaries:''
+	 category:'System-Changes'
+!
+
+!ClassChange methodsFor:'accessing'!
+
+className 
+    ^  className
+! !
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/ClassChg.st	Fri Jul 16 11:38:06 1993 +0200
@@ -0,0 +1,15 @@
+'From Smalltalk/X, Version:2.6.4 on 29-Apr-1993 at 19:31:37'!
+
+Change subclass:#ClassChange
+	 instanceVariableNames:'className'
+	 classVariableNames:''
+	 poolDictionaries:''
+	 category:'System-Changes'
+!
+
+!ClassChange methodsFor:'accessing'!
+
+className 
+    ^  className
+! !
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/ClassCommentChange.st	Fri Jul 16 11:38:06 1993 +0200
@@ -0,0 +1,21 @@
+'From Smalltalk/X, Version:2.6.4 on 29-Apr-1993 at 19:31:38'!
+
+ClassChange subclass:#ClassCommentChange
+	 instanceVariableNames:'comment'
+	 classVariableNames:''
+	 poolDictionaries:''
+	 category:'System-Changes'
+!
+
+!ClassCommentChange methodsFor:'accessing'!
+
+comment
+    ^ comment
+! !
+
+!ClassCommentChange methodsFor:'printing'!
+
+printString
+    ^ 'ClassCommentChange(' , className , ')'
+! !
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/ClassDefinitionChange.st	Fri Jul 16 11:38:06 1993 +0200
@@ -0,0 +1,15 @@
+'From Smalltalk/X, Version:2.6.4 on 29-Apr-1993 at 19:31:37'!
+
+ClassChange subclass:#ClassDefinitionChange
+	 instanceVariableNames:'definition'
+	 classVariableNames:''
+	 poolDictionaries:''
+	 category:'System-Changes'
+!
+
+!ClassDefinitionChange methodsFor:'printing'!
+
+printString
+    ^ 'ClassDefinitionChange(' , className , ')'
+! !
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/ClsComChg.st	Fri Jul 16 11:38:06 1993 +0200
@@ -0,0 +1,21 @@
+'From Smalltalk/X, Version:2.6.4 on 29-Apr-1993 at 19:31:38'!
+
+ClassChange subclass:#ClassCommentChange
+	 instanceVariableNames:'comment'
+	 classVariableNames:''
+	 poolDictionaries:''
+	 category:'System-Changes'
+!
+
+!ClassCommentChange methodsFor:'accessing'!
+
+comment
+    ^ comment
+! !
+
+!ClassCommentChange methodsFor:'printing'!
+
+printString
+    ^ 'ClassCommentChange(' , className , ')'
+! !
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/ClsDefChg.st	Fri Jul 16 11:38:06 1993 +0200
@@ -0,0 +1,15 @@
+'From Smalltalk/X, Version:2.6.4 on 29-Apr-1993 at 19:31:37'!
+
+ClassChange subclass:#ClassDefinitionChange
+	 instanceVariableNames:'definition'
+	 classVariableNames:''
+	 poolDictionaries:''
+	 category:'System-Changes'
+!
+
+!ClassDefinitionChange methodsFor:'printing'!
+
+printString
+    ^ 'ClassDefinitionChange(' , className , ')'
+! !
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/MessageTally.st	Fri Jul 16 11:38:06 1993 +0200
@@ -0,0 +1,265 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+              All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice.   This software may not
+ be provided or otherwise made available to, or used by, any
+ other person.  No title to or ownership of the software is
+ hereby transferred.
+"
+
+Object subclass:#MessageTally
+       instanceVariableNames:'classes selectors counts ntally
+                              sumClasses sumSelectors sumCounts sumNtally'
+       classVariableNames:''
+       poolDictionaries:''
+       category:'System-Support'
+!
+
+MessageTally comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+              All Rights Reserved
+
+%W% %E%
+
+MessageTally allows profiling excution of a block; statistic
+of method evaluation is output on Transcript.
+To get statistic, use MessageTally spyOn:aBlock.
+'!
+
+!MessageTally class methodsFor:'instance creation'!
+
+spyOn:aBlock
+    "evaluate aBlock and output time statistic on Transcript"
+
+    |runTime aTally|
+
+    aTally := self new.
+    runTime := aTally spyOn:aBlock.
+    aTally statistics.
+    Transcript cr.
+    Transcript showCr:('total execution time: '
+                       , runTime printString , ' ms')
+
+    "MessageTally spyOn:[10000 timesRepeat:[#(6 5 4 3 2 1) sort] ]"
+!
+
+spyCountOn:aBlock
+    "evaluate aBlock and output call statistic on Transcript"
+
+    (self new spyCountOn:aBlock) statistics
+
+    "MessageTally spyCountOn:[#(6 5 4 3 2 1) sort ]"
+! !
+
+!MessageTally methodsFor:'private'!
+
+setupArrays
+    classes := Array new:200.
+    selectors := Array new:200.
+    counts := Array new:200.
+    sumClasses := Array new:200.
+    sumSelectors := Array new:200.
+    sumCounts := Array new:200.
+    ntally := 0.
+    sumNtally := 0
+!
+
+spyOn:aBlock
+    "spy on execution time"
+
+    |startTime endTime|
+
+    self setupArrays.
+    SpyInterruptHandler := self.
+    startTime := OperatingSystem getMillisecondTime.
+    OperatingSystem startSpyTimer.
+    aBlock value.
+    OperatingSystem stopSpyTimer.
+    endTime := OperatingSystem getMillisecondTime.
+    SpyInterruptHandler := nil.
+    ^ endTime - startTime
+!
+
+spyCountOn:aBlock
+    "spy on method sends"
+
+    self setupArrays.
+    StepInterruptHandler := self.
+    StepInterruptPending := true.
+    InterruptPending := true.
+    aBlock value.
+    StepInterruptPending := nil.
+    StepInterruptHandler := nil
+!
+
+stepInterrupt
+    "called for every send;
+     increment counts and retrigger stepInterrupt"
+
+    self count.
+    StepInterruptPending := true.
+    InterruptPending := true
+!
+
+spyInterrupt
+    "called every 10ms by timer;
+     increment counts and retrigger spyInterrupt"
+
+    self count.
+    OperatingSystem startSpyTimer
+!
+
+count
+    "increment class/method counts"
+
+    |where index sel recClass done newColl|
+
+    where := thisContext.
+    "where is now my context"
+    where := where sender.
+    "where is now spy/step interrupt context"
+    where := where sender.
+    "where is now interrupted context"
+
+    "ignore block-contexts"
+    (where isBlockContext) ifTrue:[
+        where := nil.   "currently needed"
+        ^ self
+    ].
+
+    sel := where selector.
+    recClass := where searchClass whichClassImplements:sel "receiver class".
+
+    index := 0.
+    done := false.
+    [done] whileFalse:[
+        index := selectors identityIndexOf:sel startingAt:(index + 1).
+        (index == 0) ifTrue:[
+            ntally := ntally + 1.
+            (ntally > counts size) ifTrue:[
+		newColl := Array new:(ntally * 2).
+		newColl replaceFrom:1 with:counts.
+		counts := newColl.
+		newColl := Array new:(ntally * 2).
+		newColl replaceFrom:1 with:selectors.
+		selectors := newColl.
+		newColl := Array new:(ntally * 2).
+		newColl replaceFrom:1 with:classes.
+		classes := newColl.
+            ].
+            selectors at:ntally put:sel.
+            classes at:ntally put:recClass.
+            counts at:ntally put:1.
+            done := true
+        ] ifFalse:[
+            ((classes at:index) == recClass) ifTrue:[
+                counts at:index put:((counts at:index) + 1).
+                done := true
+            ]
+        ]
+    ].
+
+    "count in accumulated table"
+    [where notNil] whileTrue:[
+        sel := where selector.
+        (sel == #spyOn:) ifTrue:[
+            where := nil
+        ] ifFalse:[
+            recClass := where searchClass whichClassImplements:sel "receiver class".
+            recClass isNil ifTrue:[
+                recClass := where searchClass
+            ].
+            index := 0.
+            done := false.
+            [done] whileFalse:[
+                index := sumSelectors identityIndexOf:sel startingAt:(index + 1).
+                (index == 0) ifTrue:[
+                    sumNtally := sumNtally + 1.
+                    (sumNtally > sumCounts size) ifTrue:[
+		        newColl := Array new:(sumNtally * 2).
+		        newColl replaceFrom:1 with:sumCounts.
+		        sumCounts := newColl.
+
+		        newColl := Array new:(sumNtally * 2).
+		        newColl replaceFrom:1 with:sumSelectors.
+		        sumSelectors := newColl.
+
+		        newColl := Array new:(sumNtally * 2).
+		        newColl replaceFrom:1 with:sumClasses.
+		        sumClasses := newColl.
+                    ].
+                    sumSelectors at:sumNtally put:sel.
+                    sumClasses at:sumNtally put:recClass.
+                    sumCounts at:sumNtally put:1.
+                    done := true
+                ] ifFalse:[
+                    ((sumClasses at:index) == recClass) ifTrue:[
+                        sumCounts at:index put:((sumCounts at:index) + 1).
+                        done := true
+                    ]
+                ]
+            ].
+            where := where sender
+        ]
+    ]
+!
+
+statistics
+    "print statistics with percentages"
+
+    |nprobe sumNprobe nthis percent|
+
+    nprobe := 0.
+    1 to:ntally do:[:index |
+        nprobe := nprobe + (counts at:index)
+    ].
+    sumNprobe := 0.
+    1 to:sumNtally do:[:index |
+        sumNprobe := sumNprobe + (sumCounts at:index)
+    ].
+    Transcript cr.
+    Transcript show:'total probes: '.
+    Transcript show:nprobe printString.
+    Transcript show:' ('.
+    Transcript show:sumNprobe printString.
+    Transcript show:')'.
+    Transcript cr.
+    Transcript cr.
+    Transcript show:'  ntally'.
+    Transcript tab show:'percentage'.
+    Transcript tab show:'        class'.     
+    Transcript tab showCr:'       selector'.
+    Transcript showCr:'------------------ leafs ---------------------------'.
+    1 to:ntally do:[:index |
+        nthis := counts at:index.
+        percent := nthis * 100 // nprobe.
+        Transcript show:(nthis printStringRightAdjustLen:6).
+        Transcript tab. Transcript show:'    '.
+        Transcript show:((percent printStringRightAdjustLen:3) , '%').
+        Transcript tab. 
+        Transcript show:((classes at:index) name printStringRightAdjustLen:20).
+        Transcript tab. Transcript show:'    '.
+        Transcript showCr:((selectors at:index) printString)
+    ].
+
+    Transcript showCr:'---------------- accumulated -----------------------'.
+    1 to:sumNtally do:[:index |
+        nthis := sumCounts at:index.
+        percent := nthis * 100 // sumNprobe.
+        Transcript show:(nthis printStringRightAdjustLen:6).
+        Transcript tab. Transcript show:'    '.
+        Transcript show:((percent printStringRightAdjustLen:3) , '%').
+        Transcript tab. 
+        (sumClasses at:index) isNil ifTrue:[
+            Transcript show:('??' printStringRightAdjustLen:20)
+        ] ifFalse:[
+            Transcript show:((sumClasses at:index) name printStringRightAdjustLen:20).
+        ].
+        Transcript tab. Transcript show:'    '.
+        Transcript showCr:((sumSelectors at:index) printString)
+    ]
+! !
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/MethodChange.st	Fri Jul 16 11:38:06 1993 +0200
@@ -0,0 +1,29 @@
+'From Smalltalk/X, Version:2.6.4 on 29-Apr-1993 at 19:31:37'!
+
+ClassChange subclass:#MethodChange
+	 instanceVariableNames:'selector'
+	 classVariableNames:''
+	 poolDictionaries:''
+	 category:'System-Changes'
+!
+
+!MethodChange class methodsFor:'instance creation'!
+
+class:cls selector:sel source:src
+    ^ self basicNew class:cls selector:sel source:src
+! !
+
+!MethodChange methodsFor:'accessing'!
+
+class:cls selector:sel source:src
+    className := cls name.
+    selector := sel.
+    source := src
+! !
+
+!MethodChange methodsFor:'printing'!
+
+printString
+    ^ className , ' ' , selector 
+! !
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/MethodChg.st	Fri Jul 16 11:38:06 1993 +0200
@@ -0,0 +1,29 @@
+'From Smalltalk/X, Version:2.6.4 on 29-Apr-1993 at 19:31:37'!
+
+ClassChange subclass:#MethodChange
+	 instanceVariableNames:'selector'
+	 classVariableNames:''
+	 poolDictionaries:''
+	 category:'System-Changes'
+!
+
+!MethodChange class methodsFor:'instance creation'!
+
+class:cls selector:sel source:src
+    ^ self basicNew class:cls selector:sel source:src
+! !
+
+!MethodChange methodsFor:'accessing'!
+
+class:cls selector:sel source:src
+    className := cls name.
+    selector := sel.
+    source := src
+! !
+
+!MethodChange methodsFor:'printing'!
+
+printString
+    ^ className , ' ' , selector 
+! !
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/MsgTally.st	Fri Jul 16 11:38:06 1993 +0200
@@ -0,0 +1,265 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+              All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice.   This software may not
+ be provided or otherwise made available to, or used by, any
+ other person.  No title to or ownership of the software is
+ hereby transferred.
+"
+
+Object subclass:#MessageTally
+       instanceVariableNames:'classes selectors counts ntally
+                              sumClasses sumSelectors sumCounts sumNtally'
+       classVariableNames:''
+       poolDictionaries:''
+       category:'System-Support'
+!
+
+MessageTally comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+              All Rights Reserved
+
+%W% %E%
+
+MessageTally allows profiling excution of a block; statistic
+of method evaluation is output on Transcript.
+To get statistic, use MessageTally spyOn:aBlock.
+'!
+
+!MessageTally class methodsFor:'instance creation'!
+
+spyOn:aBlock
+    "evaluate aBlock and output time statistic on Transcript"
+
+    |runTime aTally|
+
+    aTally := self new.
+    runTime := aTally spyOn:aBlock.
+    aTally statistics.
+    Transcript cr.
+    Transcript showCr:('total execution time: '
+                       , runTime printString , ' ms')
+
+    "MessageTally spyOn:[10000 timesRepeat:[#(6 5 4 3 2 1) sort] ]"
+!
+
+spyCountOn:aBlock
+    "evaluate aBlock and output call statistic on Transcript"
+
+    (self new spyCountOn:aBlock) statistics
+
+    "MessageTally spyCountOn:[#(6 5 4 3 2 1) sort ]"
+! !
+
+!MessageTally methodsFor:'private'!
+
+setupArrays
+    classes := Array new:200.
+    selectors := Array new:200.
+    counts := Array new:200.
+    sumClasses := Array new:200.
+    sumSelectors := Array new:200.
+    sumCounts := Array new:200.
+    ntally := 0.
+    sumNtally := 0
+!
+
+spyOn:aBlock
+    "spy on execution time"
+
+    |startTime endTime|
+
+    self setupArrays.
+    SpyInterruptHandler := self.
+    startTime := OperatingSystem getMillisecondTime.
+    OperatingSystem startSpyTimer.
+    aBlock value.
+    OperatingSystem stopSpyTimer.
+    endTime := OperatingSystem getMillisecondTime.
+    SpyInterruptHandler := nil.
+    ^ endTime - startTime
+!
+
+spyCountOn:aBlock
+    "spy on method sends"
+
+    self setupArrays.
+    StepInterruptHandler := self.
+    StepInterruptPending := true.
+    InterruptPending := true.
+    aBlock value.
+    StepInterruptPending := nil.
+    StepInterruptHandler := nil
+!
+
+stepInterrupt
+    "called for every send;
+     increment counts and retrigger stepInterrupt"
+
+    self count.
+    StepInterruptPending := true.
+    InterruptPending := true
+!
+
+spyInterrupt
+    "called every 10ms by timer;
+     increment counts and retrigger spyInterrupt"
+
+    self count.
+    OperatingSystem startSpyTimer
+!
+
+count
+    "increment class/method counts"
+
+    |where index sel recClass done newColl|
+
+    where := thisContext.
+    "where is now my context"
+    where := where sender.
+    "where is now spy/step interrupt context"
+    where := where sender.
+    "where is now interrupted context"
+
+    "ignore block-contexts"
+    (where isBlockContext) ifTrue:[
+        where := nil.   "currently needed"
+        ^ self
+    ].
+
+    sel := where selector.
+    recClass := where searchClass whichClassImplements:sel "receiver class".
+
+    index := 0.
+    done := false.
+    [done] whileFalse:[
+        index := selectors identityIndexOf:sel startingAt:(index + 1).
+        (index == 0) ifTrue:[
+            ntally := ntally + 1.
+            (ntally > counts size) ifTrue:[
+		newColl := Array new:(ntally * 2).
+		newColl replaceFrom:1 with:counts.
+		counts := newColl.
+		newColl := Array new:(ntally * 2).
+		newColl replaceFrom:1 with:selectors.
+		selectors := newColl.
+		newColl := Array new:(ntally * 2).
+		newColl replaceFrom:1 with:classes.
+		classes := newColl.
+            ].
+            selectors at:ntally put:sel.
+            classes at:ntally put:recClass.
+            counts at:ntally put:1.
+            done := true
+        ] ifFalse:[
+            ((classes at:index) == recClass) ifTrue:[
+                counts at:index put:((counts at:index) + 1).
+                done := true
+            ]
+        ]
+    ].
+
+    "count in accumulated table"
+    [where notNil] whileTrue:[
+        sel := where selector.
+        (sel == #spyOn:) ifTrue:[
+            where := nil
+        ] ifFalse:[
+            recClass := where searchClass whichClassImplements:sel "receiver class".
+            recClass isNil ifTrue:[
+                recClass := where searchClass
+            ].
+            index := 0.
+            done := false.
+            [done] whileFalse:[
+                index := sumSelectors identityIndexOf:sel startingAt:(index + 1).
+                (index == 0) ifTrue:[
+                    sumNtally := sumNtally + 1.
+                    (sumNtally > sumCounts size) ifTrue:[
+		        newColl := Array new:(sumNtally * 2).
+		        newColl replaceFrom:1 with:sumCounts.
+		        sumCounts := newColl.
+
+		        newColl := Array new:(sumNtally * 2).
+		        newColl replaceFrom:1 with:sumSelectors.
+		        sumSelectors := newColl.
+
+		        newColl := Array new:(sumNtally * 2).
+		        newColl replaceFrom:1 with:sumClasses.
+		        sumClasses := newColl.
+                    ].
+                    sumSelectors at:sumNtally put:sel.
+                    sumClasses at:sumNtally put:recClass.
+                    sumCounts at:sumNtally put:1.
+                    done := true
+                ] ifFalse:[
+                    ((sumClasses at:index) == recClass) ifTrue:[
+                        sumCounts at:index put:((sumCounts at:index) + 1).
+                        done := true
+                    ]
+                ]
+            ].
+            where := where sender
+        ]
+    ]
+!
+
+statistics
+    "print statistics with percentages"
+
+    |nprobe sumNprobe nthis percent|
+
+    nprobe := 0.
+    1 to:ntally do:[:index |
+        nprobe := nprobe + (counts at:index)
+    ].
+    sumNprobe := 0.
+    1 to:sumNtally do:[:index |
+        sumNprobe := sumNprobe + (sumCounts at:index)
+    ].
+    Transcript cr.
+    Transcript show:'total probes: '.
+    Transcript show:nprobe printString.
+    Transcript show:' ('.
+    Transcript show:sumNprobe printString.
+    Transcript show:')'.
+    Transcript cr.
+    Transcript cr.
+    Transcript show:'  ntally'.
+    Transcript tab show:'percentage'.
+    Transcript tab show:'        class'.     
+    Transcript tab showCr:'       selector'.
+    Transcript showCr:'------------------ leafs ---------------------------'.
+    1 to:ntally do:[:index |
+        nthis := counts at:index.
+        percent := nthis * 100 // nprobe.
+        Transcript show:(nthis printStringRightAdjustLen:6).
+        Transcript tab. Transcript show:'    '.
+        Transcript show:((percent printStringRightAdjustLen:3) , '%').
+        Transcript tab. 
+        Transcript show:((classes at:index) name printStringRightAdjustLen:20).
+        Transcript tab. Transcript show:'    '.
+        Transcript showCr:((selectors at:index) printString)
+    ].
+
+    Transcript showCr:'---------------- accumulated -----------------------'.
+    1 to:sumNtally do:[:index |
+        nthis := sumCounts at:index.
+        percent := nthis * 100 // sumNprobe.
+        Transcript show:(nthis printStringRightAdjustLen:6).
+        Transcript tab. Transcript show:'    '.
+        Transcript show:((percent printStringRightAdjustLen:3) , '%').
+        Transcript tab. 
+        (sumClasses at:index) isNil ifTrue:[
+            Transcript show:('??' printStringRightAdjustLen:20)
+        ] ifFalse:[
+            Transcript show:((sumClasses at:index) name printStringRightAdjustLen:20).
+        ].
+        Transcript tab. Transcript show:'    '.
+        Transcript showCr:((sumSelectors at:index) printString)
+    ]
+! !