"
COPYRIGHT (c) 1994 by Claus Gittinger
All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
inclusion of the above copyright notice. This software may not
be provided or otherwise made available to, or used by, any
other person. No title to or ownership of the software is
hereby transferred.
"
Object subclass:#MessageTracer
instanceVariableNames:'traceDetail'
classVariableNames:'BreakpointSignal CallingLevel BreakBlock TraceSenderBlock
LeaveBlock MethodCounts MethodMemoryUsage MethodTiming
TraceFullBlock'
poolDictionaries:''
category:'System-Debugging-Support'
!
!MessageTracer class methodsFor:'documentation'!
copyright
"
COPYRIGHT (c) 1994 by Claus Gittinger
All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
inclusion of the above copyright notice. This software may not
be provided or otherwise made available to, or used by, any
other person. No title to or ownership of the software is
hereby transferred.
"
!
documentation
"
This class provides a common home for the tracing
facilities (originally, they where in Object, but have been moved to
allow easier separation of development vs. runtime configurations.
tracing execution of a block:
MessageTracer trace:[ ... ]
MessageTracer traceFull:[ ... ]
(for system developper only:)
MessageTracer debugTrace:[ ... ]
trapping sends to a specific object:
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
trapping any message sent to a specific object:
MessageTracer trapAll:anObject
...
MessageTracer untrap:anObject
trapping evaluation of a specific method:
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
tracing sends to a specific object:
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
tracing evaluation of a specific method:
MessageTracer traceMethod:aMethod
...
MessageTracer unwrapmethod:aMethod
see more in examples and in method comments.
[author:]
Claus Gittinger
"
!
examples
"
For the common cases, you will find a menu entry in the SystemBrowser.
Howeever, more special cases (especially with condition checks) can be
set up by evaluating the lower level entries.
trapping specific methods:
(by class/selector):
[exBegin]
MessageTracer trapClass:Collection selector:#select:.
Dictionary new select:[:e | ]. 'not cought - Dictionary has its own select'.
(Array new:10) select:[:e | ]. 'not cought - SeqColl has its own select'.
Set new select:[:e | ]. 'cought - Set inherits this from Collection'.
MessageTracer untrapClass:Collection
[exEnd]
(by method):
[exBegin]
MessageTracer trapMethod:(Collection compiledMethodAt:#select:).
Dictionary new select:[:e | ]. 'not cought - Dictionary has its own select'.
(Array new:10) select:[:e | ]. 'not cought - SeqColl has its own select'.
Set new select:[:e | ]. 'cought - Set inherits this from Collection'.
MessageTracer unwrapMethod:(Collection compiledMethodAt:#select:).
[exEnd]
(by method & instance class):
[exBegin]
MessageTracer trapMethod:(SequenceableCollection compiledMethodAt:#select:)
forInstancesOf:SortedCollection.
Dictionary new select:[:e | ]. 'not cought - Dictionary has its own select'.
(Array new:10) select:[:e | ]. 'not cought - not a SortedCollection'.
OrderedCollection new select:[:e | ]. 'not cought - not a SortedCollection'.
SortedCollection new select:[:e | ]. 'cought - Set inherits this from Collection'.
MessageTracer unwrapMethod:(SequenceableCollection compiledMethodAt:#select:).
[exEnd]
tracing specific methods:
(by class/selector):
[exBegin]
MessageTracer traceClass:SequenceableCollection selector:#quickSortFrom:to:.
#(6 1 9 66 2 17) copy sort.
MessageTracer untraceClass:SequenceableCollection
[exEnd]
(by method):
[exBegin]
MessageTracer traceMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:).
#(6 1 9 66 2 17) copy sort.
MessageTracer unwrapMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:).
[exEnd]
object trapping:
[exBegin]
|o|
o := OrderedCollection new.
MessageTracer trapAll:o.
o collect:[:el | el].
[exEnd]
"
! !
!MessageTracer class methodsFor:'initialization'!
initialize
BreakpointSignal isNil ifTrue:[
BreakpointSignal := HaltSignal newSignalMayProceed:true.
BreakpointSignal nameClass:self message:#breakpointSignal.
BreakpointSignal notifierString:'breakpoint encountered'.
BreakBlock := [:con | BreakpointSignal raiseIn:con].
TraceSenderBlock := [:con | MessageTracer printEntrySender:con].
TraceFullBlock := [:con | con fullPrintAll].
LeaveBlock := [:con :retVal | ].
]
"
BreakpointSignal := nil.
MessageTracer initialize
"
"Modified: 15.12.1995 / 18:19:13 / cg"
! !
!MessageTracer class methodsFor:'Signal constants'!
breakpointSignal
^ BreakpointSignal
! !
!MessageTracer class methodsFor:'class 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 traceMethod:(aClass compiledMethodAt:aSelector)
"
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
"
!
untraceAllClasses
"remove all traces of messages sent to any class"
"just a rename for your convenience - the same basic mechanism is used for all of these
trace facilities ..."
^ self untrapAllClasses
!
untraceClass:aClass
"remove all traces of messages sent to instances of aClass"
"just a rename for your convenience - the same basic mechanism is used for all of these
trace facilities ..."
^ self untrapClass:aClass
! !
!MessageTracer class methodsFor:'class wrapping'!
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.
ExitBlock will be called, when the method is left, and get context and the methods return value as arguments.
"
|myMetaclass trapMethod s spec implClass newClass save dict|
WrappedMethod autoload. "/ just to make sure ...
"
create a new method, which calls the original one,
but only if not already being trapped.
"
spec := Parser methodSpecificationForSelector:aSelector.
s := WriteStream on:String new.
s nextPutAll:spec.
s cr.
s nextPutAll:'|retVal stubClass|'; cr.
entryBlock notNil ifTrue:[
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:'^ retVal'; cr.
save := Compiler stcCompilation.
Compiler stcCompilation:#never.
[
Class withoutUpdatingChangesDo:[
trapMethod := Compiler compile:s contents
forClass:orgClass
inCategory:'trapping'
notifying:nil
install:false
skipIfSame:false
silent:true.
]
] valueNowOrOnUnwindDo:[
Compiler stcCompilation:save
].
implClass := orgClass whichClassIncludesSelector:aSelector.
implClass isNil ifTrue:[
Transcript showCR:aSelector , ' is not understood by ' , orgClass name.
] ifFalse:[
trapMethod changeLiteral:#originalMethod to:(implClass compiledMethodAt:aSelector).
].
entryBlock notNil ifTrue:[
trapMethod changeLiteral:#literal1 to:entryBlock.
].
exitBlock notNil ifTrue:[
trapMethod changeLiteral:#literal2 to:exitBlock.
].
"
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 changeClassTo:WrappedMethod.
dict := orgClass methodDictionary.
"
if not already trapping, create a new class
"
orgClass category == #'* trapping *' ifTrue:[
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 setInstanceVariableString:orgClass instanceVariableString.
newClass setName:orgClass name.
newClass category:orgClass category.
newClass methodDictionary:dict.
orgClass setSuperclass:newClass.
orgClass setClassVariableString:''.
orgClass setInstanceVariableString:''.
orgClass category:#'* 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: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.
Transcript showCR:'5 factorial normal'.
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
].
Transcript showCR:'5 factorial traced'.
5 factorial.
MessageTracer untrapClass:Integer selector:#factorial.
Transcript showCR:'5 factorial normal'.
5 factorial.
"
"Modified: 25.6.1996 / 22:01:05 / stefan"
"Modified: 10.9.1996 / 20:07:01 / cg"
! !
!MessageTracer class methodsFor:'cleanup'!
cleanup
"if you forgot which classes/methods where wrapped and/or trapped,
this cleans up everything ..."
self untrapAllClasses.
self unwrapAllMethods
"
MessageTracer cleanup
"
! !
!MessageTracer class methodsFor:'execution trace '!
debugTrace:aBlock
"trace execution of aBlock. This is for system debugging only"
Smalltalk sendTraceOn.
^ aBlock valueNowOrOnUnwindDo:[
Smalltalk sendTraceOff.
]
"
MessageTracer debugTrace:[#(6 5 4 3 2 1) sort]
"
"Modified: 18.3.1996 / 19:49:36 / cg"
!
trace:aBlock
"evaluate aBlock sending trace information to stdout.
Return the value of the block."
^ self new trace:aBlock detail:false.
"
MessageTracer trace:[#(6 5 4 3 2 1) sort]
"
!
traceFull:aBlock
"evaluate aBlock sending trace information to stdout.
Return the value of the block.
The trace information is more detailed."
^ self new trace:aBlock detail:true.
"
MessageTracer traceFull:[#(6 5 4 3 2 1) sort]
"
! !
!MessageTracer class methodsFor:'method breakpointing'!
trapClass:aClass selector:aSelector
"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
entry/leave blocks."
self trapMethod:(aClass compiledMethodAt:aSelector)
"
MessageTracer trapClass:Collection selector:#select:.
Dictionary new select:[:e | ]. 'not cought - Dictionary has its own select'.
(Array new:10) select:[:e | ]. 'not cought - SeqColl has its own select'.
Set new select:[:e | ]. 'cought - Set inherits this from Collection'.
MessageTracer untrapClass:Collection
"
!
trapMethod:aMethod
"arrange for the debugger to be entered when aMethod is about to be executed.
Use unwrapMethod or 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
entry/leave blocks."
^ self wrapMethod:aMethod
onEntry:BreakBlock
onExit:LeaveBlock.
"
MessageTracer trapMethod:(Collection compiledMethodAt:#select:).
Dictionary new select:[:e | ]. 'not cought - Dictionary has its own select'.
(Array new:10) select:[:e | ]. 'not cought - SeqColl has its own select'.
Set new select:[:e | ]. 'cought - Set inherits this from Collection'.
MessageTracer unwrapMethod:(Collection compiledMethodAt:#select:).
"
!
trapMethod:aMethod forInstancesOf:aClass
"arrange for the debugger to be entered when aMethod is about to be executed
for an instance of aClass.
Use unwrapMethod or 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
entry/leave blocks."
^ self wrapMethod:aMethod
onEntry:[:context |
(context receiver isMemberOf:aClass) ifTrue:[
BreakpointSignal raiseIn:context
]
]
onExit:LeaveBlock.
"
MessageTracer trapMethod:(View compiledMethodAt:#redraw) forInstancesOf:myView.
"
!
untrapAllClasses
"remove any traps on any class"
Smalltalk allBehaviorsDo:[:aClass |
self untrapClass:aClass
]
"
MessageTracer untrapAllClasses
"
!
untrapClass:aClass
"remove any traps on aClass"
"this is done by just patching the class back to the original"
|orgClass|
aClass category == #'* trapping *' ifFalse:[
^ self
].
orgClass := aClass superclass.
aClass setSuperclass:orgClass superclass.
aClass setClassVariableString:orgClass classVariableString.
aClass setInstanceVariableString:orgClass instanceVariableString.
aClass category:orgClass category.
aClass methodDictionary:orgClass methodDictionary.
ObjectMemory flushCaches.
"
MessageTracer untrapClass:Point
"
"Modified: 5.6.1996 / 13:57:39 / stefan"
"Modified: 10.9.1996 / 20:06:23 / cg"
!
untrapClass:aClass selector:aSelector
"remove trap of aSelector sent to aClass"
|dict|
aClass category == #'* trapping *' ifFalse:[
^ self
].
dict := aClass methodDictionary.
dict at:aSelector ifAbsent:[^ self].
ObjectMemory flushCaches. "avoid calling the old trap method"
dict size == 1 ifTrue:[
"the last trapped method"
^ self untrapClass:aClass
].
dict removeKey:aSelector.
aClass methodDictionary:dict.
"
MessageTracer trapClass:Point selector:#copy.
(1@2) copy.
(1@2) deepCopy.
MessageTracer trapClass:Point selector:#deepCopy.
(1@2) copy.
(1@2) deepCopy.
MessageTracer untrapClass:Point selector:#copy.
(1@2) copy.
(1@2) deepCopy.
MessageTracer untrapClass:Point selector:#deepCopy.
(1@2) copy.
(1@2) deepCopy.
"
"Modified: 5.6.1996 / 14:00:55 / stefan"
"Modified: 10.9.1996 / 20:06:29 / cg"
!
untrapMethod:aMethod
"remove break on 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 counting'!
countMethod:aMethod
"arrange for a aMethods execution to be counted.
Use unwrapMethod to remove this."
|lvl inside|
MethodCounts isNil ifTrue:[
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).
]
onExit:[:con :retVal |
]
"
MessageTracer countMethod:(Integer compiledMethodAt:#factorial).
5 factorial.
MessageTracer executionCountOf:(Integer compiledMethodAt:#factorial) printNL.
MessageTracer stopCountingMethod:(Integer compiledMethodAt:#factorial)
"
"Created: 15.12.1995 / 10:57:49 / cg"
"Modified: 15.12.1995 / 15:46:41 / cg"
!
executionCountOfMethod:aMethod
"return the current count"
|count|
MethodCounts isNil ifTrue:[^ 0].
aMethod isWrapped ifTrue:[
count := MethodCounts at:aMethod originalMethod ifAbsent:nil.
count notNil ifTrue:[^ count].
].
^ MethodCounts at:aMethod ifAbsent:0
"Created: 15.12.1995 / 11:01:56 / cg"
"Modified: 15.12.1995 / 15:45:15 / cg"
!
isCounting:aMethod
"return true if aMethod is counted"
MethodCounts isNil ifTrue:[^ false].
(MethodCounts includesKey:aMethod) ifTrue:[^ true].
aMethod isWrapped ifTrue:[
^ MethodCounts includesKey:aMethod originalMethod
].
^ false
"Created: 15.12.1995 / 11:07:58 / cg"
"Modified: 15.12.1995 / 15:42:10 / cg"
!
stopCountingMethod:aMethod
"remove counting of aMethod"
^ self unwrapMethod:aMethod
"Modified: 15.12.1995 / 15:43:53 / cg"
! !
!MessageTracer class methodsFor:'method memory usage'!
countMemoryUsageOfMethod:aMethod
"arrange for aMethods memory usage to be counted.
Use unwrapMethod to remove this."
|lvl inside oldPriority oldScavengeCount oldNewUsed|
MethodCounts isNil ifTrue:[
MethodCounts := IdentityDictionary new.
].
MethodMemoryUsage isNil ifTrue:[
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
]
onUnwind:[
oldPriority notNil ifTrue:[
Processor activeProcess priority:oldPriority
]
]
"
MessageTracer countMemoryUsageOfMethod:(Integer compiledMethodAt:#factorial).
3 factorial.
(MessageTracer memoryUsageOfMethod:(Integer compiledMethodAt:#factorial)) printNL.
MessageTracer stopCountingMemoryUsageOfMethod:(Integer compiledMethodAt:#factorial)
"
"Created: 18.12.1995 / 15:41:27 / stefan"
"Modified: 18.12.1995 / 21:46:48 / stefan"
!
isCountingMemoryUsage:aMethod
"return true if aMethod is counting memoryUsage"
MethodMemoryUsage isNil ifTrue:[^ false].
(MethodMemoryUsage includesKey:aMethod) ifTrue:[^ true].
aMethod isWrapped ifTrue:[
^ MethodMemoryUsage includesKey:aMethod originalMethod
].
^ false
"Created: 18.12.1995 / 15:51:49 / stefan"
!
memoryUsageOfMethod:aMethod
"return the current count"
|count memUse|
(MethodCounts isNil or:[MethodMemoryUsage isNil]) ifTrue:[^ 0].
aMethod isWrapped ifTrue:[
count := MethodCounts at:aMethod originalMethod ifAbsent:nil.
memUse := MethodMemoryUsage at:aMethod originalMethod ifAbsent:nil.
].
memUse isNil ifTrue:[
count := MethodCounts at:aMethod ifAbsent:0.
memUse := MethodMemoryUsage at:aMethod ifAbsent:0.
].
count = 0 ifTrue:[^ 0].
^ memUse//count
"Modified: 18.12.1995 / 16:25:51 / stefan"
!
stopCountingMemoryUsageOfMethod:aMethod
"remove counting memory of aMethod"
^ self unwrapMethod:aMethod
"Modified: 18.12.1995 / 21:54:36 / stefan"
! !
!MessageTracer class methodsFor:'method timing'!
executionTimesOfMethod:aMethod
"return the current times"
|count info min max avg ret|
count := min := max := avg := 0.
MethodTiming notNil ifTrue:[
aMethod isWrapped ifTrue:[
info := MethodTiming at:aMethod originalMethod ifAbsent:nil.
info notNil ifTrue:[
count := info at:1.
min := info at:2.
max := info at:3.
avg := ((info at:4) / count) roundTo:0.01
].
].
].
ret := IdentityDictionary new.
ret at:#count put:count.
ret at:#minTime put:min.
ret at:#maxTime put:max.
ret at:#avgTime put:avg.
^ ret
"Created: 17.6.1996 / 17:07:30 / cg"
"Modified: 17.6.1996 / 17:08:24 / cg"
!
isTiming:aMethod
"return true if aMethod is timed"
MethodTiming isNil ifTrue:[^ false].
(MethodTiming includesKey:aMethod) ifTrue:[^ true].
aMethod isWrapped ifTrue:[
^ MethodTiming includesKey:aMethod originalMethod
].
^ false
"Modified: 15.12.1995 / 15:42:10 / cg"
"Created: 17.6.1996 / 17:04:29 / 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 aMethods execution time to be measured.
Use unwrapMethod to remove this."
|lvl inside t0|
MethodTiming isNil ifTrue:[
MethodTiming := IdentityDictionary new.
].
MethodTiming removeKey:aMethod ifAbsent:nil.
^ self wrapMethod:aMethod
onEntry:[:con |
t0 := OperatingSystem getMillisecondTime.
]
onExit:[:con :retVal |
|info t cnt min max sumTimes|
t := OperatingSystem getMillisecondTime - t0.
info := MethodTiming at:aMethod ifAbsent:nil.
info isNil ifTrue:[
MethodTiming at:aMethod put:(Array with:1
with:t
with:t
with:t)
] ifFalse:[
cnt := info at:1.
min := info at:2.
max := info at:3.
sumTimes := info at:4.
t < min ifTrue:[
info at:2 put:t
] ifFalse:[
t > max ifTrue:[
info at:3 put:t
]
].
info at:4 put:(sumTimes + t).
info at:1 put:cnt + 1
].
]
"
MessageTracer timeMethod:(Integer compiledMethodAt:#factorial).
5 factorial.
5 factorial.
5 factorial.
(MessageTracer executionTimesOfMethod:(Integer compiledMethodAt:#factorial)) printCR.
MessageTracer stopTimingMethod:(Integer compiledMethodAt:#factorial)
"
"Created: 17.6.1996 / 17:03:50 / cg"
"Modified: 17.6.1996 / 17:10:43 / cg"
! !
!MessageTracer class methodsFor:'method tracing'!
traceMethod:aMethod
"arrange for a trace message to be output on Stderr, when aMethod is executed.
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.
inside := nil
]
]
onExit:[:con :retVal |
inside isNil ifTrue:[
inside := true.
MessageTracer printExit:con with:retVal level:lvl.
CallingLevel := lvl := lvl - 1.
inside := nil
]
]
"
MessageTracer traceMethod:(Integer compiledMethodAt:#factorial).
5 factorial.
MessageTracer untraceMethod:(Integer compiledMethodAt:#factorial)
"
"
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:).
"
!
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."
^ self wrapMethod:aMethod
onEntry:[:con | ObjectMemory flushCaches. Smalltalk sendTraceOn.]
onExit:[:con :val | Smalltalk sendTraceOff.].
"Created: 17.12.1995 / 17:08:28 / cg"
"Modified: 17.12.1995 / 17:12:50 / cg"
!
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 wrapMethod:aMethod
onEntry:TraceFullBlock
onExit:LeaveBlock.
"Created: 15.12.1995 / 18:19:31 / 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 wrapMethod:aMethod
onEntry:TraceSenderBlock
onExit:LeaveBlock.
!
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:[:aMethod |
self unwrapMethod:aMethod
]
!
unwrapMethod:aMethod
"remove any wrapper on aMethod"
|selector class originalMethod dict mthd|
MethodCounts notNil ifTrue:[
aMethod isWrapped ifTrue:[
MethodCounts removeKey:aMethod originalMethod ifAbsent:nil.
].
MethodCounts removeKey:aMethod ifAbsent:nil.
MethodCounts isEmpty ifTrue:[MethodCounts := nil].
].
MethodMemoryUsage notNil ifTrue:[
aMethod isWrapped ifTrue:[
MethodMemoryUsage removeKey:aMethod originalMethod ifAbsent:nil.
].
MethodMemoryUsage removeKey:aMethod ifAbsent:nil.
MethodMemoryUsage isEmpty ifTrue:[MethodMemoryUsage := nil].
].
MethodTiming notNil ifTrue:[
aMethod isWrapped ifTrue:[
MethodTiming removeKey:aMethod originalMethod ifAbsent:nil.
].
MethodTiming removeKey:aMethod ifAbsent:nil.
MethodTiming isEmpty ifTrue:[MethodTiming := nil].
].
CallingLevel := 0.
(aMethod isNil or:[aMethod isWrapped not]) ifTrue:[
^ aMethod
].
"
get class/selector
"
class := aMethod containingClass.
class isNil ifTrue:[
'MSGTRACER: no containing class for method found' infoPrintCR.
^ aMethod
].
selector := class selectorAtMethod:aMethod.
originalMethod := aMethod originalMethod.
originalMethod isNil ifTrue:[
self error:'oops, could not find original method'.
^ aMethod
].
dict := class methodDictionary.
mthd := dict at:selector ifAbsent:[0].
mthd ~~ 0 ifTrue:[
dict at:selector put:originalMethod.
class methodDictionary:dict.
] ifFalse:[
self halt:'oops, unexpected error'.
^ aMethod
].
ObjectMemory flushCaches.
^ originalMethod
"Modified: 5.6.1996 / 14:08:08 / stefan"
"Modified: 17.6.1996 / 17:20:43 / 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,
beacause allocating the unwindBlock uses memory and some users want to count allocated memory.
"
|selector class trapMethod s spec src dict sel save|
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)'.
^ aMethod
].
selector := class selectorAtMethod:aMethod.
WrappedMethod autoload. "/ for small systems
"
get a new method-spec
"
spec := Parser methodSpecificationForSelector:selector.
"
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:' |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:'] valueOnUnwindDo:#unwindBlock yourself.'.
].
s nextPutAll:'^ retVal'; cr.
src := s contents.
save := Compiler stcCompilation.
Compiler stcCompilation:#never.
[
Class withoutUpdatingChangesDo:[
trapMethod := Compiler compile:src
forClass:UndefinedObject
inCategory:aMethod category
notifying:nil
install:false
skipIfSame:false
silent:true.
]
] valueNowOrOnUnwindDo:[
Compiler stcCompilation:save
].
trapMethod changeClassTo:WrappedMethod.
"
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'.
dict := class methodDictionary.
sel := dict at:selector ifAbsent:[0].
sel == 0 ifTrue:[
self halt:'oops, unexpected error'.
^ aMethod
].
dict at:selector put:trapMethod.
class methodDictionary:dict.
ObjectMemory flushCaches.
^ 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: 13.12.1995 / 16:06:22 / cg"
"Modified: 25.6.1996 / 22:04:51 / stefan"
! !
!MessageTracer class methodsFor:'object breakpointing'!
trap:anObject selector:aSelector
"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:LeaveBlock.
"
|p|
p := Point new.
MessageTracer trap:p selector:#x:.
p x:5
"
!
trap:anObject selectors:aCollection
self wrap:anObject
selectors:aCollection
onEntry:BreakBlock
onExit:LeaveBlock.
!
trapAll:anObject
"trap on all messages which are understood by anObject"
self wrapAll:anObject
onEntry:BreakBlock
onExit:LeaveBlock.
!
trapAll:anObject from:aClass
"trap on all messages defined in aClass sent to anObject"
self trap:anObject selectors:aClass selectors
"Modified: 5.6.1996 / 13:46:06 / stefan"
!
untrap:anObject
"remove any traps on anObject"
"this is done by just patching the objects class back to the original"
|orgClass|
orgClass := anObject class.
orgClass category == #'* trapping *' ifFalse:[
^ self
].
anObject changeClassTo:orgClass superclass
"
|p|
p := Point new copy.
MessageTracer trace:p selector:#x:.
MessageTracer trace:p selector:#y:.
p y:1.
p x:2.
MessageTracer untrap:p
p y:2.
p x:1.
"
"Modified: 10.9.1996 / 20:06:07 / cg"
!
untrap:anObject selector:aSelector
"remove trap on aSelector from anObject"
|orgClass idx sels dict|
orgClass := anObject class.
orgClass category == #'* trapping *' ifFalse:[^ self].
dict := orgClass methodDictionary.
dict at:aSelector ifAbsent:[^ self].
dict size == 1 ifTrue:[
"the last trap got removed"
anObject changeClassTo:orgClass superclass.
^ self
].
dict removeKey:aSelector.
orgClass methodDictionary:dict.
ObjectMemory flushCaches. "avoid calling the old trap method"
"
|p|
p := Point new copy.
MessageTracer trace:p selector:#x:.
MessageTracer trace:p selector:#y:.
'trace both ...' errorPrintNL.
p x:2.
p y:1.
'trace only y ...' errorPrintNL.
MessageTracer untrap:p selector:#x:.
p x:2.
p y:1.
'trace none ...' errorPrintNL.
MessageTracer untrap:p selector:#y:.
p x:2.
p y:1.
"
"Modified: 5.6.1996 / 13:56:08 / stefan"
"Modified: 10.9.1996 / 20:06:14 / cg"
! !
!MessageTracer class methodsFor:'object tracing'!
trace:anObject selector:aSelector
"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."
|methodName|
methodName := anObject class name , '>>' , aSelector.
self wrap:anObject
selector:aSelector
onEntry:[:con |
'enter ' errorPrint. methodName errorPrint.
' receiver=' errorPrint. con receiver printString errorPrint.
' args=' errorPrint. (con args) printString errorPrint.
' from:' errorPrint. con sender errorPrintNL.
]
onExit:[:con :retVal |
'leave ' errorPrint. methodName errorPrint.
' receiver=' errorPrint. con receiver printString errorPrint.
' returning:' errorPrint. retVal printString errorPrintNL.
].
"
|p|
p := Point new.
MessageTracer trace:p selector:#x:.
p x:5.
p y:1.
p x:10.
MessageTracer untrap:p.
p x:7
"
"
|a|
a := #(6 1 9 66 2 17) copy.
MessageTracer trace:a selector:#at:put:.
MessageTracer trace:a selector:#at:.
a sort.
"
!
trace:anObject selectors:aCollection
aCollection do:[:aSelector |
self trace:anObject selector:aSelector
]
"
trace all methods in Display, which are implemented
in the DisplayWorkstation class.
"
"
MessageTracer trace:Display selectors:(XWorkstation selectorArray)
MessageTracer untrace:Display
"
!
traceAll:anObject
"trace all messages which are understood by anObject"
|allSelectors|
allSelectors := IdentitySet new.
anObject class withAllSuperclasses do:[:aClass |
aClass methodDictionary keys addAllTo:allSelectors
].
self trace:anObject selectors:allSelectors
"
trace all (implemented) messages sent to Display
(other messages lead to an error, anyway)
"
"
MessageTracer traceAll:Display
MessageTracer untrace:Display
"
"Modified: 5.6.1996 / 13:43:51 / stefan"
!
traceAll:anObject from:aClass
"trace all messages defined in aClass sent to anObject"
self trace:anObject selectors:aClass selectors
"
trace all methods in Display, which are implemented
in the DisplayWorkstation class.
"
"
MessageTracer traceAll:Display from:XWorkstation
MessageTracer untrace:Display
"
"Modified: 5.6.1996 / 13:45:37 / stefan"
!
traceSender:anObject selector:aSelector
"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."
|methodName|
methodName := anObject class name , '>>' , aSelector.
self wrap:anObject
selector:aSelector
onEntry:[:con |
methodName errorPrint.
' from ' errorPrint.
con sender errorPrintNL.
]
onExit:LeaveBlock.
"
|p|
p := Point new.
MessageTracer traceSender:p selector:#x:.
p x:5.
p y:1.
p x:10.
MessageTracer untrap:p.
p x:7
"
"
|a|
a := #(6 1 9 66 2 17) copy.
MessageTracer traceSender:a selector:#at:put:.
MessageTracer traceSender:a selector:#at:.
a sort.
"
!
untrace:anObject
"remove any traces on anObject"
"just a rename for your convenience - the same basic mechanism is used for all of these
trace facilities ..."
^ self untrap:anObject
!
untrace:anObject selector:aSelector
"remove traces of aSelector sent to anObject"
"just a rename for your convenience - the same basic mechanism is used for all of these
trace facilities ..."
^ self untrap:anObject selector:aSelector
! !
!MessageTracer class methodsFor:'object wrapping'!
wrap:anObject selector:aSelector onEntry:entryBlock onExit:exitBlock
"arrange for the two blocks entryBlock and exitBlock to be evaluated whenever
a message with aSelector is sent to anObject. 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 the context and the methods return value as arguments.
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;
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
!
wrap:anObject selector:aSelector onEntry:entryBlock onExit:exitBlock withOriginalClass:withOriginalClass
"arrange for the two blocks entryBlock and exitBlock to be evaluated whenever
a message with aSelector is sent to anObject. 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 the current context and the methods return value as argument.
If withOriginalClass is true, the class of anObject will be set to its original class
before the wrapped method will be called.
NOTICE: The current implementation does not allow integers or nil to be wrapped."
|newClass orgClass myMetaclass trapMethod s spec implClass save dict|
"
some are not allowed (otherwise we get into trouble ...)
"
(#(class changeClassTo:) includes:aSelector) ifTrue:[
Transcript showCR:'sorry, cannot place trap on: ' , aSelector.
^ self
].
WrappedMethod autoload. "/ just to make sure ...
"
create a new (anonymous) subclass of the receivers class
but only if not already being trapped.
"
orgClass := anObject class.
orgClass category == #'* trapping *' ifTrue:[
newClass := orgClass
] ifFalse:[
myMetaclass := orgClass class.
newClass := myMetaclass copy new.
newClass setSuperclass:orgClass.
newClass instSize:orgClass instSize.
newClass flags:orgClass flags.
newClass setClassVariableString:''.
newClass setInstanceVariableString:''.
newClass setName:orgClass name.
newClass category:#'* trapping *'.
newClass methodDictionary:MethodDictionary new.
].
"
create a method, executing the trap-blocks and the original method via a super-send
"
spec := Parser methodSpecificationForSelector:aSelector.
s := WriteStream on:String new.
s nextPutAll:spec.
s nextPutAll:' |retVal stubClass| '.
withOriginalClass ifTrue:[
s nextPutAll:'stubClass := self class. '.
s nextPutAll:'self changeClassTo:(stubClass superclass). '.
].
entryBlock notNil ifTrue:[
s nextPutAll:'#literal1 yourself value:thisContext. '.
].
s nextPutAll:('retVal := #originalMethod. '). "/ just to get a place for the originalMethod
s nextPutAll:('retVal := super ' , spec , '. ').
exitBlock notNil ifTrue:[
s nextPutAll:'#literal2 yourself value:thisContext value:retVal. '.
].
withOriginalClass ifTrue:[
s nextPutAll:'self changeClassTo:stubClass. '.
].
s nextPutAll:'^ retVal'; cr.
save := Compiler stcCompilation.
Compiler stcCompilation:#never.
[
Class withoutUpdatingChangesDo:[
trapMethod := Compiler compile:s contents
forClass:newClass
inCategory:'breakpointed'
notifying:nil
install:false
skipIfSame:false
silent:true.
]
] valueNowOrOnUnwindDo:[
Compiler stcCompilation:save
].
implClass := orgClass whichClassIncludesSelector:aSelector.
implClass isNil ifTrue:[
Transcript showCR:aSelector , ' is not understood by ' , orgClass name.
] ifFalse:[
trapMethod changeLiteral:#originalMethod to:(implClass compiledMethodAt:aSelector).
].
entryBlock notNil ifTrue:[
trapMethod changeLiteral:#literal1 to:entryBlock.
].
exitBlock notNil ifTrue:[
trapMethod changeLiteral:#literal2 to:exitBlock.
].
"
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 changeClassTo:WrappedMethod.
"
install this new method
"
dict := newClass methodDictionary.
dict := dict at:aSelector putOrAppend:trapMethod.
newClass methodDictionary:dict.
"
and finally, the big trick:
"
anObject changeClassTo:newClass
"
[exBegin]
|p|
p := Point new copy.
MessageTracer
wrap:p
selector:#y:
onEntry:nil
onExit:[:context :retVal |
Transcript show:'leave Point>>y:, returning:'.
Transcript showCR:retVal printString.
Transcript endEntry
]
withOriginalClass:true.
Transcript showCR:'sending x: ...'.
p x:1.
Transcript showCR:'sending y: ...'.
p y:2.
MessageTracer untrap:p.
Transcript showCR:'sending x: ...'.
p x:2.
Transcript showCR:'sending y: ...'.
p y:1.
[exEnd]
"
"
[exBegin]
|p|
p := Point new copy.
MessageTracer wrap:p
selector:#y:
onEntry:[:context | self halt:'y: you are trapped']
onExit:nil
withOriginalClass:false.
Transcript showCR:'sending x: ...'.
p x:1.
Transcript showCR:'sending y: ...'.
p y:2.
MessageTracer untrap:p.
Transcript showCR:'sending x: ...'.
p x:2.
Transcript showCR:'sending y: ...'.
p y:1.
[exEnd]
"
"Modified: 25.6.1996 / 22:11:21 / stefan"
"Modified: 10.9.1996 / 20:06:54 / cg"
!
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
]
!
wrapAll:anObject onEntry:entryBlock onExit:exitBlock
"install wrappers for anObject on all implemented selectors"
|allSelectors|
allSelectors := IdentitySet new.
anObject class withAllSuperclasses do:[:aClass |
aClass methodDictionary keys addAllTo:allSelectors
].
self wrap:anObject selectors:allSelectors onEntry:entryBlock onExit:exitBlock
"Modified: 5.6.1996 / 14:50:07 / stefan"
! !
!MessageTracer class methodsFor:'trace helpers'!
printEntryFull:aContext
self printEntryFull:aContext level:0
!
printEntryFull:aContext level:lvl
(String new:lvl) errorPrint.
'enter ' errorPrint.
aContext methodClass name errorPrint.
' ' errorPrint.
aContext selector errorPrint.
' rcvr=' errorPrint.
aContext receiver "printString" errorPrint.
' args=' errorPrint.
(aContext args) "printString" errorPrint.
' from:' errorPrint. aContext sender errorPrintNL.
!
printEntrySender:aContext
aContext methodClass name errorPrint.
' ' errorPrint. aContext selector errorPrint.
' from ' errorPrint.
aContext sender errorPrintNL.
!
printExit:aContext with:retVal
self printExit:aContext with:retVal level:0
!
printExit:aContext with:retVal level:lvl
(String new:lvl) errorPrint.
'leave ' errorPrint.
aContext methodClass name errorPrint.
' ' errorPrint.
aContext selector errorPrint.
' rcvr=' errorPrint.
aContext receiver "printString" errorPrint.
' return:' errorPrint. retVal "printString" errorPrintNL.
! !
!MessageTracer methodsFor:'trace helpers '!
stepInterrupt
"called for every send while tracing"
|con|
StepInterruptPending := nil.
con := thisContext sender.
con lineNumber == 1 ifTrue:[
traceDetail == true ifTrue:[
self class printEntryFull:con.
] ifFalse:[
con printCR.
]
].
ObjectMemory flushInlineCaches.
StepInterruptPending := 1.
InterruptPending := 1.
^ self
"Modified: 20.5.1996 / 10:28:20 / cg"
!
trace:aBlock detail:fullDetail
"trace execution of aBlock."
traceDetail := fullDetail.
ObjectMemory stepInterruptHandler:self.
^ [
ObjectMemory flushInlineCaches.
StepInterruptPending := 1.
InterruptPending := 1.
aBlock value
] valueNowOrOnUnwindDo:[
StepInterruptPending := nil.
ObjectMemory stepInterruptHandler:nil.
]
"
MessageTracer trace:[#(6 5 4 3 2 1) sort] detail:false
MessageTracer trace:[#(6 5 4 3 2 1) sort] detail:true
"
! !
!MessageTracer class methodsFor:'documentation'!
version
^ '$Header: /cvs/stx/stx/libbasic3/Attic/MsgTracer.st,v 1.43 1996-09-10 18:08:29 cg Exp $'
! !
MessageTracer initialize!