--- a/MessageTracer.st Tue Feb 04 21:01:56 2014 +0100
+++ b/MessageTracer.st Wed Apr 01 10:37:40 2015 +0100
@@ -11,13 +11,15 @@
"
"{ Package: 'stx:libbasic3' }"
+"{ NameSpace: Smalltalk }"
+
Object subclass:#MessageTracer
instanceVariableNames:'traceDetail tracedBlock'
classVariableNames:'BreakpointSignal CallingLevel BreakBlock TraceSenderBlock
TraceSenderBlock2 LeaveBreakBlock LeaveTraceBlock MethodCounts
MethodCountsPerReceiverClass MethodMemoryUsage MethodTiming
TraceFullBlock TraceFullBlock2 ObjectWrittenBreakpointSignal
- ObjectCopyHolders TimeForWrappers'
+ ObjectCopyHolders TimeForWrappers MockedMethodMarker'
poolDictionaries:''
category:'System-Debugging-Support'
!
@@ -29,6 +31,13 @@
privateIn:MessageTracer
!
+Object subclass:#MethodSpyInfo
+ instanceVariableNames:'profiler'
+ classVariableNames:''
+ poolDictionaries:''
+ privateIn:MessageTracer
+!
+
Object subclass:#MethodTimingInfo
instanceVariableNames:'count minTime maxTime sumTimes avgTime'
classVariableNames:''
@@ -67,88 +76,88 @@
tracing execution of a block:
- MessageTracer trace:[ ... ]
-
- MessageTracer traceFull:[ ... ]
-
- (for system developer only:)
-
- MessageTracer debugTrace:[ ... ]
+ MessageTracer trace:[ ... ]
+
+ MessageTracer traceFull:[ ... ]
+
+ (for system developer only:)
+
+ MessageTracer debugTrace:[ ... ]
trapping sends to a specific object:
- MessageTracer trap:anObject selector:aSelector
- ...
- MessageTracer untrap:anObject selector:aSelector
- or:
- MessageTracer untrap:anObject
+ MessageTracer trap:anObject selector:aSelector
+ ...
+ MessageTracer untrap:anObject selector:aSelector
+ or:
+ MessageTracer untrap:anObject
trapping some messages sent to a specific object:
- MessageTracer trap:anObject selectors:aCollectionOfSelectors
- ...
- MessageTracer untrap:anObject
+ MessageTracer trap:anObject selectors:aCollectionOfSelectors
+ ...
+ MessageTracer untrap:anObject
trapping any message sent to a specific object:
- MessageTracer trapAll:anObject
- ...
- MessageTracer untrap:anObject
+ MessageTracer trapAll:anObject
+ ...
+ MessageTracer untrap:anObject
trapping evaluation of a specific method:
- MessageTracer trapMethod:aMethod
- ...
- MessageTracer unwrapMethod:aMethod
+ MessageTracer trapMethod:aMethod
+ ...
+ MessageTracer unwrapMethod:aMethod
trapping evaluation of a specific method with
receiver being an instance of some class:
- MessageTracer trapMethod:aMethod forInstancesOf:aClass
- ...
- MessageTracer unwrapMethod:aMethod
+ MessageTracer trapMethod:aMethod forInstancesOf:aClass
+ ...
+ MessageTracer unwrapMethod:aMethod
tracing sends to a specific object:
- MessageTracer trace:anObject selector:aSelector
- ...
- MessageTracer untrace:anObject selector:aSelector
- or:
- MessageTracer untrace:anObject
+ MessageTracer trace:anObject selector:aSelector
+ ...
+ MessageTracer untrace:anObject selector:aSelector
+ or:
+ MessageTracer untrace:anObject
tracing sender only:
- MessageTracer traceSender:anObject selector:aSelector
- ...
- MessageTracer untrace:anObject selector:aSelector
- or:
- MessageTracer untrace:anObject
+ MessageTracer traceSender:anObject selector:aSelector
+ ...
+ MessageTracer untrace:anObject selector:aSelector
+ or:
+ MessageTracer untrace:anObject
tracing evaluation of a specific method:
- MessageTracer traceMethod:aMethod
- ...
- MessageTracer unwrapmethod:aMethod
+ MessageTracer traceMethod:aMethod
+ ...
+ MessageTracer unwrapmethod:aMethod
see more in examples and in method comments.
[author:]
- Claus Gittinger
+ Claus Gittinger
"
!
@@ -161,60 +170,60 @@
trapping specific methods:
(by class/selector):
- [exBegin]
+ [exBegin]
MessageTracer trapClass:Collection selector:#select:.
Dictionary new select:[:e | ]. 'not caught - Dictionary has its own select'.
(Array new:10) select:[:e | ]. 'not caught - SeqColl has its own select'.
Set new select:[:e | ]. 'caught - Set inherits this from Collection'.
- MessageTracer untrapClass:Collection
- [exEnd]
+ MessageTracer untrapClass:Collection
+ [exEnd]
(by method):
- [exBegin]
+ [exBegin]
MessageTracer trapMethod:(Collection compiledMethodAt:#select:).
Dictionary new select:[:e | ]. 'not caught - Dictionary has its own select'.
(Array new:10) select:[:e | ]. 'not caught - SeqColl has its own select'.
Set new select:[:e | ]. 'caught - Set inherits this from Collection'.
MessageTracer unwrapMethod:(Collection compiledMethodAt:#select:).
- [exEnd]
+ [exEnd]
(by method & instance class):
- [exBegin]
+ [exBegin]
MessageTracer trapMethod:(SequenceableCollection compiledMethodAt:#select:)
- forInstancesOf:SortedCollection.
+ forInstancesOf:SortedCollection.
Dictionary new select:[:e | ]. 'not caught - Dictionary has its own select'.
(Array new:10) select:[:e | ]. 'not caught - not a SortedCollection'.
OrderedCollection new select:[:e | ]. 'not caught - not a SortedCollection'.
SortedCollection new select:[:e | ]. 'caught - Set inherits this from Collection'.
MessageTracer unwrapMethod:(SequenceableCollection compiledMethodAt:#select:).
- [exEnd]
+ [exEnd]
tracing specific methods:
(by class/selector):
- [exBegin]
+ [exBegin]
MessageTracer traceClass:SequenceableCollection selector:#quickSortFrom:to:.
#(6 1 9 66 2 17) copy sort.
- MessageTracer untraceClass:SequenceableCollection
- [exEnd]
+ MessageTracer untraceClass:SequenceableCollection
+ [exEnd]
(by method):
- [exBegin]
+ [exBegin]
MessageTracer traceMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:).
#(6 1 9 66 2 17) copy sort.
- MessageTracer unwrapMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:).
- [exEnd]
+ MessageTracer unwrapMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:).
+ [exEnd]
object trapping:
- [exBegin]
+ [exBegin]
|o|
o := OrderedCollection new.
MessageTracer trapAll:o.
o collect:[:el | el].
- [exEnd]
+ [exEnd]
trapping modifications to an objects instVars:
- [exBegin]
+ [exBegin]
|o|
o := Point new.
@@ -224,10 +233,10 @@
o x:1.
o y:2.
MessageTracer untrap:o
- [exEnd]
+ [exEnd]
trapping modifications of a particular instVar:
- [exBegin]
+ [exBegin]
|o|
o := Point new.
@@ -237,11 +246,11 @@
o x:1.
o y:2.
MessageTracer untrap:o
- [exEnd]
+ [exEnd]
tracing during block execution:
- [exBegin]
+ [exBegin]
MessageTracer trace:[ 10 factorialR ]
- [exEnd]
+ [exEnd]
"
! !
@@ -285,19 +294,22 @@
ObjectMemory addDependent:self.
+ MockedMethodMarker := Object new.
+
"
BreakpointSignal := nil.
MessageTracer initialize
"
"Modified: / 15-09-2011 / 19:02:13 / cg"
+ "Modified: / 29-07-2014 / 09:16:45 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
update:something with:parameter from:changedObject
"sent when restarted after a snapIn"
(something == #restarted) ifTrue:[
- TimeForWrappers := nil
+ TimeForWrappers := nil
]
"Created: / 30.7.1998 / 17:00:09 / cg"
@@ -325,10 +337,10 @@
!MessageTracer class methodsFor:'class wrapping'!
-wrapClass:orgClass selector:aSelector onEntry:entryBlock onExit:exitBlock
+wrapClass:orgClass selector:aSelector onEntry:entryBlock onExit:exitBlock
"arrange for the two blocks entryBlock and exitBlock to be evaluated whenever
- aSelector is sent to instances of orgClass or subclasses.
- EntryBlock will be called on entry, and get the current context passed as argument.
+ aSelector is sent to instances of orgClass or subclasses.
+ EntryBlock will be called on entry, and get the current context passed as argument.
ExitBlock will be called, when the method is left, and get context and the methods return value as arguments.
"
@@ -348,41 +360,41 @@
s nextPutAll:'<context: #return>'; cr.
s nextPutAll:'|retVal stubClass|'; cr.
entryBlock notNil ifTrue:[
- s nextPutAll:'#literal1 yourself value:thisContext.'; cr.
+ s nextPutAll:'#literal1 yourself value:thisContext.'; cr.
].
s nextPutAll:('retVal := #originalMethod. '). "/ just to get a literal to be replaced by theoriginal method
s nextPutAll:('retVal := super ' , spec , '.'); cr.
exitBlock notNil ifTrue:[
- s nextPutAll:'#literal2 yourself value:thisContext value:retVal.'; cr.
+ s nextPutAll:'#literal2 yourself value:thisContext value:retVal.'; cr.
].
s nextPutAll:'^ retVal'; cr.
- ParserFlags
- withSTCCompilation:#never
- do:[
- Class withoutUpdatingChangesDo:[
- trapMethod := Compiler
- compile:s contents
- forClass:orgClass
- inCategory:'trapping'
- notifying:nil
- install:false
- skipIfSame:false
- silent:true.
- ]
- ].
+ ParserFlags
+ withSTCCompilation:#never
+ do:[
+ Class withoutUpdatingChangesDo:[
+ trapMethod := Compiler
+ compile:s contents
+ forClass:orgClass
+ inCategory:'trapping'
+ notifying:nil
+ install:false
+ skipIfSame:false
+ silent:true.
+ ]
+ ].
implClass := orgClass whichClassIncludesSelector:aSelector.
implClass isNil ifTrue:[
- Transcript showCR:aSelector , ' is not understood by ' , orgClass name.
+ Transcript showCR:aSelector , ' is not understood by ' , orgClass name.
] ifFalse:[
- trapMethod changeLiteral:#originalMethod to:(implClass compiledMethodAt:aSelector).
+ trapMethod changeLiteral:#originalMethod to:(implClass compiledMethodAt:aSelector).
].
entryBlock notNil ifTrue:[
- trapMethod changeLiteral:#literal1 to:entryBlock.
+ trapMethod changeLiteral:#literal1 to:entryBlock.
].
exitBlock notNil ifTrue:[
- trapMethod changeLiteral:#literal2 to:exitBlock.
+ trapMethod changeLiteral:#literal2 to:exitBlock.
].
"
@@ -399,90 +411,90 @@
if not already trapping, create a new class
"
orgClass category == #'* trapping *' ifTrue:[
- dict at:aSelector put:trapMethod.
- orgClass methodDictionary:dict.
- newClass := orgClass superclass.
+ dict at:aSelector put:trapMethod.
+ orgClass methodDictionary:dict.
+ newClass := orgClass superclass.
] ifFalse:[
- myMetaclass := orgClass class.
-
- newClass := myMetaclass copy new.
- newClass setSuperclass:orgClass superclass.
- newClass instSize:orgClass instSize.
- newClass flags:orgClass flags.
- newClass setClassVariableString:orgClass classVariableString.
- newClass setSharedPoolNames:(orgClass sharedPoolNames).
- newClass setInstanceVariableString:orgClass instanceVariableString.
- newClass setName:orgClass name.
- newClass setCategory:orgClass category.
- newClass methodDictionary:dict.
-
- orgClass setSuperclass:newClass.
- orgClass setClassVariableString:''.
- orgClass setInstanceVariableString:''.
- orgClass setCategory:#'* trapping *'.
-
- dict := MethodDictionary new:1.
- dict at:aSelector put:trapMethod.
- orgClass methodDictionary:dict.
+ myMetaclass := orgClass class.
+
+ newClass := myMetaclass copy new.
+ newClass setSuperclass:orgClass superclass.
+ newClass instSize:orgClass instSize.
+ newClass flags:orgClass flags.
+ newClass setClassVariableString:orgClass classVariableString.
+ newClass setSharedPoolNames:(orgClass sharedPoolNames).
+ newClass setInstanceVariableString:orgClass instanceVariableString.
+ newClass setName:orgClass name.
+ newClass setCategory:orgClass category.
+ newClass methodDictionary:dict.
+
+ orgClass setSuperclass:newClass.
+ orgClass setClassVariableString:''.
+ orgClass setInstanceVariableString:''.
+ orgClass setCategory:#'* trapping *'.
+
+ dict := MethodDictionary new:1.
+ dict at:aSelector put:trapMethod.
+ orgClass methodDictionary:dict.
].
trapMethod changeLiteral:(newClass superclass) to:newClass.
ObjectMemory flushCaches.
"
- MessageTracer
- wrapClass:Point
- selector:#scaleBy:
- onEntry:nil
- onExit:[:con :retVal |
- Transcript show:'leave Point>>scaleBy:; returning:'.
- Transcript showCR:retVal printString.
- Transcript endEntry
- ].
- (1@2) scaleBy:5.
- MessageTracer untrapClass:Point selector:#scaleBy:.
- (1@2) scaleBy:5.
+ MessageTracer
+ wrapClass:Point
+ selector:#scaleBy:
+ onEntry:nil
+ onExit:[:con :retVal |
+ Transcript show:'leave Point>>scaleBy:; returning:'.
+ Transcript showCR:retVal printString.
+ Transcript endEntry
+ ].
+ (1@2) scaleBy:5.
+ MessageTracer untrapClass:Point selector:#scaleBy:.
+ (1@2) scaleBy:5.
"
"
- MessageTracer
- wrapClass:Integer
- selector:#factorial
- onEntry:[:con |
- Transcript showCR:('entering ' , con receiver printString , '>>factorial').
- ]
- onExit:[:con :retVal |
- Transcript show:'leave Integer>>factorial; returning:'.
- Transcript showCR:retVal printString.
- Transcript endEntry
- ].
+ MessageTracer
+ wrapClass:Integer
+ selector:#factorial
+ onEntry:[:con |
+ Transcript showCR:('entering ' , con receiver printString , '>>factorial').
+ ]
+ onExit:[:con :retVal |
+ Transcript show:'leave Integer>>factorial; returning:'.
+ Transcript showCR:retVal printString.
+ Transcript endEntry
+ ].
Transcript showCR:'5 factorial traced'.
- 5 factorial.
- MessageTracer untrapClass:Integer selector:#factorial.
+ 5 factorial.
+ MessageTracer untrapClass:Integer selector:#factorial.
Transcript showCR:'5 factorial normal'.
- 5 factorial.
+ 5 factorial.
"
"
|lvl|
lvl := 0.
- MessageTracer
- wrapClass:Integer
- selector:#factorial
- onEntry:[:con |
- Transcript spaces:lvl. lvl := lvl + 2.
- Transcript showCR:('entering ' , con receiver printString , '>>factorial').
- ]
- onExit:[:con :retVal |
- lvl := lvl - 2. Transcript spaces:lvl.
- Transcript show:('leave ' , con receiver printString , '>>factorial; returning:').
- Transcript showCR:retVal printString.
- Transcript endEntry
- ].
+ MessageTracer
+ wrapClass:Integer
+ selector:#factorial
+ onEntry:[:con |
+ Transcript spaces:lvl. lvl := lvl + 2.
+ Transcript showCR:('entering ' , con receiver printString , '>>factorial').
+ ]
+ onExit:[:con :retVal |
+ lvl := lvl - 2. Transcript spaces:lvl.
+ Transcript show:('leave ' , con receiver printString , '>>factorial; returning:').
+ Transcript showCR:retVal printString.
+ Transcript endEntry
+ ].
Transcript showCR:'5 factorial traced'.
- 5 factorial.
- MessageTracer untrapClass:Integer selector:#factorial.
+ 5 factorial.
+ MessageTracer untrapClass:Integer selector:#factorial.
Transcript showCR:'5 factorial normal'.
- 5 factorial.
+ 5 factorial.
"
"Modified: / 25-06-1996 / 22:01:05 / stefan"
@@ -537,9 +549,9 @@
"evaluate aBlock sending trace information to stdout.
Return the value of the block."
- ^ PrintingMessageTracer new
- output:aStream;
- trace:aBlock detail:false.
+ ^ PrintingMessageTracer new
+ output:aStream;
+ trace:aBlock detail:false.
"
MessageTracer trace:[#(6 5 4 3 2 1) sort] on:Transcript
@@ -563,9 +575,9 @@
Return the value of the block.
The trace information is more detailed."
- ^ PrintingMessageTracer new
- output:aStream;
- trace:aBlock detail:true.
+ ^ PrintingMessageTracer new
+ output:aStream;
+ trace:aBlock detail:true.
"
MessageTracer traceFull:[#(6 5 4 3 2 1) sort]
@@ -589,9 +601,9 @@
Return the value of the block.
The trace information is more detailed."
- ^ PrintingMessageTracer new
- output:aStream;
- trace:aBlock detail:#fullIndent.
+ ^ PrintingMessageTracer new
+ output:aStream;
+ trace:aBlock detail:#fullIndent.
"
MessageTracer traceFullIndented:[ #(6 5 4 3 2 1) sort ]
@@ -613,9 +625,9 @@
"evaluate aBlock sending trace information to stdout.
Return the value of the block."
- ^ PrintingMessageTracer new
- output:aStream;
- trace:aBlock detail:#indent.
+ ^ PrintingMessageTracer new
+ output:aStream;
+ trace:aBlock detail:#indent.
"
MessageTracer traceIndented:[ #(6 5 4 3 2 1) sort ] on:Transcript
@@ -625,7 +637,7 @@
!MessageTracer class methodsFor:'method breakpointing'!
trapClass:aClass selector:aSelector
- "arrange for the debugger to be entered when a message with aSelector is
+ "arrange for the debugger to be entered when a message with aSelector is
sent to instances of aClass (or subclass instances). Use untrapClass to remove this trap.
Be careful, to not place a trap on code needed in the debugger (i.e. on scrollBars etc.);
if there is a need to trap those, use the low-level wrap-methods, and put a check into the
@@ -638,7 +650,7 @@
Dictionary new select:[:e | ]. 'not caught - Dictionary has its own select'.
(Array new:10) select:[:e | ]. 'not caught - SeqColl has its own select'.
Set new select:[:e | ]. 'caught - Set inherits this from Collection'.
- MessageTracer untrapClass:Collection
+ MessageTracer untrapClass:Collection
"
!
@@ -652,8 +664,8 @@
entry/leave blocks."
^ self wrapMethod:aMethod
- onEntry:BreakBlock
- onExit:LeaveBreakBlock.
+ onEntry:BreakBlock
+ onExit:LeaveBreakBlock.
"
MessageTracer trapMethod:(Collection compiledMethodAt:#select:).
@@ -678,13 +690,13 @@
n := 0.
^ self wrapMethod:aMethod
- onEntry:[:con | n := n + 1.
- n > countInvocations
- ifTrue:[
- BreakpointSignal raiseRequestWith:nil errorString:nil in:con
- ]
- ]
- onExit:LeaveBreakBlock.
+ onEntry:[:con | n := n + 1.
+ n > countInvocations
+ ifTrue:[
+ BreakpointSignal raiseRequestWith:nil errorString:nil in:con
+ ]
+ ]
+ onExit:LeaveBreakBlock.
!
@@ -697,12 +709,12 @@
entry/leave blocks."
^ self wrapMethod:aMethod
- onEntry:[:con |
- (con receiver isMemberOf:aClass) ifTrue:[
- BreakpointSignal raiseRequestWith:nil errorString:nil in:con
- ]
- ]
- onExit:LeaveBreakBlock.
+ onEntry:[:con |
+ (con receiver isMemberOf:aClass) ifTrue:[
+ BreakpointSignal raiseRequestWith:nil errorString:nil in:con
+ ]
+ ]
+ onExit:LeaveBreakBlock.
"
MessageTracer trapMethod:(View compiledMethodAt:#redraw) forInstancesOf:myView.
@@ -720,26 +732,26 @@
if there is a need to trap those, use the low-level wrap-methods, and put a check into the
entry/leave blocks."
- ^ self
- wrapMethod:aMethod
- onEntry:[:con |
- |conditionFires|
-
- Error handle:[:ex |
- 'MessageTrace: error in breakpoint condition cought: ' errorPrint.
- ex description errorPrintCR.
- ] do:[
- conditionBlock numArgs == 1 ifTrue:[
- conditionFires := conditionBlock value:con
- ] ifFalse:[
- conditionFires := conditionBlock value:con value:aMethod
- ].
- ].
- conditionFires == true ifTrue:[
- BreakpointSignal raiseRequestWith:nil errorString:nil in:con
- ]
- ]
- onExit:LeaveBreakBlock.
+ ^ self
+ wrapMethod:aMethod
+ onEntry:[:con |
+ |conditionFires|
+
+ Error handle:[:ex |
+ 'MessageTrace: error in breakpoint condition caught: ' errorPrint.
+ ex description errorPrintCR.
+ ] do:[
+ conditionBlock numArgs == 1 ifTrue:[
+ conditionFires := conditionBlock value:con
+ ] ifFalse:[
+ conditionFires := conditionBlock value:con value:aMethod
+ ].
+ ].
+ conditionFires == true ifTrue:[
+ BreakpointSignal raiseRequestWith:nil errorString:nil in:con
+ ]
+ ]
+ onExit:LeaveBreakBlock.
"Created: / 18-08-2000 / 22:09:10 / cg"
"Modified: / 20-10-2010 / 09:38:57 / cg"
@@ -756,12 +768,12 @@
entry/leave blocks."
^ self wrapMethod:aMethod
- onEntry:[:con |
- (Processor activeProcess processGroupId = aProcess id) ifTrue:[
- BreakpointSignal raiseRequestWith:nil errorString:nil in:con
- ]
- ]
- onExit:LeaveBreakBlock.
+ onEntry:[:con |
+ (Processor activeProcess processGroupId = aProcess id) ifTrue:[
+ BreakpointSignal raiseRequestWith:nil errorString:nil in:con
+ ]
+ ]
+ onExit:LeaveBreakBlock.
"Created: 14.10.1996 / 15:38:46 / cg"
"Modified: 22.10.1996 / 17:40:06 / cg"
@@ -771,7 +783,7 @@
"remove any traps on any class"
Smalltalk allClassesDo:[:aClass |
- self untrapClass:aClass
+ self untrapClass:aClass
]
"
@@ -787,7 +799,7 @@
|orgClass|
aClass category == #'* trapping *' ifFalse:[
- ^ self
+ ^ self
].
orgClass := aClass superclass.
@@ -814,7 +826,7 @@
|dict|
aClass category == #'* trapping *' ifFalse:[
- ^ self
+ ^ self
].
dict := aClass methodDictionary.
@@ -823,8 +835,8 @@
ObjectMemory flushCaches. "avoid calling the old trap method"
dict size == 1 ifTrue:[
- "the last trapped method"
- ^ self untrapClass:aClass
+ "the last trapped method"
+ ^ self untrapClass:aClass
].
dict removeKey:aSelector.
aClass methodDictionary:dict.
@@ -859,7 +871,7 @@
!MessageTracer class methodsFor:'method breakpointing - new'!
-breakMethod: method atLine: line
+breakMethod: method atLine: line
"Installs new breakpoint in given method at given line.
Returns the installed breakpoint or nil if none could be
installed"
@@ -867,8 +879,8 @@
| analyzer map lines i breakpoint table |
(ConfigurableFeatures includesFeature: #VMBreakpointSupport) ifFalse:[
- self error: 'Breakpoint support not present'.
- ^nil.
+ self error: 'Breakpoint support not present'.
+ ^nil.
].
analyzer := BreakpointAnalyzer parseMethodSilent: method source in: method mclass.
@@ -876,24 +888,24 @@
lines := map keys asSortedCollection.
i := lines indexForInserting: line.
i > lines size ifTrue:[
- ^nil
+ ^nil
].
breakpoint := Breakpoint new line: (lines at: i).
breakpoint breaksToIgnore: (((map at: breakpoint line) size - 1) max: 0).
table := method breakpointTable.
table isNil ifTrue:[
- "/old way:
- "/table := Array with: (breakpoint line) with: breakpoint.
-
- "/new way:
- table := Array with: breakpoint.
+ "/old way:
+ "/table := Array with: (breakpoint line) with: breakpoint.
+
+ "/new way:
+ table := Array with: breakpoint.
] ifFalse:[
- "/old way:
- "/table := table, (Array with: (breakpoint line) with: breakpoint).
-
- "/new way:
- table := table copyWith: breakpoint
+ "/old way:
+ "/table := table, (Array with: (breakpoint line) with: breakpoint).
+
+ "/new way:
+ table := table copyWith: breakpoint
].
method breakpointTable: table.
@@ -910,27 +922,26 @@
Use unwrapMethod to remove this."
MethodCounts isNil ifTrue:[
- MethodCounts := IdentityDictionary new.
+ MethodCounts := IdentityDictionary new.
].
MethodCounts at:aMethod put:0.
^ self wrapMethod:aMethod
- onEntry:[:con |
- |cnt|
-
- cnt := MethodCounts at:aMethod ifAbsent:0.
- MethodCounts at:aMethod put:(cnt + 1).
- MessageTracer changed:#statistics: with:aMethod.
- aMethod changed:#statistics
- ]
- onExit:[:con :retVal |
- ]
+ onEntry:[:con |
+ |cnt|
+
+ cnt := MethodCounts at:aMethod ifAbsent:0.
+ MethodCounts at:aMethod put:(cnt + 1).
+ MessageTracer changed:#statistics: with:aMethod.
+ aMethod changed:#statistics
+ ]
+ onExit:nil
"
MessageTracer countMethod:(Integer compiledMethodAt:#factorial).
5 factorial.
- MessageTracer executionCountOf:(Integer compiledMethodAt:#factorial) printNL.
- MessageTracer stopCountingMethod:(Integer compiledMethodAt:#factorial)
+ MessageTracer executionCountOf:(Integer compiledMethodAt:#factorial) printNL.
+ MessageTracer stopCountingMethod:(Integer compiledMethodAt:#factorial)
"
"Created: / 15.12.1995 / 10:57:49 / cg"
@@ -943,29 +954,28 @@
Use unwrapMethod to remove this."
MethodCountsPerReceiverClass isNil ifTrue:[
- MethodCountsPerReceiverClass := IdentityDictionary new.
+ MethodCountsPerReceiverClass := IdentityDictionary new.
].
MethodCountsPerReceiverClass at:aMethod put:(IdentityDictionary new).
^ self wrapMethod:aMethod
- onEntry:[:con |
- |cls perMethodCounts cnt|
-
- cls := (con receiver class).
- perMethodCounts := MethodCountsPerReceiverClass at:aMethod.
- cnt := perMethodCounts at:cls ifAbsentPut:0.
- perMethodCounts at:cls put:(cnt + 1).
- MessageTracer changed:#statistics: with:aMethod.
- aMethod changed:#statistics
- ]
- onExit:[:con :retVal |
- ]
+ onEntry:[:con |
+ |cls perMethodCounts cnt|
+
+ cls := (con receiver class).
+ perMethodCounts := MethodCountsPerReceiverClass at:aMethod.
+ cnt := perMethodCounts at:cls ifAbsentPut:0.
+ perMethodCounts at:cls put:(cnt + 1).
+ MessageTracer changed:#statistics: with:aMethod.
+ aMethod changed:#statistics
+ ]
+ onExit:nil
"
MessageTracer countMethodWithReceiverStatistic:(Collection compiledMethodAt:#detect:).
NewSystemBrowser open.
- MessageTracer executionCountsOf:(Collection compiledMethodAt:#detect:) printNL.
- MessageTracer stopCountingMethod:(Collection compiledMethodAt:#detect:)
+ MessageTracer executionCountsOf:(Collection compiledMethodAt:#detect:) printNL.
+ MessageTracer stopCountingMethod:(Collection compiledMethodAt:#detect:)
"
!
@@ -975,20 +985,20 @@
|count counts|
MethodCounts notNil ifTrue:[
- aMethod isWrapped ifTrue:[
- count := MethodCounts at:aMethod originalMethod ifAbsent:nil.
- count notNil ifTrue:[^ count].
- ].
- ^ MethodCounts at:aMethod ifAbsent:0
+ aMethod isWrapped ifTrue:[
+ count := MethodCounts at:aMethod originalMethod ifAbsent:nil.
+ count notNil ifTrue:[^ count].
+ ].
+ ^ MethodCounts at:aMethod ifAbsent:0
].
MethodCountsPerReceiverClass notNil ifTrue:[
- aMethod isWrapped ifTrue:[
- counts := MethodCountsPerReceiverClass at:aMethod originalMethod ifAbsent:nil.
- ].
- counts isNil ifTrue:[
- counts := MethodCounts at:aMethod ifAbsent:#().
- ].
- ^ (counts collect:[:eachClassCountAssoc | eachClassCountAssoc value]) sum
+ aMethod isWrapped ifTrue:[
+ counts := MethodCountsPerReceiverClass at:aMethod originalMethod ifAbsent:nil.
+ ].
+ counts isNil ifTrue:[
+ counts := MethodCounts at:aMethod ifAbsent:#().
+ ].
+ ^ (counts collect:[:eachClassCountAssoc | eachClassCountAssoc value]) sum
].
^ 0
!
@@ -999,13 +1009,13 @@
|counts|
MethodCountsPerReceiverClass notNil ifTrue:[
- aMethod isWrapped ifTrue:[
- counts := MethodCountsPerReceiverClass at:aMethod originalMethod ifAbsent:nil.
- ].
- counts isNil ifTrue:[
- counts := MethodCounts at:aMethod ifAbsent:#().
- ].
- ^ counts
+ aMethod isWrapped ifTrue:[
+ counts := MethodCountsPerReceiverClass at:aMethod originalMethod ifAbsent:nil.
+ ].
+ counts isNil ifTrue:[
+ counts := MethodCounts at:aMethod ifAbsent:#().
+ ].
+ ^ counts
].
^ #()
!
@@ -1014,9 +1024,9 @@
"return the current count"
MethodCounts notNil ifTrue:[
- aMethod isWrapped ifTrue:[
- MethodCounts at:aMethod originalMethod put:0.
- ].
+ aMethod isWrapped ifTrue:[
+ MethodCounts at:aMethod originalMethod put:0.
+ ].
].
"Created: / 30.7.1998 / 17:42:08 / cg"
@@ -1026,14 +1036,14 @@
"remove counting of aMethod"
MethodCounts notNil ifTrue:[
- aMethod isWrapped ifTrue:[
- MethodCounts removeKey:aMethod originalMethod ifAbsent:nil.
- ].
+ aMethod isWrapped ifTrue:[
+ MethodCounts removeKey:aMethod originalMethod ifAbsent:nil.
+ ].
].
MethodCountsPerReceiverClass notNil ifTrue:[
- aMethod isWrapped ifTrue:[
- MethodCountsPerReceiverClass removeKey:aMethod originalMethod ifAbsent:nil.
- ].
+ aMethod isWrapped ifTrue:[
+ MethodCountsPerReceiverClass removeKey:aMethod originalMethod ifAbsent:nil.
+ ].
].
^ self unwrapMethod:aMethod
@@ -1049,53 +1059,54 @@
|oldPriority oldScavengeCount oldNewUsed|
MethodCounts isNil ifTrue:[
- MethodCounts := IdentityDictionary new.
+ MethodCounts := IdentityDictionary new.
].
MethodMemoryUsage isNil ifTrue:[
- MethodMemoryUsage := IdentityDictionary new.
+ MethodMemoryUsage := IdentityDictionary new.
].
MethodCounts at:aMethod put:0.
MethodMemoryUsage at:aMethod put:0.
^ self wrapMethod:aMethod
- onEntry:[:con |
- oldPriority := Processor activeProcess changePriority:(Processor userInterruptPriority).
- oldNewUsed := ObjectMemory newSpaceUsed.
- oldScavengeCount := ObjectMemory scavengeCount.
- ]
- onExit:[:con :retVal |
- |cnt memUse scavenges|
-
- memUse := ObjectMemory newSpaceUsed - oldNewUsed.
- scavenges := ObjectMemory scavengeCount - oldScavengeCount.
- scavenges ~= 0 ifTrue:[
- memUse := memUse + (ObjectMemory newSpaceSize * scavenges)
- ].
-
- MethodCounts notNil ifTrue:[
- cnt := MethodCounts at:aMethod ifAbsent:0.
- MethodCounts at:aMethod put:(cnt + 1).
- ].
- MethodMemoryUsage notNil ifTrue:[
- cnt := MethodMemoryUsage at:aMethod ifAbsent:0.
- MethodMemoryUsage at:aMethod put:(cnt + memUse).
- ].
- Processor activeProcess priority:oldPriority.
- MessageTracer changed:#statistics: with:aMethod.
- aMethod changed:#statistics
- ]
- onUnwind:[
- oldPriority notNil ifTrue:[
- Processor activeProcess priority:oldPriority
- ]
- ]
+ onEntry:[:con |
+ oldPriority := Processor activeProcess changePriority:(Processor userInterruptPriority).
+ oldNewUsed := ObjectMemory newSpaceUsed.
+ oldScavengeCount := ObjectMemory scavengeCount.
+ ]
+ onExit:[:con :retVal |
+ |cnt memUse scavenges|
+
+ memUse := ObjectMemory newSpaceUsed - oldNewUsed.
+ scavenges := ObjectMemory scavengeCount - oldScavengeCount.
+ scavenges ~= 0 ifTrue:[
+ memUse := memUse + (ObjectMemory newSpaceSize * scavenges)
+ ].
+
+ MethodCounts notNil ifTrue:[
+ cnt := MethodCounts at:aMethod ifAbsent:0.
+ MethodCounts at:aMethod put:(cnt + 1).
+ ].
+ MethodMemoryUsage notNil ifTrue:[
+ cnt := MethodMemoryUsage at:aMethod ifAbsent:0.
+ MethodMemoryUsage at:aMethod put:(cnt + memUse).
+ ].
+ Processor activeProcess priority:oldPriority.
+ MessageTracer changed:#statistics: with:aMethod.
+ aMethod changed:#statistics.
+ retVal
+ ]
+ onUnwind:[
+ oldPriority notNil ifTrue:[
+ Processor activeProcess priority:oldPriority
+ ]
+ ]
"
MessageTracer countMemoryUsageOfMethod:(Integer compiledMethodAt:#factorialR).
3 factorialR.
- Transcript showCR:(MessageTracer memoryUsageOfMethod:(Integer compiledMethodAt:#factorialR)).
- MessageTracer stopCountingMemoryUsageOfMethod:(Integer compiledMethodAt:#factorialR)
+ Transcript showCR:(MessageTracer memoryUsageOfMethod:(Integer compiledMethodAt:#factorialR)).
+ MessageTracer stopCountingMemoryUsageOfMethod:(Integer compiledMethodAt:#factorialR)
"
"Created: / 18.12.1995 / 15:41:27 / stefan"
@@ -1123,13 +1134,13 @@
(MethodCounts isNil or:[MethodMemoryUsage isNil]) ifTrue:[^ 0].
aMethod isWrapped ifTrue:[
- orgMethod := aMethod originalMethod.
- count := MethodCounts at:orgMethod ifAbsent:nil.
- memUse := MethodMemoryUsage at:orgMethod ifAbsent:nil.
+ orgMethod := aMethod originalMethod.
+ count := MethodCounts at:orgMethod ifAbsent:nil.
+ memUse := MethodMemoryUsage at:orgMethod ifAbsent:nil.
].
memUse isNil ifTrue:[
- count := MethodCounts at:aMethod ifAbsent:0.
- memUse := MethodMemoryUsage at:aMethod ifAbsent:0.
+ count := MethodCounts at:aMethod ifAbsent:0.
+ memUse := MethodMemoryUsage at:aMethod ifAbsent:0.
].
count = 0 ifTrue:[^ 0].
^ memUse//count
@@ -1143,13 +1154,13 @@
|orgMethod|
MethodCounts notNil ifTrue:[
- MethodMemoryUsage notNil ifTrue:[
- aMethod isWrapped ifTrue:[
- orgMethod := aMethod originalMethod.
- MethodCounts at:orgMethod put:0.
- MethodMemoryUsage at:orgMethod put:nil.
- ]
- ].
+ MethodMemoryUsage notNil ifTrue:[
+ aMethod isWrapped ifTrue:[
+ orgMethod := aMethod originalMethod.
+ MethodCounts at:orgMethod put:0.
+ MethodMemoryUsage at:orgMethod put:nil.
+ ]
+ ].
].
"Created: / 30.7.1998 / 17:43:07 / cg"
@@ -1161,584 +1172,249 @@
|orgMethod|
MethodCounts notNil ifTrue:[
- MethodMemoryUsage notNil ifTrue:[
- aMethod isWrapped ifTrue:[
- orgMethod := aMethod originalMethod.
- MethodCounts removeKey:orgMethod ifAbsent:nil.
- MethodMemoryUsage removeKey:orgMethod ifAbsent:nil.
- ]
- ].
+ MethodMemoryUsage notNil ifTrue:[
+ aMethod isWrapped ifTrue:[
+ orgMethod := aMethod originalMethod.
+ MethodCounts removeKey:orgMethod ifAbsent:nil.
+ MethodMemoryUsage removeKey:orgMethod ifAbsent:nil.
+ ]
+ ].
].
^ self unwrapMethod:aMethod
"Modified: 18.12.1995 / 21:54:36 / stefan"
! !
-!MessageTracer class methodsFor:'method timing'!
-
-executionTimesOfMethod:aMethod
- "return the current gathered execution time statistics"
-
- |info|
-
- MethodTiming notNil ifTrue:[
- aMethod isWrapped ifTrue:[
- info := ( MethodTiming at:(aMethod originalMethod) ifAbsent:nil ) copy.
- ].
- ].
-
- info isNil ifTrue:[ info := MethodTimingInfo new ].
- ^ info
-
- "Created: / 17-06-1996 / 17:07:30 / cg"
- "Modified: / 05-03-2007 / 15:46:17 / cg"
-!
-
-resetExecutionTimesOfMethod:aMethod
- "reset the gathered execution times statistics for aMethod;
- the method remains wrapped."
-
- MethodTiming notNil ifTrue:[
- MethodTiming removeKey:aMethod.
- aMethod isWrapped ifTrue:[
- MethodTiming removeKey:aMethod originalMethod.
- ].
- ].
-
- "Created: / 30-07-1998 / 17:12:35 / cg"
- "Modified: / 05-03-2007 / 15:36:59 / cg"
-!
-
-stopTimingMethod:aMethod
- "remove timing of aMethod"
-
- ^ self unwrapMethod:aMethod
-
- "Modified: 15.12.1995 / 15:43:53 / cg"
- "Created: 17.6.1996 / 17:04:03 / cg"
-!
-
-timeMethod:aMethod
- "arrange for a aMethod's execution time to be measured.
- Use unwrapMethod: or stopTimingMethod: to remove this."
-
- |t0|
-
- MethodTiming isNil ifTrue:[
- MethodTiming := IdentityDictionary new.
- ].
- MethodTiming removeKey:aMethod ifAbsent:nil.
-
- TimeForWrappers isNil ifTrue:[
- self getTimeForWrappers
- ].
-
- ^ self wrapMethod:aMethod
- onEntry:[:con |
- t0 := OperatingSystem getMicrosecondTime.
- ]
- onExit:[:con :retVal |
- |info t cnt minT maxT sumTimes|
-
- t := OperatingSystem getMicrosecondTime - t0.
- t := t - TimeForWrappers.
- t < 0 ifTrue:[t := 0].
- t := t / 1000.0.
-
- MethodTiming isNil ifTrue:[
- MethodTiming := IdentityDictionary new.
- ].
- info := MethodTiming at:aMethod ifAbsent:nil.
- info isNil ifTrue:[
- MethodTiming at:aMethod put:(info := MethodTimingInfo new)
- ] ifFalse:[
- info rememberExecutionTime:t.
- ].
- MessageTracer changed:#statistics: with:aMethod.
- aMethod changed:#statistics
- ]
-
- "
- MessageTracer timeMethod:(Integer compiledMethodAt:#factorial).
- 5 factorial.
- 5 factorial.
- 5 factorial.
- (MessageTracer executionTimesOfMethod:(Integer compiledMethodAt:#factorial)) printCR.
- MessageTracer stopTimingMethod:(Integer compiledMethodAt:#factorial)
- "
-
- "Created: / 17-06-1996 / 17:03:50 / cg"
- "Modified: / 05-03-2007 / 15:34:01 / cg"
-! !
-
-!MessageTracer class methodsFor:'method tracing'!
-
-traceClass:aClass selector:aSelector
- "arrange for a trace message to be output on Stderr, when a message with aSelector is
- sent to instances of aClass (or subclass instances). Use untraceClass to remove this."
-
- self traceClass:aClass selector:aSelector on:Stderr
-
- "
- MessageTracer traceClass:Integer selector:#factorial.
- 5 factorial.
- MessageTracer untraceClass:Integer
- "
- "
- MessageTracer traceClass:SequenceableCollection selector:#quickSortFrom:to:.
- #(6 1 9 66 2 17) copy sort.
- MessageTracer untraceClass:SequenceableCollection
- "
- "
- MessageTracer traceClass:Array selector:#at:.
- MessageTracer traceClass:Array selector:#at:put:.
- #(6 1 9 66 2 17) copy sort.
- MessageTracer untraceClass:Array
- "
+!MessageTracer class methodsFor:'method mocking'!
+
+mock: selector in: class do: block
+ | method |
+
+ method := class compiledMethodAt: selector ifAbsent: [ self error:'No such mnethod' ].
+ ^ self mockMethod: method do: block
+
+ "Created: / 28-07-2014 / 23:53:18 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 29-07-2014 / 09:44:23 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
-traceClass:aClass selector:aSelector on:aStream
- "arrange for a trace message to be output on aStream, when a message with aSelector is
- sent to instances of aClass (or subclass instances). Use untraceClass to remove this."
-
- self traceMethod:(aClass compiledMethodAt:aSelector) on:aStream
-
- "
- MessageTracer traceClass:Integer selector:#factorial on:Transcript.
- 5 factorial.
- MessageTracer untraceClass:Integer
- "
- "
- MessageTracer traceClass:Integer selector:#factorialR on:Transcript.
- 5 factorialR.
- MessageTracer untraceClass:Integer
- "
-
-!
-
-traceMethod:aMethod
- "arrange for a trace message to be output on Stderr,
- when aMethod is executed. Traces both entry and exit.
- Use unwrapMethod to remove this."
-
- ^ self traceMethod:aMethod on:Stderr
-
- "
- MessageTracer traceMethod:(Integer compiledMethodAt:#factorial).
- 5 factorial.
- MessageTracer untraceMethod:(Integer compiledMethodAt:#factorial)
- "
- "
- MessageTracer traceMethod:(Integer compiledMethodAt:#factorialR).
- 5 factorialR.
- MessageTracer untraceMethod:(Integer compiledMethodAt:#factorialR)
- "
- "
- MessageTracer traceMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:).
- #(6 1 9 66 2 17) copy sort.
- MessageTracer untraceMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:).
- "
- "
- dont do this:
- "
- "
- MessageTracer traceMethod:(Object compiledMethodAt:#at:).
- MessageTracer traceMethod:(Object compiledMethodAt:#at:put:).
- #(6 1 9 66 2 17) copy sort.
- MessageTracer untraceMethod:(Object compiledMethodAt:#at:).
- MessageTracer untraceMethod:(Object compiledMethodAt:#at:put:).
+mockMethod: method do: block
+ "Temporarily change the behaviour of the given method to perform the given block instead
+ of the method's code. The value of the block is returned as the method's return value.
+ The behaviour is changed only for current thread, i.e., thread the calling this methood
+ and its child threads.
+
+ The block gets the receiver as the first argument, followed by method parameters
+ and then - optionally - the original method object.
+
+ Do not forget to 'unmock' by means of #unmockMethod: or #unmockAllMethods
+
+ CAVEAT: The 'current thread and its child threads' detection is done by walking
+ threads along their #creatorId. However, when the parent thread dies,
+ the link if broken and thus 'and its child threads' may not work 100%.
+ For the calling thread itself, mocking should work reliably.
"
-!
-
-traceMethod:aMethod on:aStream
- "arrange for a trace message to be output on aStream,
- when aMethod is executed. Traces both entry and exit.
- Use unwrapMethod to remove this."
-
- |lvl inside|
-
- ^ self wrapMethod:aMethod
- onEntry:[:con |
- inside isNil ifTrue:[
- inside := true.
- CallingLevel isNil ifTrue:[
- CallingLevel := 0.
- ].
- lvl notNil ifTrue:[
- lvl := lvl + 1
- ] ifFalse:[
- CallingLevel := lvl := CallingLevel + 1.
- ].
- MessageTracer printEntryFull:con level:lvl on:aStream.
- inside := nil
- ]
- ]
- onExit:[:con :retVal |
- inside isNil ifTrue:[
- inside := true.
- MessageTracer printExit:con with:retVal level:lvl on:aStream.
- CallingLevel := lvl := lvl - 1.
- inside := nil
- ]
- ]
-
- "
- MessageTracer traceMethod:(Integer compiledMethodAt:#factorial) on:Transcript.
- 5 factorial.
- MessageTracer untraceMethod:(Integer compiledMethodAt:#factorial)
- "
- "
- MessageTracer traceMethod:(Integer compiledMethodAt:#factorialR) on:Transcript.
- 5 factorialR.
- MessageTracer untraceMethod:(Integer compiledMethodAt:#factorialR)
- "
- "
- MessageTracer traceMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:) on:Transcript.
- #(6 1 9 66 2 17) copy sort.
- MessageTracer untraceMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:).
- "
-!
-
-traceMethodAll:aMethod
- "arrange for a full trace message to be output on Stderr, when aMethod is executed.
- Only the sender is traced on entry.
- Use untraceMethod to remove this trace.
- This is for system debugging only;
- The trace output is a low level trace generated in the VM."
-
- ^ self wrapMethod:aMethod
- onEntry:[:con | ObjectMemory flushCaches. ObjectMemory sendTraceOn.]
- onExit:[:con :val | ObjectMemory sendTraceOff.]
-
- "Modified: / 31.7.1998 / 16:40:07 / cg"
-!
-
-traceMethodEntry:aMethod
- "arrange for a trace message to be output on stdErr,
- when aMethod is executed. Only entry is traced.
- Use unwrapMethod to remove this."
-
- ^ self traceMethodEntry:aMethod on:Stderr
+
+ | selector class trapMethod spec src dict sel saveUS xselector|
+
+ CallingLevel := 0.
"
- MessageTracer traceMethodEntry:(Integer compiledMethodAt:#factorial).
- 5 factorial.
- MessageTracer untraceMethod:(Integer compiledMethodAt:#factorial)
- "
- "
- MessageTracer traceMethodEntry:(Integer compiledMethodAt:#factorialR).
- 5 factorialR.
- MessageTracer untraceMethod:(Integer compiledMethodAt:#factorialR)
- "
- "
- MessageTracer traceMethodEntry:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:).
- #(6 1 9 66 2 17) copy sort.
- MessageTracer untraceMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:).
- "
-!
-
-traceMethodEntry:aMethod on:aStream
- "arrange for a trace message to be output on aStream,
- when aMethod is executed. Only entry is traced.
- Use unwrapMethod to remove this."
-
- |lvl inside|
-
- ^ self wrapMethod:aMethod
- onEntry:[:con |
- inside isNil ifTrue:[
- inside := true.
- CallingLevel isNil ifTrue:[
- CallingLevel := 0.
- ].
- lvl notNil ifTrue:[
- lvl := lvl + 1
- ] ifFalse:[
- CallingLevel := lvl := CallingLevel + 1.
- ].
- MessageTracer printEntryFull:con level:lvl on:aStream.
- inside := nil
- ]
- ]
- onExit:[:con :retVal |]
-
- "
- MessageTracer traceMethodEntry:(Integer compiledMethodAt:#factorial) on:Transcript.
- 5 factorial.
- MessageTracer untraceMethod:(Integer compiledMethodAt:#factorial)
- "
- "
- MessageTracer traceMethodEntry:(Integer compiledMethodAt:#factorialR) on:Transcript.
- 5 factorialR.
- MessageTracer untraceMethod:(Integer compiledMethodAt:#factorialR)
- "
- "
- MessageTracer traceMethodEntry:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:) on:Transcript.
- #(6 1 9 66 2 17) copy sort.
- MessageTracer untraceMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:).
+ create a new method, which calls the original one,
+ but only if not already being trapped.
"
-!
-
-traceMethodFull:aMethod
- "arrange for a full trace message to be output on Stderr, when amethod is executed.
- Only the sender is traced on entry.
- Use untraceMethod to remove this trace."
-
- ^ self traceMethodFull:aMethod on:Stderr
-
- "Created: 15.12.1995 / 18:19:31 / cg"
- "Modified: 22.10.1996 / 17:39:28 / cg"
-!
-
-traceMethodFull:aMethod on:aStream
- "arrange for a full trace message to be output on Stderr, when aMethod is executed.
- Only the sender is traced on entry.
- Use untraceMethod to remove this trace."
-
- ^ self
- wrapMethod:aMethod
- onEntry:(self traceFullBlockFor:aStream)
- onExit:LeaveTraceBlock.
-
- "Created: 15.12.1995 / 18:19:31 / cg"
- "Modified: 22.10.1996 / 17:39:28 / cg"
-!
-
-traceMethodSender:aMethod
- "arrange for a trace message to be output on Stderr,
- when amethod is executed.
- Only the sender is traced on entry.
- Use untraceMethod to remove this trace."
-
- ^ self traceMethodSender:aMethod on:Stderr
-!
-
-traceMethodSender:aMethod on:aStream
- "arrange for a trace message to be output on Stderr, when amethod is executed.
- Only the sender is traced on entry.
- Use untraceMethod to remove this trace."
-
- ^ self
- wrapMethod:aMethod
- onEntry:(self traceSenderBlockFor:aStream)
- onExit:LeaveTraceBlock.
-
- "Modified: 22.10.1996 / 17:39:33 / cg"
-!
-
-traceUpdateMethod:aMethod on:aStream
- "arrange for a trace message to be output on aStream,
- when aMethod is executed.
- Traces both entry and exit.
- Use unwrapMethod to remove this.
- This one is specialized for change-update calling i.e. it traces from the update
- back to the origial change message."
-
- |lvl inside|
-
- ^ self
- wrapMethod:aMethod
- onEntry:[:con |
- inside isNil ifTrue:[
- inside := true.
- CallingLevel isNil ifTrue:[
- CallingLevel := 0.
- ].
- lvl notNil ifTrue:[
- lvl := lvl + 1
- ] ifFalse:[
- CallingLevel := lvl := CallingLevel + 1.
- ].
- MessageTracer printUpdateEntryFull:con level:lvl on:aStream.
- inside := nil
- ]
- ]
- onExit:[:con :retVal |
- inside isNil ifTrue:[
- inside := true.
- MessageTracer printExit:con with:retVal level:lvl on:aStream.
- CallingLevel := lvl := lvl - 1.
- inside := nil
- ]
- ]
-!
-
-tracelogMethod:aMethod
- "arrange for a trace log entry to be appended to a standard log using
- Logger, when aMethod is executed. Traces both entry and exit.
- Use unwrapMethod to remove this."
-
- |lvl inside|
-
- ^ self wrapMethod:aMethod
- onEntry:[:con |
- | msg |
- inside isNil ifTrue:[
- inside := true.
- CallingLevel isNil ifTrue:[
- CallingLevel := 0.
- ].
- lvl notNil ifTrue:[
- lvl := lvl + 1
- ] ifFalse:[
- CallingLevel := lvl := CallingLevel + 1.
- ].
- msg := String streamContents:[:s|MessageTracer printEntryFull:con level:lvl on:s].
- Logger log: msg severity: #trace attachment: con args.
- inside := nil
- ]
- ]
- onExit:[:con :retVal |
- | msg |
- inside isNil ifTrue:[
- inside := true.
- msg := String streamContents:[:s|MessageTracer printExit:con with:retVal level:lvl on:s].
- Logger log: msg severity: #trace attachment: retVal.
- CallingLevel := lvl := lvl - 1.
- inside := nil
- ]
- ]
-
- "
- MessageTracer traceMethod:(Integer compiledMethodAt:#factorial) on:Transcript.
- 5 factorial.
- MessageTracer untraceMethod:(Integer compiledMethodAt:#factorial)
- "
- "
- MessageTracer traceMethod:(Integer compiledMethodAt:#factorialR) on:Transcript.
- 5 factorialR.
- MessageTracer untraceMethod:(Integer compiledMethodAt:#factorialR)
- "
- "
- MessageTracer traceMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:) on:Transcript.
- #(6 1 9 66 2 17) copy sort.
- MessageTracer untraceMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:).
- "
-
- "Created: / 15-03-2013 / 11:04:20 / Jan Vrany <jan.vrany@fit.cvut.cz>"
-!
-
-untraceMethod:aMethod
- "remove tracing of aMethod"
-
- "just a rename for your convenience - the same basic mechanism is used for all of these
- trace facilities ..."
-
- ^ self unwrapMethod:aMethod
-! !
-
-!MessageTracer class methodsFor:'method wrapping'!
-
-unwrapAllMethods
- "just in case you dont know what methods have break/trace-points
- on them; this removes them all"
-
- WrappedMethod allInstancesDo:[:aWrapperMethod |
- aWrapperMethod unregister.
- self unwrapMethod:aWrapperMethod.
- ]
-
- "
- MessageTracer unwrapAllMethods
- "
-
- "Modified: / 01-07-2011 / 10:02:47 / cg"
-!
-
-unwrapMethod:aMethod
- "remove any wrapper on aMethod"
-
- |selector class originalMethod dict mthd|
-
- aMethod isWrapped ifTrue:[
- originalMethod := aMethod originalMethod.
+ (method isNil or:[method isWrapped]) ifTrue:[
+ ^ method
].
-
- MethodCounts notNil ifTrue:[
- aMethod isWrapped ifTrue:[
- MethodCounts removeKey:originalMethod ifAbsent:nil.
- ].
- MethodCounts removeKey:aMethod ifAbsent:nil.
- MethodCounts := MethodCounts asNilIfEmpty.
- ].
- MethodMemoryUsage notNil ifTrue:[
- aMethod isWrapped ifTrue:[
- MethodMemoryUsage removeKey:originalMethod ifAbsent:nil.
- ].
- MethodMemoryUsage removeKey:aMethod ifAbsent:nil.
- MethodMemoryUsage := MethodMemoryUsage asNilIfEmpty.
- ].
- MethodTiming notNil ifTrue:[
- aMethod isWrapped ifTrue:[
- MethodTiming removeKey:originalMethod ifAbsent:nil.
- ].
- MethodTiming removeKey:aMethod ifAbsent:nil.
- MethodTiming := MethodTiming asNilIfEmpty.
- ].
-
- CallingLevel := 0.
-
- (aMethod isNil or:[aMethod isWrapped not]) ifTrue:[
- ^ aMethod
+ method isLazyMethod ifTrue:[
+ method makeRealMethod
].
"
get class/selector
"
- class := aMethod containingClass.
+ class := method containingClass.
class isNil ifTrue:[
- 'MessageTracer [info]: no containing class for method found' infoPrintCR.
- ^ aMethod
+ self error:'cannot place trap (no containing class found)' mayProceed:true.
+ ^ method
+ ].
+ selector := class selectorAtMethod:method.
+
+ WrappedMethod autoload. "/ for small systems
+
+ "
+ get a new method-spec
+ "
+ xselector := '_x'.
+ method numArgs timesRepeat:[
+ xselector := xselector , '_:'
+ ].
+ spec := Parser methodSpecificationForSelector:xselector.
+
+ "
+ create a method, executing the trap-blocks and the original method via a direct call
+ "
+ src := '%(spec)
+
+ <context: #return>
+ | currentProcess mock mockedVal context args marker |
+
+ context := thisContext.
+ currentProcess := Processor activeProcess.
+ mock := false.
+ marker := #mockedMethodMarker yourself.
+
+ [ mock not and:[currentProcess notNil] ] whileTrue:[
+ mock := currentProcess id = %(pid).
+ currentProcess := ProcessorScheduler knownProcesses detect:[:p | p id = currentProcess creatorId ] ifNone:[ nil ].
+ ].
+ mock ifTrue:[
+ mockedVal := #replacementBlock yourself valueWithOptionalArguments: (((Array with: context receiver) , (context args)) copyWith: #originalMethod)
+ ] ifFalse:[
+ mockedVal := #originalMethod yourself
+ valueWithReceiver:(context receiver)
+ arguments:(context args)
+ selector:(context selector)
+ search:(context searchClass)
+ sender:nil.
].
- selector := class selectorAtMethod:aMethod.
-
- originalMethod isNil ifTrue:[
- self error:'oops, could not find original method' mayProceed:true.
- ^ aMethod
+ ^ mockedVal'.
+
+ src := src expandPlaceholdersWith:
+ (Dictionary new
+ at: 'spec' put: spec;
+ at: 'pid' put: Processor activeProcess id;
+ yourself).
+
+ saveUS := Compiler allowUnderscoreInIdentifier.
+ ParserFlags
+ withSTCCompilation:#never
+ do:[
+ [
+ Compiler allowUnderscoreInIdentifier:true.
+ Class withoutUpdatingChangesDo:[
+ trapMethod := Compiler
+ compile:src
+ forClass:UndefinedObject
+ inCategory:method category
+ notifying:nil
+ install:false
+ skipIfSame:false
+ silent:false. "/ true.
+ ]
+ ] ensure:[
+ Compiler allowUnderscoreInIdentifier:saveUS.
+ ].
+ ].
+
+ trapMethod setPackage:method package.
+ trapMethod changeClassTo:WrappedMethod.
+ trapMethod register.
+
+ "
+ raising our eyebrows here ...
+ "
+ block notNil ifTrue:[
+ trapMethod changeLiteral:#replacementBlock to: block.
].
+ trapMethod changeLiteral:#originalMethod to:method.
+ trapMethod changeLiteral:#mockedMethodMarker to: MockedMethodMarker.
+
+ "
+ change the source of this new method
+ (to avoid confusion in the debugger ...)
+ "
+ trapMethod source: src.
+"/ trapMethod sourceFilename:(method getSource) position:(method getSourcePosition).
dict := class methodDictionary.
- mthd := dict at:selector ifAbsent:nil.
- mthd notNil ifTrue:[
- dict at:selector put:originalMethod.
- class methodDictionary:dict.
- ] ifFalse:[
- 'MessageTracer [info]: no containing class for method found' infoPrintCR.
-"/ self halt:'oops, unexpected error - cannot remove wrap'.
- aMethod becomeSameAs:originalMethod.
- ^ aMethod
+ sel := dict at:selector ifAbsent:[0].
+ sel == 0 ifTrue:[
+ self error:'oops, unexpected error' mayProceed:true.
+ ^ method
].
+ dict at:selector put:trapMethod.
+ class methodDictionary:dict.
ObjectMemory flushCaches.
class changed:#methodTrap with:selector. "/ tell browsers
- MethodTrapChangeNotificationParameter notNil ifTrue:[
+ MethodTrapChangeNotificationParameter notNil ifTrue:[
Smalltalk changed:#methodTrap with:(MethodTrapChangeNotificationParameter changeClass:class changeSelector:selector).
].
- ^ originalMethod
-
- "Modified: / 05-06-1996 / 14:08:08 / stefan"
- "Modified: / 04-10-2007 / 16:41:01 / cg"
+ ^ trapMethod
+
+ "
+ MessageTracer
+ mockMethod:(Color class compiledMethodAt:#magenta)
+ do: [ :color |
+ Color red
+ ].
+ Color magenta.
+ [ [ Color magenta inspect ] fork. Delay waitForSeconds: 1. ] fork.
+ (Color class compiledMethodAt:#magenta) isMocked.
+ MessageTracer unwrapMethod:(Color class compiledMethodAt:#magenta).
+ Color magenta.
+ "
+
+ "Created: / 29-07-2014 / 09:44:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 18-02-2015 / 15:25:23 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
-wrapMethod:aMethod onEntry:entryBlock onExit:exitBlock
- ^ self wrapMethod:aMethod onEntry:entryBlock onExit:exitBlock onUnwind:nil
-
- "Modified: 18.12.1995 / 15:58:12 / stefan"
+unmock: selector in: class
+ | method |
+
+ method := class compiledMethodAt: selector ifAbsent: [ self error:'No such mnethod' ].
+ ^ self unmockMethod: method
+
+ "Created: / 29-07-2014 / 10:02:58 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
-wrapMethod:aMethod onEntry:entryBlock onExit:exitBlock onUnwind:unwindBlock
- "arrange for the two blocks entryBlock and exitBlock to be evaluated whenever
- aMethod is evaluated.
- EntryBlock will be called on entry, and gets the current context passed as argument.
- ExitBlock will be called, when the method is left, and gets the context and
- the methods return value as arguments.
- UnwindBlock will be called when the contxt of aMethod is unwound.
- If there is an unwindBlock, the entry and exitBlocks will be called within the unwind block,
- because allocating the unwindBlock uses memory and some users want to count allocated memory.
+unmockAllMethods
+ "Remove mocking wrapper from all methods, unconditionally.
+ May (should) be called in tearDdown of each testcase that
+ uses method mocking"
+
+ WrappedMethod allInstancesDo:[:method |
+ method isMocked ifTrue:[
+ method unregister.
+ self unwrapMethod: method.
+ ]
+ ]
+
+ "Created: / 29-07-2014 / 10:12:48 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+unmockMethod: method
+ "Remove mocking wrapper from a method, if it has been mocked by
+ #mockMethod:do:"
+
+ method isMocked ifTrue:[
+ self unwrapMethod: method
+ ].
+
+ "Created: / 29-07-2014 / 09:45:54 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!MessageTracer class methodsFor:'method profiling'!
+
+spyMethod:aMethod
+ "arrange for given method to collect profiling data
+ using message tally profiler.
+ Use unwrapMethod to remove this.
"
- |selector class trapMethod s spec src dict sel saveUS xselector|
+ self spyMethod: aMethod interval: MessageTally normalSamplingIntervalMS
+
+ "Created: / 01-02-2015 / 09:02:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+spyMethod:aMethod interval: anInteger
+ "arrange for given method to collect profiling data
+ using message tally profiler.
+ Use unwrapMethod to remove this.
+ "
+
+ |selector class trapMethod s spec src dict sel saveUS xselector info |
CallingLevel := 0.
@@ -1774,6 +1450,8 @@
].
spec := Parser methodSpecificationForSelector:xselector.
+
+ info := MethodSpyInfo new.
"
create a method, executing the trap-blocks and the original method via a direct call
"
@@ -1782,38 +1460,28 @@
s nextPutAll:' <context: #return>'.
s nextPutAll:' |retVal context| '.
s nextPutAll:' context := thisContext.'.
- unwindBlock notNil ifTrue:[
- s nextPutAll:'['.
- ].
- entryBlock notNil ifTrue:[
- s nextPutAll:'#entryBlock yourself value:context. '.
- ].
- s nextPutAll:'retVal := #originalMethod yourself';
- nextPutAll: ' valueWithReceiver:(context receiver)';
+ s nextPutAll: '#info profiler: (Tools::Profiler ? MessageTally) new.';
+ nextPutAll: '#info profiler spyOn: [';
+ nextPutAll:'retVal := #originalMethod yourself';
+ nextPutAll: ' valueWithReceiver:(context receiver)';
nextPutAll: ' arguments:(context args)';
- nextPutAll: ' selector:(context selector)';
+ nextPutAll: ' selector:(context selector)';
nextPutAll: ' search:(context searchClass)';
- nextPutAll: ' sender:nil. '.
-
- exitBlock notNil ifTrue:[
- s nextPutAll:'#exitBlock yourself value:context value:retVal.'.
- ].
- unwindBlock notNil ifTrue:[
- s nextPutAll:'] ifCurtailed:#unwindBlock yourself.'.
- ].
+ nextPutAll: ' sender:nil. ';
+ nextPutAll:'] interval:'; nextPutAll: anInteger printString; nextPutAll: '.'.
s nextPutAll:'^ retVal'; cr.
src := s contents.
saveUS := Compiler allowUnderscoreInIdentifier.
- ParserFlags
- withSTCCompilation:#never
+ ParserFlags
+ withSTCCompilation:#never
do:[
[
Compiler allowUnderscoreInIdentifier:true.
Class withoutUpdatingChangesDo:[
- trapMethod := Compiler
- compile:src
- forClass:UndefinedObject
+ trapMethod := Compiler
+ compile:src
+ forClass:UndefinedObject
inCategory:aMethod category
notifying:nil
install:false
@@ -1832,16 +1500,8 @@
"
raising our eyebrows here ...
"
- entryBlock notNil ifTrue:[
- trapMethod changeLiteral:#entryBlock to:entryBlock.
- ].
+ trapMethod changeLiteral:#info to: info.
trapMethod changeLiteral:#originalMethod to:aMethod.
- exitBlock notNil ifTrue:[
- trapMethod changeLiteral:#exitBlock to:exitBlock.
- ].
- unwindBlock notNil ifTrue:[
- trapMethod changeLiteral:#unwindBlock to:unwindBlock.
- ].
"
change the source of this new method
(to avoid confusion in the debugger ...)
@@ -1861,27 +1521,27 @@
ObjectMemory flushCaches.
class changed:#methodTrap with:selector. "/ tell browsers
- MethodTrapChangeNotificationParameter notNil ifTrue:[
+ MethodTrapChangeNotificationParameter notNil ifTrue:[
Smalltalk changed:#methodTrap with:(MethodTrapChangeNotificationParameter changeClass:class changeSelector:selector).
].
^ trapMethod
"
- MessageTracer
- wrapMethod:(Point compiledMethodAt:#scaleBy:)
+ MessageTracer
+ wrapMethod:(Point compiledMethodAt:#scaleBy:)
onEntry:nil
onExit:[:con :retVal |
Transcript show:'leave Point>>scaleBy:; returning:'.
Transcript showCR:retVal printString.
Transcript endEntry
].
- (1@2) scaleBy:5.
- MessageTracer unwrapMethod:(Point compiledMethodAt:#scaleBy:).
- (1@2) scaleBy:5.
+ (1@2) scaleBy:5.
+ MessageTracer unwrapMethod:(Point compiledMethodAt:#scaleBy:).
+ (1@2) scaleBy:5.
"
"
- MessageTracer
- wrapMethod:(Integer compiledMethodAt:#factorial)
+ MessageTracer
+ wrapMethod:(Integer compiledMethodAt:#factorial)
onEntry:[:con |
Transcript showCR:('entering ' , con receiver printString , '>>factorial').
]
@@ -1891,17 +1551,17 @@
Transcript endEntry
].
Transcript showCR:'5 factorial traced'.
- 5 factorial.
- MessageTracer unwrapMethod:(Integer compiledMethodAt:#factorial).
+ 5 factorial.
+ MessageTracer unwrapMethod:(Integer compiledMethodAt:#factorial).
Transcript showCR:'5 factorial normal'.
- 5 factorial.
+ 5 factorial.
"
"
|lvl|
lvl := 0.
- MessageTracer
- wrapMethod:(Integer compiledMethodAt:#factorial)
+ MessageTracer
+ wrapMethod:(Integer compiledMethodAt:#factorial)
onEntry:[:con |
Transcript spaces:lvl. lvl := lvl + 2.
Transcript showCR:('entering ' , con receiver printString , '>>factorial').
@@ -1913,10 +1573,763 @@
Transcript endEntry
].
Transcript showCR:'5 factorial traced'.
- 5 factorial.
- MessageTracer unwrapMethod:(Integer compiledMethodAt:#factorial).
+ 5 factorial.
+ MessageTracer unwrapMethod:(Integer compiledMethodAt:#factorial).
Transcript showCR:'5 factorial normal'.
- 5 factorial.
+ 5 factorial.
+ "
+
+ "Created: / 01-02-2015 / 09:22:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!MessageTracer class methodsFor:'method timing'!
+
+executionTimesOfMethod:aMethod
+ "return the current gathered execution time statistics"
+
+ |info|
+
+ MethodTiming notNil ifTrue:[
+ aMethod isWrapped ifTrue:[
+ info := ( MethodTiming at:(aMethod originalMethod) ifAbsent:nil ) copy.
+ ].
+ ].
+
+ info isNil ifTrue:[ info := MethodTimingInfo new ].
+ ^ info
+
+ "Created: / 17-06-1996 / 17:07:30 / cg"
+ "Modified: / 05-03-2007 / 15:46:17 / cg"
+!
+
+resetExecutionTimesOfMethod:aMethod
+ "reset the gathered execution times statistics for aMethod;
+ the method remains wrapped."
+
+ MethodTiming notNil ifTrue:[
+ MethodTiming removeKey:aMethod.
+ aMethod isWrapped ifTrue:[
+ MethodTiming removeKey:aMethod originalMethod.
+ ].
+ ].
+
+ "Created: / 30-07-1998 / 17:12:35 / cg"
+ "Modified: / 05-03-2007 / 15:36:59 / cg"
+!
+
+stopTimingMethod:aMethod
+ "remove timing of aMethod"
+
+ ^ self unwrapMethod:aMethod
+
+ "Modified: 15.12.1995 / 15:43:53 / cg"
+ "Created: 17.6.1996 / 17:04:03 / cg"
+!
+
+timeMethod:aMethod
+ "arrange for a aMethod's execution time to be measured.
+ Use unwrapMethod: or stopTimingMethod: to remove this."
+
+ |t0|
+
+ MethodTiming isNil ifTrue:[
+ MethodTiming := IdentityDictionary new.
+ ].
+ MethodTiming removeKey:aMethod ifAbsent:nil.
+
+ TimeForWrappers isNil ifTrue:[
+ self getTimeForWrappers
+ ].
+
+ ^ self wrapMethod:aMethod
+ onEntry:[:con |
+ t0 := OperatingSystem getMicrosecondTime.
+ ]
+ onExit:[:con :retVal |
+ |info t cnt minT maxT sumTimes|
+
+ t := OperatingSystem getMicrosecondTime - t0.
+ t := t - TimeForWrappers.
+ t < 0 ifTrue:[t := 0].
+ t := t / 1000.0.
+
+ MethodTiming isNil ifTrue:[
+ MethodTiming := IdentityDictionary new.
+ ].
+ info := MethodTiming at:aMethod ifAbsent:nil.
+ info isNil ifTrue:[
+ MethodTiming at:aMethod put:(info := MethodTimingInfo new)
+ ] ifFalse:[
+ info rememberExecutionTime:t.
+ ].
+ MessageTracer changed:#statistics: with:aMethod.
+ aMethod changed:#statistics.
+ retVal
+ ]
+
+ "
+ MessageTracer timeMethod:(Integer compiledMethodAt:#factorial).
+ 5 factorial.
+ 5 factorial.
+ 5 factorial.
+ (MessageTracer executionTimesOfMethod:(Integer compiledMethodAt:#factorial)) printCR.
+ MessageTracer stopTimingMethod:(Integer compiledMethodAt:#factorial)
+ "
+
+ "Created: / 17-06-1996 / 17:03:50 / cg"
+ "Modified: / 05-03-2007 / 15:34:01 / cg"
+! !
+
+!MessageTracer class methodsFor:'method tracing'!
+
+traceClass:aClass selector:aSelector
+ "arrange for a trace message to be output on Stderr, when a message with aSelector is
+ sent to instances of aClass (or subclass instances). Use untraceClass to remove this."
+
+ self traceClass:aClass selector:aSelector on:Stderr
+
+ "
+ MessageTracer traceClass:Integer selector:#factorial.
+ 5 factorial.
+ MessageTracer untraceClass:Integer
+ "
+ "
+ MessageTracer traceClass:SequenceableCollection selector:#quickSortFrom:to:.
+ #(6 1 9 66 2 17) copy sort.
+ MessageTracer untraceClass:SequenceableCollection
+ "
+ "
+ MessageTracer traceClass:Array selector:#at:.
+ MessageTracer traceClass:Array selector:#at:put:.
+ #(6 1 9 66 2 17) copy sort.
+ MessageTracer untraceClass:Array
+ "
+!
+
+traceClass:aClass selector:aSelector on:aStream
+ "arrange for a trace message to be output on aStream, when a message with aSelector is
+ sent to instances of aClass (or subclass instances). Use untraceClass to remove this."
+
+ self traceMethod:(aClass compiledMethodAt:aSelector) on:aStream
+
+ "
+ MessageTracer traceClass:Integer selector:#factorial on:Transcript.
+ 5 factorial.
+ MessageTracer untraceClass:Integer
+ "
+ "
+ MessageTracer traceClass:Integer selector:#factorialR on:Transcript.
+ 5 factorialR.
+ MessageTracer untraceClass:Integer
+ "
+
+!
+
+traceMethod:aMethod
+ "arrange for a trace message to be output on Stderr,
+ when aMethod is executed. Traces both entry and exit.
+ Use unwrapMethod to remove this."
+
+ ^ self traceMethod:aMethod on:Stderr
+
+ "
+ MessageTracer traceMethod:(Integer compiledMethodAt:#factorial).
+ 5 factorial.
+ MessageTracer untraceMethod:(Integer compiledMethodAt:#factorial)
+ "
+ "
+ MessageTracer traceMethod:(Integer compiledMethodAt:#factorialR).
+ 5 factorialR.
+ MessageTracer untraceMethod:(Integer compiledMethodAt:#factorialR)
+ "
+ "
+ MessageTracer traceMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:).
+ #(6 1 9 66 2 17) copy sort.
+ MessageTracer untraceMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:).
+ "
+ "
+ dont do this:
+ "
+ "
+ MessageTracer traceMethod:(Object compiledMethodAt:#at:).
+ MessageTracer traceMethod:(Object compiledMethodAt:#at:put:).
+ #(6 1 9 66 2 17) copy sort.
+ MessageTracer untraceMethod:(Object compiledMethodAt:#at:).
+ MessageTracer untraceMethod:(Object compiledMethodAt:#at:put:).
+ "
+!
+
+traceMethod:aMethod on:aStream
+ "arrange for a trace message to be output on aStream,
+ when aMethod is executed. Traces both entry and exit.
+ Use unwrapMethod to remove this."
+
+ |lvl inside|
+
+ ^ self wrapMethod:aMethod
+ onEntry:[:con |
+ inside isNil ifTrue:[
+ inside := true.
+ CallingLevel isNil ifTrue:[
+ CallingLevel := 0.
+ ].
+ lvl notNil ifTrue:[
+ lvl := lvl + 1
+ ] ifFalse:[
+ CallingLevel := lvl := CallingLevel + 1.
+ ].
+ MessageTracer printEntryFull:con level:lvl on:aStream.
+ inside := nil
+ ]
+ ]
+ onExit:[:con :retVal |
+ inside isNil ifTrue:[
+ inside := true.
+ MessageTracer printExit:con with:retVal level:lvl on:aStream.
+ CallingLevel := lvl := lvl - 1.
+ inside := nil
+ ].
+ retVal
+ ]
+
+ "
+ MessageTracer traceMethod:(Integer compiledMethodAt:#factorial) on:Transcript.
+ 5 factorial.
+ MessageTracer untraceMethod:(Integer compiledMethodAt:#factorial)
+ "
+ "
+ MessageTracer traceMethod:(Integer compiledMethodAt:#factorialR) on:Transcript.
+ 5 factorialR.
+ MessageTracer untraceMethod:(Integer compiledMethodAt:#factorialR)
+ "
+ "
+ MessageTracer traceMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:) on:Transcript.
+ #(6 1 9 66 2 17) copy sort.
+ MessageTracer untraceMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:).
+ "
+!
+
+traceMethodAll:aMethod
+ "arrange for a full trace message to be output on Stderr, when aMethod is executed.
+ Only the sender is traced on entry.
+ Use untraceMethod to remove this trace.
+ This is for system debugging only;
+ The trace output is a low level trace generated in the VM."
+
+ ^ self wrapMethod:aMethod
+ onEntry:[:con | ObjectMemory flushCaches. ObjectMemory sendTraceOn.]
+ onExit:[:con :retVal | ObjectMemory sendTraceOff. retVal]
+
+ "Modified: / 31.7.1998 / 16:40:07 / cg"
+!
+
+traceMethodEntry:aMethod
+ "arrange for a trace message to be output on stdErr,
+ when aMethod is executed. Only entry is traced.
+ Use unwrapMethod to remove this."
+
+ ^ self traceMethodEntry:aMethod on:Stderr
+
+ "
+ MessageTracer traceMethodEntry:(Integer compiledMethodAt:#factorial).
+ 5 factorial.
+ MessageTracer untraceMethod:(Integer compiledMethodAt:#factorial)
+ "
+ "
+ MessageTracer traceMethodEntry:(Integer compiledMethodAt:#factorialR).
+ 5 factorialR.
+ MessageTracer untraceMethod:(Integer compiledMethodAt:#factorialR)
+ "
+ "
+ MessageTracer traceMethodEntry:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:).
+ #(6 1 9 66 2 17) copy sort.
+ MessageTracer untraceMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:).
+ "
+!
+
+traceMethodEntry:aMethod on:aStream
+ "arrange for a trace message to be output on aStream,
+ when aMethod is executed. Only entry is traced.
+ Use unwrapMethod to remove this."
+
+ |lvl inside|
+
+ ^ self wrapMethod:aMethod
+ onEntry:[:con |
+ inside isNil ifTrue:[
+ inside := true.
+ CallingLevel isNil ifTrue:[
+ CallingLevel := 0.
+ ].
+ lvl notNil ifTrue:[
+ lvl := lvl + 1
+ ] ifFalse:[
+ CallingLevel := lvl := CallingLevel + 1.
+ ].
+ MessageTracer printEntryFull:con level:lvl on:aStream.
+ inside := nil
+ ]
+ ]
+ onExit:nil
+
+ "
+ MessageTracer traceMethodEntry:(Integer compiledMethodAt:#factorial) on:Transcript.
+ 5 factorial.
+ MessageTracer untraceMethod:(Integer compiledMethodAt:#factorial)
+ "
+ "
+ MessageTracer traceMethodEntry:(Integer compiledMethodAt:#factorialR) on:Transcript.
+ 5 factorialR.
+ MessageTracer untraceMethod:(Integer compiledMethodAt:#factorialR)
+ "
+ "
+ MessageTracer traceMethodEntry:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:) on:Transcript.
+ #(6 1 9 66 2 17) copy sort.
+ MessageTracer untraceMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:).
+ "
+!
+
+traceMethodFull:aMethod
+ "arrange for a full trace message to be output on Stderr, when amethod is executed.
+ Only the sender is traced on entry.
+ Use untraceMethod to remove this trace."
+
+ ^ self traceMethodFull:aMethod on:Stderr
+
+ "Created: 15.12.1995 / 18:19:31 / cg"
+ "Modified: 22.10.1996 / 17:39:28 / cg"
+!
+
+traceMethodFull:aMethod on:aStream
+ "arrange for a full trace message to be output on Stderr, when aMethod is executed.
+ Only the sender is traced on entry.
+ Use untraceMethod to remove this trace."
+
+ ^ self
+ wrapMethod:aMethod
+ onEntry:(self traceFullBlockFor:aStream)
+ onExit:LeaveTraceBlock.
+
+ "Created: 15.12.1995 / 18:19:31 / cg"
+ "Modified: 22.10.1996 / 17:39:28 / cg"
+!
+
+traceMethodSender:aMethod
+ "arrange for a trace message to be output on Stderr,
+ when amethod is executed.
+ Only the sender is traced on entry.
+ Use untraceMethod to remove this trace."
+
+ ^ self traceMethodSender:aMethod on:Stderr
+!
+
+traceMethodSender:aMethod on:aStream
+ "arrange for a trace message to be output on Stderr, when amethod is executed.
+ Only the sender is traced on entry.
+ Use untraceMethod to remove this trace."
+
+ ^ self
+ wrapMethod:aMethod
+ onEntry:(self traceSenderBlockFor:aStream)
+ onExit:LeaveTraceBlock.
+
+ "Modified: 22.10.1996 / 17:39:33 / cg"
+!
+
+traceUpdateMethod:aMethod on:aStream
+ "arrange for a trace message to be output on aStream,
+ when aMethod is executed.
+ Traces both entry and exit.
+ Use unwrapMethod to remove this.
+ This one is specialized for change-update calling i.e. it traces from the update
+ back to the origial change message."
+
+ |lvl inside|
+
+ ^ self
+ wrapMethod:aMethod
+ onEntry:[:con |
+ inside isNil ifTrue:[
+ inside := true.
+ CallingLevel isNil ifTrue:[
+ CallingLevel := 0.
+ ].
+ lvl notNil ifTrue:[
+ lvl := lvl + 1
+ ] ifFalse:[
+ CallingLevel := lvl := CallingLevel + 1.
+ ].
+ MessageTracer printUpdateEntryFull:con level:lvl on:aStream.
+ inside := nil
+ ]
+ ]
+ onExit:[:con :retVal |
+ inside isNil ifTrue:[
+ inside := true.
+ MessageTracer printExit:con with:retVal level:lvl on:aStream.
+ CallingLevel := lvl := lvl - 1.
+ inside := nil
+ ].
+ retVal
+ ]
+!
+
+tracelogMethod:aMethod
+ "arrange for a trace log entry to be appended to a standard log using
+ Logger, when aMethod is executed. Traces both entry and exit.
+ Use unwrapMethod to remove this."
+
+ |lvl inside|
+
+ ^ self wrapMethod:aMethod
+ onEntry:[:con |
+ | msg |
+ inside isNil ifTrue:[
+ inside := true.
+ CallingLevel isNil ifTrue:[
+ CallingLevel := 0.
+ ].
+ lvl notNil ifTrue:[
+ lvl := lvl + 1
+ ] ifFalse:[
+ CallingLevel := lvl := CallingLevel + 1.
+ ].
+ msg := String streamContents:[:s|MessageTracer printEntryFull:con level:lvl on:s].
+ Logger log: msg severity: Logger severityENTER attachment: con args.
+ inside := nil
+ ]
+ ]
+ onExit:[:con :retVal |
+ | msg |
+ inside isNil ifTrue:[
+ inside := true.
+ msg := String streamContents:[:s|MessageTracer printExit:con with:retVal level:lvl on:s].
+ Logger log: msg severity: Logger severityLEAVE attachment: retVal.
+ CallingLevel := lvl := lvl - 1.
+ inside := nil
+ ].
+ retVal
+ ]
+
+ "
+ MessageTracer traceMethod:(Integer compiledMethodAt:#factorial) on:Transcript.
+ 5 factorial.
+ MessageTracer untraceMethod:(Integer compiledMethodAt:#factorial)
+ "
+ "
+ MessageTracer traceMethod:(Integer compiledMethodAt:#factorialR) on:Transcript.
+ 5 factorialR.
+ MessageTracer untraceMethod:(Integer compiledMethodAt:#factorialR)
+ "
+ "
+ MessageTracer traceMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:) on:Transcript.
+ #(6 1 9 66 2 17) copy sort.
+ MessageTracer untraceMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:).
+ "
+
+ "Created: / 15-03-2013 / 11:04:20 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 03-10-2014 / 15:00:45 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+untraceMethod:aMethod
+ "remove tracing of aMethod"
+
+ "just a rename for your convenience - the same basic mechanism is used for all of these
+ trace facilities ..."
+
+ ^ self unwrapMethod:aMethod
+! !
+
+!MessageTracer class methodsFor:'method wrapping'!
+
+unwrapAllMethods
+ "just in case you dont know what methods have break/trace-points
+ on them; this removes them all"
+
+ WrappedMethod allInstancesDo:[:aWrapperMethod |
+ aWrapperMethod unregister.
+ self unwrapMethod:aWrapperMethod.
+ ]
+
+ "
+ MessageTracer unwrapAllMethods
+ "
+
+ "Modified: / 01-07-2011 / 10:02:47 / cg"
+!
+
+unwrapMethod:aMethod
+ "remove any wrapper on aMethod"
+
+ |selector class originalMethod dict mthd|
+
+ aMethod isWrapped ifTrue:[
+ originalMethod := aMethod originalMethod.
+ ].
+
+ MethodCounts notNil ifTrue:[
+ aMethod isWrapped ifTrue:[
+ MethodCounts removeKey:originalMethod ifAbsent:nil.
+ ].
+ MethodCounts removeKey:aMethod ifAbsent:nil.
+ MethodCounts := MethodCounts asNilIfEmpty.
+ ].
+ MethodMemoryUsage notNil ifTrue:[
+ aMethod isWrapped ifTrue:[
+ MethodMemoryUsage removeKey:originalMethod ifAbsent:nil.
+ ].
+ MethodMemoryUsage removeKey:aMethod ifAbsent:nil.
+ MethodMemoryUsage := MethodMemoryUsage asNilIfEmpty.
+ ].
+ MethodTiming notNil ifTrue:[
+ aMethod isWrapped ifTrue:[
+ MethodTiming removeKey:originalMethod ifAbsent:nil.
+ ].
+ MethodTiming removeKey:aMethod ifAbsent:nil.
+ MethodTiming := MethodTiming asNilIfEmpty.
+ ].
+
+ CallingLevel := 0.
+
+ (aMethod isNil or:[aMethod isWrapped not]) ifTrue:[
+ ^ aMethod
+ ].
+
+ "
+ get class/selector
+ "
+ class := aMethod containingClass.
+ class isNil ifTrue:[
+ 'MessageTracer [info]: no containing class for method found' infoPrintCR.
+ ^ aMethod
+ ].
+ selector := class selectorAtMethod:aMethod.
+
+ originalMethod isNil ifTrue:[
+ self error:'oops, could not find original method' mayProceed:true.
+ ^ aMethod
+ ].
+
+ dict := class methodDictionary.
+ mthd := dict at:selector ifAbsent:nil.
+ mthd notNil ifTrue:[
+ dict at:selector put:originalMethod.
+ class methodDictionary:dict.
+ ] ifFalse:[
+ 'MessageTracer [info]: no containing class for method found' infoPrintCR.
+"/ self halt:'oops, unexpected error - cannot remove wrap'.
+ aMethod becomeSameAs:originalMethod.
+ ^ aMethod
+ ].
+
+ ObjectMemory flushCaches.
+
+ class changed:#methodTrap with:selector. "/ tell browsers
+ MethodTrapChangeNotificationParameter notNil ifTrue:[
+ Smalltalk changed:#methodTrap with:(MethodTrapChangeNotificationParameter changeClass:class changeSelector:selector).
+ ].
+ ^ originalMethod
+
+ "Modified: / 05-06-1996 / 14:08:08 / stefan"
+ "Modified: / 04-10-2007 / 16:41:01 / cg"
+!
+
+wrapMethod:aMethod onEntry:entryBlock onExit:exitBlock
+ ^ self wrapMethod:aMethod onEntry:entryBlock onExit:exitBlock onUnwind:nil
+
+ "Modified: 18.12.1995 / 15:58:12 / stefan"
+!
+
+wrapMethod:aMethod onEntry:entryBlock onExit:exitBlock onUnwind:unwindBlock
+ "arrange for the two blocks entryBlock and exitBlock to be evaluated whenever
+ aMethod is evaluated.
+ EntryBlock will be called on entry, and gets the current context passed as argument.
+ ExitBlock will be called, when the method is left, and gets the context and
+ the methods return value as arguments.
+ UnwindBlock will be called when the contxt of aMethod is unwound.
+ If there is an unwindBlock, the entry and exitBlocks will be called within the unwind block,
+ because allocating the unwindBlock uses memory and some users want to count allocated memory.
+ "
+
+ |selector class trapMethod s spec src dict sel saveUS xselector|
+
+ CallingLevel := 0.
+
+ "
+ create a new method, which calls the original one,
+ but only if not already being trapped.
+ "
+ (aMethod isNil or:[aMethod isWrapped]) ifTrue:[
+ ^ aMethod
+ ].
+ aMethod isLazyMethod ifTrue:[
+ aMethod makeRealMethod
+ ].
+
+ "
+ get class/selector
+ "
+ class := aMethod containingClass.
+ class isNil ifTrue:[
+ self error:'cannot place trap (no containing class found)' mayProceed:true.
+ ^ aMethod
+ ].
+ selector := class selectorAtMethod:aMethod.
+
+ WrappedMethod autoload. "/ for small systems
+
+ "
+ get a new method-spec
+ "
+ xselector := '_x'.
+ aMethod numArgs timesRepeat:[
+ xselector := xselector , '_:'
+ ].
+ spec := Parser methodSpecificationForSelector:xselector.
+
+ "
+ create a method, executing the trap-blocks and the original method via a direct call
+ "
+ s := WriteStream on:String new.
+ s nextPutAll:spec.
+ s nextPutAll:' <context: #return>'.
+ s nextPutAll:' |retVal context| '.
+ s nextPutAll:' context := thisContext.'.
+ unwindBlock notNil ifTrue:[
+ s nextPutAll:'['.
+ ].
+ entryBlock notNil ifTrue:[
+ s nextPutAll:'#entryBlock yourself value:context. '.
+ ].
+ s nextPutAll:'retVal := #originalMethod yourself';
+ nextPutAll: ' valueWithReceiver:(context receiver)';
+ nextPutAll: ' arguments:(context args)';
+ nextPutAll: ' selector:(context selector)';
+ nextPutAll: ' search:(context searchClass)';
+ nextPutAll: ' sender:nil. '.
+
+ exitBlock notNil ifTrue:[
+ s nextPutAll:'^ #exitBlock yourself value:context value:retVal.'.
+ ].
+ unwindBlock notNil ifTrue:[
+ s nextPutAll:'] ifCurtailed:#unwindBlock yourself.'.
+ ].
+ s nextPutAll:'^ retVal'; cr.
+
+ src := s contents.
+ saveUS := Compiler allowUnderscoreInIdentifier.
+ ParserFlags
+ withSTCCompilation:#never
+ do:[
+ [
+ Compiler allowUnderscoreInIdentifier:true.
+ Class withoutUpdatingChangesDo:[
+ trapMethod := Compiler
+ compile:src
+ forClass:UndefinedObject
+ inCategory:aMethod category
+ notifying:nil
+ install:false
+ skipIfSame:false
+ silent:false. "/ true.
+ ]
+ ] ensure:[
+ Compiler allowUnderscoreInIdentifier:saveUS.
+ ].
+ ].
+
+ trapMethod setPackage:aMethod package.
+ trapMethod changeClassTo:WrappedMethod.
+ trapMethod register.
+
+ "
+ raising our eyebrows here ...
+ "
+ entryBlock notNil ifTrue:[
+ trapMethod changeLiteral:#entryBlock to:entryBlock.
+ ].
+ trapMethod changeLiteral:#originalMethod to:aMethod.
+ exitBlock notNil ifTrue:[
+ trapMethod changeLiteral:#exitBlock to:exitBlock.
+ ].
+ unwindBlock notNil ifTrue:[
+ trapMethod changeLiteral:#unwindBlock to:unwindBlock.
+ ].
+ "
+ change the source of this new method
+ (to avoid confusion in the debugger ...)
+ "
+"/ trapMethod source:'this is a wrapper method - not the real one'.
+ trapMethod sourceFilename:(aMethod getSource) position:(aMethod getSourcePosition).
+
+ dict := class methodDictionary.
+ sel := dict at:selector ifAbsent:[0].
+ sel == 0 ifTrue:[
+ self error:'oops, unexpected error' mayProceed:true.
+ ^ aMethod
+ ].
+
+ dict at:selector put:trapMethod.
+ class methodDictionary:dict.
+ ObjectMemory flushCaches.
+
+ class changed:#methodTrap with:selector. "/ tell browsers
+ MethodTrapChangeNotificationParameter notNil ifTrue:[
+ Smalltalk changed:#methodTrap with:(MethodTrapChangeNotificationParameter changeClass:class changeSelector:selector).
+ ].
+ ^ trapMethod
+
+ "
+ MessageTracer
+ wrapMethod:(Point compiledMethodAt:#scaleBy:)
+ onEntry:nil
+ onExit:[:con :retVal |
+ Transcript show:'leave Point>>scaleBy:; returning:'.
+ Transcript showCR:retVal printString.
+ Transcript endEntry
+ ].
+ (1@2) scaleBy:5.
+ MessageTracer unwrapMethod:(Point compiledMethodAt:#scaleBy:).
+ (1@2) scaleBy:5.
+ "
+ "
+ MessageTracer
+ wrapMethod:(Integer compiledMethodAt:#factorial)
+ onEntry:[:con |
+ Transcript showCR:('entering ' , con receiver printString , '>>factorial').
+ ]
+ onExit:[:con :retVal |
+ Transcript show:'leave Integer>>factorial; returning:'.
+ Transcript showCR:retVal printString.
+ Transcript endEntry
+ ].
+ Transcript showCR:'5 factorial traced'.
+ 5 factorial.
+ MessageTracer unwrapMethod:(Integer compiledMethodAt:#factorial).
+ Transcript showCR:'5 factorial normal'.
+ 5 factorial.
+ "
+ "
+ |lvl|
+
+ lvl := 0.
+ MessageTracer
+ wrapMethod:(Integer compiledMethodAt:#factorial)
+ onEntry:[:con |
+ Transcript spaces:lvl. lvl := lvl + 2.
+ Transcript showCR:('entering ' , con receiver printString , '>>factorial').
+ ]
+ onExit:[:con :retVal |
+ lvl := lvl - 2. Transcript spaces:lvl.
+ Transcript show:('leave ' , con receiver printString , '>>factorial; returning:').
+ Transcript showCR:retVal printString.
+ Transcript endEntry
+ ].
+ Transcript showCR:'5 factorial traced'.
+ 5 factorial.
+ MessageTracer unwrapMethod:(Integer compiledMethodAt:#factorial).
+ Transcript showCR:'5 factorial normal'.
+ 5 factorial.
"
"Modified: / 25-06-1996 / 22:04:51 / stefan"
@@ -1935,20 +2348,20 @@
"return anObjects real class"
(anObject class category == #'* trapping *') ifFalse:[
- ^ anObject class
+ ^ anObject class
].
^ anObject class superclass
!
trap:anObject selector:aSelector
- "arrange for the debugger to be entered when a message with aSelector is
+ "arrange for the debugger to be entered when a message with aSelector is
sent to anObject. Use untrap to remove this trap.
The current implementation does not allow integers or nil to be trapped."
self wrap:anObject
- selector:aSelector
- onEntry:BreakBlock
- onExit:LeaveBreakBlock.
+ selector:aSelector
+ onEntry:BreakBlock
+ onExit:LeaveBreakBlock.
"
|p|
@@ -1963,9 +2376,9 @@
trap:anObject selectors:aCollection
self wrap:anObject
- selectors:aCollection
- onEntry:BreakBlock
- onExit:LeaveBreakBlock.
+ selectors:aCollection
+ onEntry:BreakBlock
+ onExit:LeaveBreakBlock.
"Modified: 22.10.1996 / 17:39:50 / cg"
!
@@ -1974,8 +2387,8 @@
"trap on all messages which are understood by anObject"
self wrapAll:anObject
- onEntry:BreakBlock
- onExit:LeaveBreakBlock.
+ onEntry:BreakBlock
+ onExit:LeaveBreakBlock.
"Modified: 22.10.1996 / 17:39:54 / cg"
!
@@ -1997,7 +2410,7 @@
orgClass := anObject class.
orgClass category == #'* trapping *' ifFalse:[
- ^ self
+ ^ self
].
anObject changeClassTo:orgClass superclass.
@@ -2033,12 +2446,12 @@
dict at:aSelector ifAbsent:[^ self].
dict size == 1 ifTrue:[
- "the last trap got removed"
- anObject changeClassTo:orgClass superclass.
- ObjectCopyHolders notNil ifTrue:[
- ObjectCopyHolders removeKey:anObject ifAbsent:nil.
+ "the last trap got removed"
+ anObject changeClassTo:orgClass superclass.
+ ObjectCopyHolders notNil ifTrue:[
+ ObjectCopyHolders removeKey:anObject ifAbsent:nil.
].
- ^ self
+ ^ self
].
dict removeKey:aSelector.
orgClass methodDictionary:dict.
@@ -2071,7 +2484,7 @@
"return the set of wrapped selectors (if any)"
(anObject class category == #'* trapping *') ifFalse:[
- ^ #()
+ ^ #()
].
^ anObject class selectors
! !
@@ -2081,8 +2494,8 @@
trapModificationsIn:anObject
"trap modifications in anObject"
- self
- trapModificationsIn:anObject filter:[:old :new | true]
+ self
+ trapModificationsIn:anObject filter:[:old :new | true]
"
|a|
@@ -2113,7 +2526,7 @@
allSelectors := IdentitySet new.
anObject class withAllSuperclassesDo:[:aClass |
- aClass methodDictionary keys addAllTo:allSelectors
+ aClass methodDictionary keys addAllTo:allSelectors
].
self trapModificationsIn:anObject selectors:allSelectors filter:aFilterBlock
@@ -2145,13 +2558,13 @@
trapModificationsIn:anObject selector:aSelector filter:aFilterBlock
"install a trap for modifications in anObject by aSelector-messages.
the filterBlock will be invoked (after a modification) with the old and
- new values as arguments and should return true,
+ new values as arguments and should return true,
if the debugger is really wanted."
self
- trapModificationsIn:anObject
- selectors:(Array with:aSelector)
- filter:aFilterBlock
+ trapModificationsIn:anObject
+ selectors:(Array with:aSelector)
+ filter:aFilterBlock
"Modified: / 21.4.1998 / 15:34:44 / cg"
!
@@ -2159,27 +2572,27 @@
trapModificationsIn:anObject selectors:aCollectionOfSelectors filter:aFilterBlock
"install a trap for modifications in anObject by aSelector-messages.
the filterBlock will be invoked (after a modification) with the old and
- new values as arguments and should return true,
+ new values as arguments and should return true,
if the debugger is really wanted."
|copyHolder sels checkBlock|
- (anObject isNil
- or:[anObject isSymbol
- or:[anObject class == SmallInteger
- or:[anObject == true
- or:[anObject == false]]]])
+ (anObject isNil
+ or:[anObject isSymbol
+ or:[anObject class == SmallInteger
+ or:[anObject == true
+ or:[anObject == false]]]])
ifTrue:[
- self error:'cannot place trap on this object' mayProceed:true.
- ^ self.
+ self error:'cannot place trap on this object' mayProceed:true.
+ ^ self.
].
ObjectCopyHolders isNil ifTrue:[
- ObjectCopyHolders := WeakIdentityDictionary new.
+ ObjectCopyHolders := WeakIdentityDictionary new.
].
copyHolder := ObjectCopyHolders at:anObject ifAbsent:nil.
copyHolder isNil ifTrue:[
- ObjectCopyHolders at:anObject put:(copyHolder := ValueHolder new).
+ ObjectCopyHolders at:anObject put:(copyHolder := ValueHolder new).
].
copyHolder value:(anObject shallowCopy).
@@ -2187,40 +2600,40 @@
"/ some required ones, which are used in the wrapped code and are known to
"/ do no harm to the object ... consider this a kludge
sels := aCollectionOfSelectors copy.
- sels removeAll:#(#class #species #yourself #'sameContentsAs:'
- #'instVarAt:' #'at:' #'basicAt:'
- #'shallowCopy' #'copy'
- #'=' #'==' #'~=' #'~~'
- #'size'
- ).
+ sels removeAll:#(#class #species #yourself #'sameContentsAs:'
+ #'instVarAt:' #'at:' #'basicAt:'
+ #'shallowCopy' #'copy'
+ #'=' #'==' #'~=' #'~~'
+ #'size'
+ ).
checkBlock :=
- [:con :retVal |
- |oldValue|
-
- oldValue := copyHolder value.
-
- "/ compare with copy ...
- (anObject sameContentsAs:oldValue) ifFalse:[
- "/ see oldValue vs. anObject
- (aFilterBlock value:oldValue value:anObject) ifTrue:[
- copyHolder value:(anObject shallowCopy).
- ObjectWrittenBreakpointSignal
- raiseRequestWith:(oldValue -> anObject)
- errorString:('object was modififed in: ' , con sender selector)
- in:con sender
- ]
- ]
- ].
+ [:con :retVal |
+ |oldValue|
+
+ oldValue := copyHolder value.
+
+ "/ compare with copy ...
+ (anObject sameContentsAs:oldValue) ifFalse:[
+ "/ see oldValue vs. anObject
+ (aFilterBlock value:oldValue value:anObject) ifTrue:[
+ copyHolder value:(anObject shallowCopy).
+ ObjectWrittenBreakpointSignal
+ raiseRequestWith:(oldValue -> anObject)
+ errorString:('object was modififed in: ' , con sender selector)
+ in:con sender
+ ]
+ ]
+ ].
sels do:[:aSelector |
- self
- wrap:anObject
- selector:aSelector
- onEntry:[:con | ]
- onExit:checkBlock
- withOriginalClass:true
- flushCaches:false.
+ self
+ wrap:anObject
+ selector:aSelector
+ onEntry:[:con | ]
+ onExit:checkBlock
+ withOriginalClass:true
+ flushCaches:false.
].
ObjectMemory flushCaches
@@ -2234,20 +2647,20 @@
|idx selectors definingClass|
anInstVarOrOffset isInteger ifTrue:[
- "/ indexed slot
- self
- trapModificationsIn:anObject filter:[:old :new | (old at:anInstVarOrOffset) ~~ (new at:anInstVarOrOffset)]
+ "/ indexed slot
+ self
+ trapModificationsIn:anObject filter:[:old :new | (old at:anInstVarOrOffset) ~~ (new at:anInstVarOrOffset)]
] ifFalse:[
- "/ instVar by name
- selectors := IdentitySet new.
- definingClass := anObject class whichClassDefinesInstVar:anInstVarOrOffset.
-
- definingClass withAllSuperclassesDo:[:aClass |
- aClass methodDictionary keys addAllTo:selectors
- ].
- idx := anObject class instVarIndexFor:anInstVarOrOffset.
- self
- trapModificationsIn:anObject selectors:selectors filter:[:old :new | (old instVarAt:idx) ~~ (new instVarAt:idx)]
+ "/ instVar by name
+ selectors := IdentitySet new.
+ definingClass := anObject class whichClassDefinesInstVar:anInstVarOrOffset.
+
+ definingClass withAllSuperclassesDo:[:aClass |
+ aClass methodDictionary keys addAllTo:selectors
+ ].
+ idx := anObject class instVarIndexFor:anInstVarOrOffset.
+ self
+ trapModificationsIn:anObject selectors:selectors filter:[:old :new | (old instVarAt:idx) ~~ (new instVarAt:idx)]
]
"
@@ -2274,7 +2687,7 @@
!MessageTracer class methodsFor:'object tracing'!
trace:anObject selector:aSelector
- "arrange for a trace message to be output on Stderr, when a message with
+ "arrange for a trace message to be output on Stderr, when a message with
aSelector is sent to anObject. Both entry and exit are traced.
Use untrap to remove this trace.
The current implementation does not allow integers or nil to be traced."
@@ -2305,15 +2718,15 @@
!
trace:anObject selector:aSelector on:aStream
- "arrange for a trace message to be output on Stderr, when a message with
+ "arrange for a trace message to be output on Stderr, when a message with
aSelector is sent to anObject. Both entry and exit are traced.
Use untrap to remove this trace.
The current implementation does not allow integers or nil to be traced."
self
- trace:anObject
- selectors:(Array with:aSelector)
- on:aStream
+ trace:anObject
+ selectors:(Array with:aSelector)
+ on:aStream
"
|p|
@@ -2339,8 +2752,8 @@
!
trace:anObject selectors:aCollectionOfSelectors
- "arrange for a trace message to be output on Stderr, when any message
- from aCollectionOfSelectors is sent to anObject.
+ "arrange for a trace message to be output on Stderr, when any message
+ from aCollectionOfSelectors is sent to anObject.
Both entry and exit are traced.
Use untrap:/untrace: to remove this trace.
The current implementation does not allow integers or nil to be traced."
@@ -2371,35 +2784,35 @@
!
trace:anObject selectors:aCollectionOfSelectors on:aStream
- "arrange for a trace message to be output on Stderr, when any message
- from aCollectionOfSelectors is sent to anObject.
+ "arrange for a trace message to be output on Stderr, when any message
+ from aCollectionOfSelectors is sent to anObject.
Both entry and exit are traced.
Use untrap:/untrace: to remove this trace.
The current implementation does not allow integers or nil to be traced."
aCollectionOfSelectors do:[:aSelector |
- |methodName|
-
- methodName := anObject class name , '>>' , aSelector.
- self
- wrap:anObject
- selector:aSelector
- onEntry:[:con |
- aStream nextPutAll:'enter '; nextPutAll:methodName.
- aStream nextPutAll:' receiver='.
- con receiver printOn:aStream.
- aStream nextPutAll:' args='. (con args) printOn:aStream.
- aStream nextPutAll:' from:'. con sender printOn:aStream.
- aStream cr; flush
- ]
- onExit:[:con :retVal |
- aStream nextPutAll:'leave '; nextPutAll:methodName.
- aStream nextPutAll:' receiver='. con receiver printOn:aStream.
- aStream nextPutAll:' returning:'. retVal printOn:aStream.
- aStream cr; flush
- ]
- withOriginalClass:true
- flushCaches:false
+ |methodName|
+
+ methodName := anObject class name , '>>' , aSelector.
+ self
+ wrap:anObject
+ selector:aSelector
+ onEntry:[:con |
+ aStream nextPutAll:'enter '; nextPutAll:methodName.
+ aStream nextPutAll:' receiver='.
+ con receiver printOn:aStream.
+ aStream nextPutAll:' args='. (con args) printOn:aStream.
+ aStream nextPutAll:' from:'. con sender printOn:aStream.
+ aStream cr; flush
+ ]
+ onExit:[:con :retVal |
+ aStream nextPutAll:'leave '; nextPutAll:methodName.
+ aStream nextPutAll:' receiver='. con receiver printOn:aStream.
+ aStream nextPutAll:' returning:'. retVal printOn:aStream.
+ aStream cr; flush
+ ]
+ withOriginalClass:true
+ flushCaches:false
].
ObjectMemory flushCaches
@@ -2486,7 +2899,7 @@
allSelectors := IdentitySet new.
anObject class withAllSuperclassesDo:[:aClass |
- aClass methodDictionary keys addAllTo:allSelectors
+ aClass methodDictionary keys addAllTo:allSelectors
].
self trace:anObject selectors:allSelectors on:aStream
@@ -2504,14 +2917,14 @@
!
traceEntry:anObject selectors:aCollectionOfSelectors on:aStream
- "arrange for a trace message to be output on Stderr, when any message
- from aCollectionOfSelectors is sent to anObject.
+ "arrange for a trace message to be output on Stderr, when any message
+ from aCollectionOfSelectors is sent to anObject.
Only entry is traced.
Use untrap:/untrace: to remove this trace.
The current implementation does not allow integers or nil to be traced."
self
- traceEntry:anObject selectors:aCollectionOfSelectors on:Stderr
+ traceEntry:anObject selectors:aCollectionOfSelectors on:Stderr
"
|p|
@@ -2536,7 +2949,7 @@
!
traceSender:anObject selector:aSelector
- "arrange for a trace message to be output on Stderr, when a message with
+ "arrange for a trace message to be output on Stderr, when a message with
aSelector is sent to anObject. Only the sender is traced on entry.
Use untrap to remove this trace.
The current implementation does not allow integers or nil to be traced."
@@ -2567,7 +2980,7 @@
!
traceSender:anObject selector:aSelector on:aStream
- "arrange for a trace message to be output on Stderr, when a message with
+ "arrange for a trace message to be output on Stderr, when a message with
aSelector is sent to anObject. Only the sender is traced on entry.
Use untrap to remove this trace.
The current implementation does not allow integers or nil to be traced."
@@ -2576,14 +2989,14 @@
methodName := anObject class name , '>>' , aSelector.
self wrap:anObject
- selector:aSelector
- onEntry:[:con |
- aStream nextPutAll:methodName.
- aStream nextPutAll:' from '.
- con sender printOn:aStream.
- aStream cr; flush.
- ]
- onExit:LeaveTraceBlock.
+ selector:aSelector
+ onEntry:[:con |
+ aStream nextPutAll:methodName.
+ aStream nextPutAll:' from '.
+ con sender printOn:aStream.
+ aStream cr; flush.
+ ]
+ onExit:LeaveTraceBlock.
"
|p|
@@ -2636,19 +3049,19 @@
The current implementation does not allow integers or nil to be wrapped."
"I have not yet enough experience, if the wrapped original method should
- run as an instance of the original, or of the catching class;
+ run as an instance of the original, or of the catching class;
The latter has the advantage of catching recursive and other sends, while
it might lead into trouble when the message is sent from a debugger or a long
return is done out of the original method ...
Time will show, you can experiment by setting the withOriginalClass: flag to false
"
- ^ self
- wrap:anObject
- selector:aSelector
- onEntry:entryBlock
- onExit:exitBlock
- withOriginalClass:true
- flushCaches:true
+ ^ self
+ wrap:anObject
+ selector:aSelector
+ onEntry:entryBlock
+ onExit:exitBlock
+ withOriginalClass:true
+ flushCaches:true
"Modified: / 21.4.1998 / 15:29:50 / cg"
!
@@ -2668,7 +3081,7 @@
"
some are not allowed (otherwise we get into trouble ...)
"
- (aSelector == #class
+ (aSelector == #class
or:[aSelector == #changeClassTo:]) ifTrue:[
Transcript showCR:'sorry, cannot place trap on: ' , aSelector.
^ self
@@ -2736,14 +3149,20 @@
withSTCCompilation:#never
do:[
Class withoutUpdatingChangesDo:[
- trapMethod := Compiler
- compile:s contents
- forClass:newClass
- inCategory:'breakpointed'
- notifying:nil
- install:false
- skipIfSame:false
- silent:true.
+ [
+ trapMethod := Compiler
+ compile:s contents
+ forClass:newClass
+ inCategory:'breakpointed'
+ notifying:nil
+ install:false
+ skipIfSame:false
+ silent:true.
+ ] on: ParseError do:[:ex |
+ "/ Sigh, compiler used to return #Error but now raises
+ "/ a ParseError. Simulate old behaviour
+ trapMethod := #Error
+ ].
]
].
@@ -2800,9 +3219,9 @@
|p|
p := Point new copy.
- MessageTracer
+ MessageTracer
wrap:p
- selector:#y:
+ selector:#y:
onEntry:nil
onExit:[:context :retVal |
Transcript show:'leave Point>>y:, returning:'.
@@ -2828,7 +3247,7 @@
p := Point new copy.
MessageTracer wrap:p
- selector:#y:
+ selector:#y:
onEntry:[:context | self halt:'y: you are trapped']
onExit:nil
withOriginalClass:false.
@@ -2846,6 +3265,7 @@
"Modified: / 25-06-1996 / 22:11:21 / stefan"
"Created: / 21-04-1998 / 15:30:27 / cg"
+ "Modified: / 29-07-2014 / 11:58:46 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
wrap:anObject selector:aSelector onEntry:entryBlock onExit:exitBlock withOriginalClass:withOriginalClass flushCaches:flushCaches
@@ -2858,20 +3278,20 @@
NOTICE: The current implementation does not allow integers or nil to be wrapped."
^ self
- wrap:anObject selector:aSelector onEntry:entryBlock onExit:exitBlock
- additionalEntryCode:nil additionalExitCode:nil additionalVariables:nil
- withOriginalClass:withOriginalClass flushCaches:flushCaches
+ wrap:anObject selector:aSelector onEntry:entryBlock onExit:exitBlock
+ additionalEntryCode:nil additionalExitCode:nil additionalVariables:nil
+ withOriginalClass:withOriginalClass flushCaches:flushCaches
!
wrap:anObject selectors:aCollection onEntry:entryBlock onExit:exitBlock
"install wrappers for anObject on all selectors from aCollection"
aCollection do:[:aSelector |
- self
- wrap:anObject selector:aSelector
- onEntry:entryBlock onExit:exitBlock
- withOriginalClass:true
- flushCaches:false
+ self
+ wrap:anObject selector:aSelector
+ onEntry:entryBlock onExit:exitBlock
+ withOriginalClass:true
+ flushCaches:false
].
ObjectMemory flushCaches
@@ -2885,7 +3305,7 @@
allSelectors := IdentitySet new.
anObject class withAllSuperclassesDo:[:aClass |
- aClass methodDictionary keys addAllTo:allSelectors
+ aClass methodDictionary keys addAllTo:allSelectors
].
self wrap:anObject selectors:allSelectors onEntry:entryBlock onExit:exitBlock
@@ -2895,30 +3315,32 @@
!MessageTracer class methodsFor:'queries'!
allWrappedMethods
- ^ Smalltalk allMethodsForWhich:[:mthd | mthd isWrapped]
+ ^ WrappedMethod allWrappedMethods.
+ "/ ^ Smalltalk allMethodsForWhich:[:mthd | mthd isWrapped]
!
areAnyMethodsWrapped
- Smalltalk allMethodsDo:[:mthd |
- mthd isWrapped ifTrue:[ ^ true ]
- ].
- ^ false
+ ^ WrappedMethod allWrappedMethods notEmpty.
+"/ Smalltalk allMethodsDo:[:mthd |
+"/ mthd isWrapped ifTrue:[ ^ true ]
+"/ ].
+"/ ^ false
!
isCounting:aMethod
"return true if aMethod is counted"
MethodCounts notNil ifTrue:[
- (MethodCounts includesKey:aMethod) ifTrue:[^ true].
- aMethod isWrapped ifTrue:[
- (MethodCounts includesKey:aMethod originalMethod)ifTrue:[^ true].
- ].
+ (MethodCounts includesKey:aMethod) ifTrue:[^ true].
+ aMethod isWrapped ifTrue:[
+ (MethodCounts includesKey:aMethod originalMethod)ifTrue:[^ true].
+ ].
].
MethodCountsPerReceiverClass notNil ifTrue:[
- (MethodCountsPerReceiverClass includesKey:aMethod) ifTrue:[^ true].
- aMethod isWrapped ifTrue:[
- (MethodCountsPerReceiverClass includesKey:aMethod originalMethod)ifTrue:[^ true].
- ].
+ (MethodCountsPerReceiverClass includesKey:aMethod) ifTrue:[^ true].
+ aMethod isWrapped ifTrue:[
+ (MethodCountsPerReceiverClass includesKey:aMethod originalMethod)ifTrue:[^ true].
+ ].
].
^ false
@@ -2932,18 +3354,27 @@
MethodCountsPerReceiverClass isNil ifTrue:[^ false].
(MethodCountsPerReceiverClass includesKey:aMethod) ifTrue:[^ true].
aMethod isWrapped ifTrue:[
- ^ MethodCountsPerReceiverClass includesKey:aMethod originalMethod
+ ^ MethodCountsPerReceiverClass includesKey:aMethod originalMethod
].
^ false
!
+isMocking:aMethod
+ "Return true if aMethod is mocking"
+
+ aMethod basicLiterals do:[ :object | object == MockedMethodMarker ifTrue:[ ^ true ] ].
+ ^ false
+
+ "Created: / 29-07-2014 / 09:51:59 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
isTiming:aMethod
"return true if aMethod is timed"
MethodTiming isNil ifTrue:[^ false].
(MethodTiming includesKey:aMethod) ifTrue:[^ true].
aMethod isWrapped ifTrue:[
- ^ MethodTiming includesKey:aMethod originalMethod
+ ^ MethodTiming includesKey:aMethod originalMethod
].
^ false
@@ -2996,7 +3427,7 @@
"/ depends on whether there is already some statistic data)
10 timesRepeat:[
- self dummyEmptyMethod.
+ self dummyEmptyMethod.
].
"/ fetch min time & unwrap
@@ -3022,9 +3453,9 @@
!
printEntryFull:aContext level:lvl on:aStream
- aStream
- spaces:lvl;
- nextPutAll:'enter '.
+ aStream
+ spaces:lvl;
+ nextPutAll:'enter '.
self printFull:aContext on:aStream withSender:true.
!
@@ -3037,24 +3468,24 @@
mClass := aContext methodClass.
mClass isNil ifTrue:[
- mClassName := '???'
+ mClassName := '???'
] ifFalse:[
- mClassName := mClass name
+ mClassName := mClass name
].
- aStream
- nextPutAll:mClassName;
- space;
- bold;
- nextPutAll:aContext selector;
- normal;
- nextPutAll:' from '.
+ aStream
+ nextPutAll:mClassName;
+ space;
+ bold;
+ nextPutAll:aContext selector;
+ normal;
+ nextPutAll:' from '.
sender := aContext sender.
sender notNil ifTrue:[
- (sender selector startsWith:'perform:') ifTrue:[
- sender := sender sender.
- ].
+ (sender selector startsWith:'perform:') ifTrue:[
+ sender := sender sender.
+ ].
].
sender printOn:aStream.
aStream cr; flush.
@@ -3075,19 +3506,19 @@
mClass := aContext methodClass.
mClass isNil ifTrue:[
- mClassName := '???'
+ mClassName := '???'
] ifFalse:[
- mClassName := mClass name
+ mClassName := mClass name
].
- aStream
- spaces:lvl;
- nextPutAll:'leave ';
- nextPutAll:mClassName;
- space;
- bold;
- nextPutAll:aContext selector;
- normal;
- nextPutAll:' rec=['.
+ aStream
+ spaces:lvl;
+ nextPutAll:'leave ';
+ nextPutAll:mClassName;
+ space;
+ bold;
+ nextPutAll:aContext selector;
+ normal;
+ nextPutAll:' rec=['.
self printObject:aContext receiver on:aStream.
aStream nextPutAll:'] return: ['.
@@ -3101,9 +3532,9 @@
printFull:aContext on:aStream withSender:withSender
self
- printFull:aContext on:aStream
- withSenderContext:(withSender ifTrue:[aContext sender]
- ifFalse:[nil])
+ printFull:aContext on:aStream
+ withSenderContext:(withSender ifTrue:[aContext sender]
+ ifFalse:[nil])
!
printFull:aContext on:aStream withSenderContext:aSenderContextOrNil
@@ -3111,30 +3542,30 @@
mClass := aContext methodClass.
mClass isNil ifTrue:[
- mClassName := '???'
+ mClassName := '???'
] ifFalse:[
- mClassName := mClass name
+ mClassName := mClass name
].
- aStream
- nextPutAll:mClassName;
- space;
- bold;
- nextPutAll:aContext selector;
- normal;
- nextPutAll:' rec=['.
+ aStream
+ nextPutAll:mClassName;
+ space;
+ bold;
+ nextPutAll:aContext selector;
+ normal;
+ nextPutAll:' rec=['.
self printObject:aContext receiver on:aStream.
- aStream nextPutAll:'] '.
+ aStream nextPutAll:'] '.
(aContext args) keysAndValuesDo:[:idx :arg |
- aStream nextPutAll:'arg'. idx printOn:aStream. aStream nextPutAll:'=['.
- self printObject:arg on:aStream.
- aStream nextPutAll:'] '.
+ aStream nextPutAll:'arg'. idx printOn:aStream. aStream nextPutAll:'=['.
+ self printObject:arg on:aStream.
+ aStream nextPutAll:'] '.
].
aSenderContextOrNil notNil ifTrue:[
- self printSender:aSenderContextOrNil on:aStream.
+ self printSender:aSenderContextOrNil on:aStream.
].
aStream cr; flush.
!
@@ -3144,7 +3575,7 @@
s := anObject printString.
s size > 40 ifTrue:[
- s := s chopTo:40.
+ s := s chopTo:40.
].
aStream nextPutAll:s
!
@@ -3154,11 +3585,11 @@
sender := aSenderContext.
sender notNil ifTrue:[
- (sender selector startsWith:'perform:') ifTrue:[
- sender := sender sender.
- ].
+ (sender selector startsWith:'perform:') ifTrue:[
+ sender := sender sender.
+ ].
].
- aStream nextPutAll:'from:'.
+ aStream nextPutAll:'from:'.
aStream bold.
sender printOn:aStream.
aStream normal.
@@ -3170,32 +3601,32 @@
con := aContext.
[con notNil
- and:[con selector ~~ #'changed:with:']
+ and:[con selector ~~ #'changed:with:']
] whileTrue:[
- con := con sender.
+ con := con sender.
].
"/ con is #'changed:with:'
con isNil ifTrue:[
- ^ self printEntryFull:aContext level:lvl on:aStream.
+ ^ self printEntryFull:aContext level:lvl on:aStream.
].
(con sender notNil
and:[ con sender selector == #'changed:']) ifTrue:[
- con := con sender.
+ con := con sender.
].
(con sender notNil
and:[ con sender selector == #'changed']) ifTrue:[
- con := con sender.
+ con := con sender.
].
(con sender notNil) ifTrue:[
- con := con sender.
+ con := con sender.
].
aStream spaces:lvl; nextPutAll:'enter '.
self
- printFull:aContext
- on:aStream
- withSenderContext:con
+ printFull:aContext
+ on:aStream
+ withSenderContext:con
!
traceEntryFull:aContext on:aStream
@@ -3210,10 +3641,10 @@
"avoid generation of fullBlocks"
aStream == Transcript ifTrue:[
- ^ TraceFullBlock2
+ ^ TraceFullBlock2
].
aStream == Stderr ifTrue:[
- ^ TraceFullBlock
+ ^ TraceFullBlock
].
^ [:con | con fullPrintAllOn:aStream]
@@ -3225,10 +3656,10 @@
"avoid generation of fullBlocks"
aStream == Transcript ifTrue:[
- ^ TraceSenderBlock2
+ ^ TraceSenderBlock2
].
aStream == Stderr ifTrue:[
- ^ TraceSenderBlock
+ ^ TraceSenderBlock
].
^ [:con | MessageTracer printEntrySender:con on:aStream]
@@ -3246,24 +3677,24 @@
ObjectMemory stepInterruptHandler:self.
^ [
- ObjectMemory flushInlineCaches.
- StepInterruptPending := 1.
- InterruptPending := 1.
- aBlock value
+ ObjectMemory flushInlineCaches.
+ StepInterruptPending := 1.
+ InterruptPending := 1.
+ aBlock value
] ensure:[
- tracedBlock := nil.
- StepInterruptPending := nil.
- ObjectMemory stepInterruptHandler:nil.
+ tracedBlock := nil.
+ StepInterruptPending := nil.
+ ObjectMemory stepInterruptHandler:nil.
]
"
PrintingMessageTracer new trace:[#(6 5 4 3 2 1) sort] detail:false
- PrintingMessageTracer new trace:[#(6 5 4 3 2 1) sort] detail:true
-
- PrintingMessageTracer new trace:[#(6 5 4 3 2 1) sort] detail:#indent
-
- PrintingMessageTracer new trace:[#(6 5 4 3 2 1) sort] detail:#fullIndent
+ PrintingMessageTracer new trace:[#(6 5 4 3 2 1) sort] detail:true
+
+ PrintingMessageTracer new trace:[#(6 5 4 3 2 1) sort] detail:#indent
+
+ PrintingMessageTracer new trace:[#(6 5 4 3 2 1) sort] detail:#fullIndent
"
! !
@@ -3276,11 +3707,21 @@
InterruptPending := 1.
! !
+!MessageTracer::MethodSpyInfo methodsFor:'accessing'!
+
+profiler
+ ^ profiler
+!
+
+profiler:aMessageTally
+ profiler := aMessageTally.
+! !
+
!MessageTracer::MethodTimingInfo methodsFor:'accessing'!
avgTime
sumTimes notNil ifTrue:[
- ^ sumTimes / count
+ ^ sumTimes / count
].
^ nil
@@ -3303,7 +3744,7 @@
^ count
!
-count:countArg minTime:minTimeArg maxTime:maxTimeArg sumTimes:sumTimesArg
+count:countArg minTime:minTimeArg maxTime:maxTimeArg sumTimes:sumTimesArg
count := countArg.
minTime := minTimeArg.
maxTime := maxTimeArg.
@@ -3344,18 +3785,18 @@
rememberExecutionTime:t
(count isNil or:[count == 0]) ifTrue:[
- minTime := maxTime := sumTimes := t.
- count := 1.
+ minTime := maxTime := sumTimes := t.
+ count := 1.
] ifFalse:[
- t < minTime ifTrue:[
- minTime := t.
- ] ifFalse:[
- t > maxTime ifTrue:[
- maxTime := t.
- ]
- ].
- sumTimes := (sumTimes + t).
- count := count + 1
+ t < minTime ifTrue:[
+ minTime := t.
+ ] ifFalse:[
+ t > maxTime ifTrue:[
+ maxTime := t.
+ ]
+ ].
+ sumTimes := (sumTimes + t).
+ count := count + 1
].
"Created: / 05-03-2007 / 15:32:43 / cg"
@@ -3380,53 +3821,53 @@
outStream := output ? Stderr.
con receiver == Processor ifTrue:[
- (sel := con selector) == #threadSwitch: ifTrue:[
- ignore := true.
- ].
- sel == #timerInterrupt ifTrue:[
- ignore := true.
- ]
+ (sel := con selector) == #threadSwitch: ifTrue:[
+ ignore := true.
+ ].
+ sel == #timerInterrupt ifTrue:[
+ ignore := true.
+ ]
].
con lineNumber == 1 ifFalse:[
- ignore := true
+ ignore := true
].
ignore ifFalse:[
- con markForInterruptOnUnwind.
-
- ((r := con receiver) ~~ self
- and:[r ~~ tracedBlock]) ifTrue:[
- traceDetail == #fullIndent ifTrue:[
- [con notNil
- and:[(r := con receiver) ~~ self
- and:[r ~~ tracedBlock]]] whileTrue:[
- ' ' printOn:outStream.
- con := con sender.
- ].
- con := senderContext.
- self class printFull:con on:outStream withSender:false.
- ] ifFalse:[
- traceDetail == #indent ifTrue:[
- [con notNil
- and:[(r := con receiver) ~~ self
- and:[r ~~ tracedBlock]]] whileTrue:[
- ' ' printOn:outStream.
- con := con sender.
- ].
- con := senderContext.
- con printOn:outStream.
- outStream cr.
- ] ifFalse:[
- traceDetail == true ifTrue:[
- self class printFull:con on:outStream withSender:true.
- ] ifFalse:[
- con printOn:outStream.
- outStream cr.
- ]
- ]
- ].
- ].
+ con markForInterruptOnUnwind.
+
+ ((r := con receiver) ~~ self
+ and:[r ~~ tracedBlock]) ifTrue:[
+ traceDetail == #fullIndent ifTrue:[
+ [con notNil
+ and:[(r := con receiver) ~~ self
+ and:[r ~~ tracedBlock]]] whileTrue:[
+ ' ' printOn:outStream.
+ con := con sender.
+ ].
+ con := senderContext.
+ self class printFull:con on:outStream withSender:false.
+ ] ifFalse:[
+ traceDetail == #indent ifTrue:[
+ [con notNil
+ and:[(r := con receiver) ~~ self
+ and:[r ~~ tracedBlock]]] whileTrue:[
+ ' ' printOn:outStream.
+ con := con sender.
+ ].
+ con := senderContext.
+ con printOn:outStream.
+ outStream cr.
+ ] ifFalse:[
+ traceDetail == true ifTrue:[
+ self class printFull:con on:outStream withSender:true.
+ ] ifFalse:[
+ con printOn:outStream.
+ outStream cr.
+ ]
+ ]
+ ].
+ ].
].
ObjectMemory flushInlineCaches.
@@ -3436,28 +3877,19 @@
"
self new trace:[#(6 5 4 3 2 1) sort] detail:false
- self new trace:[#(6 5 4 3 2 1) sort] detail:true
-
- self new trace:[#(6 5 4 3 2 1) sort] detail:#indent
-
- self new trace:[#(6 5 4 3 2 1) sort] detail:#fullIndent
- self new trace:[ View new ] detail:#fullIndent
+ self new trace:[#(6 5 4 3 2 1) sort] detail:true
+
+ self new trace:[#(6 5 4 3 2 1) sort] detail:#indent
+
+ self new trace:[#(6 5 4 3 2 1) sort] detail:#fullIndent
+ self new trace:[ View new ] detail:#fullIndent
"
! !
!MessageTracer class methodsFor:'documentation'!
version_CVS
- ^ '$Header: /cvs/stx/stx/libbasic3/MessageTracer.st,v 1.127 2013-08-29 09:52:30 cg Exp $'
-!
-
-version_HG
-
- ^ '$Changeset: <not expanded> $'
-!
-
-version_SVN
- ^ 'Id: MessageTracer.st 1981 2012-11-30 17:20:01Z vranyj1 '
+ ^ '$Header: /cvs/stx/stx/libbasic3/MessageTracer.st,v 1.137 2015-02-18 15:30:07 vrany Exp $'
! !