You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
766 lines
21 KiB
Tcl
766 lines
21 KiB
Tcl
15 years ago
|
# -----------------------------------------------------------------------------
|
||
|
|
# NAME:
|
||
|
|
# ::debug
|
||
|
|
#
|
||
|
|
# DESC:
|
||
|
|
# This namespace implements general-purpose debugging functions
|
||
|
|
# to display information as a program runs. In addition, it
|
||
|
|
# includes profiling (derived from Sage 1.1) and tracing. For
|
||
|
|
# output it can write to files, stdout, or use a debug output
|
||
|
|
# window.
|
||
|
|
#
|
||
|
|
# NOTES:
|
||
|
|
# Output of profiler is compatible with sageview.
|
||
|
|
#
|
||
|
|
# -----------------------------------------------------------------------------
|
||
|
|
|
||
|
|
package provide debug 1.0
|
||
|
|
|
||
|
|
namespace eval ::debug {
|
||
|
|
namespace export debug dbug
|
||
|
|
variable VERSION 1.1
|
||
|
|
variable absolute
|
||
|
|
variable stack ""
|
||
|
|
variable outfile "trace.out"
|
||
|
|
variable watch 0
|
||
|
|
variable watchstart 0
|
||
|
|
variable debugwin ""
|
||
|
|
variable tracedVars
|
||
|
|
variable logfile ""
|
||
|
|
variable initialized 0
|
||
|
|
variable stoptrace 0
|
||
|
|
variable tracing 0
|
||
|
|
variable profiling 0
|
||
|
|
variable level 0
|
||
|
|
|
||
|
|
# here's where we'll store our collected profile data
|
||
|
|
namespace eval data {
|
||
|
|
variable entries
|
||
|
|
}
|
||
|
|
|
||
|
|
proc logfile {file} {
|
||
|
|
variable logfile
|
||
|
|
if {$logfile != "" && $logfile != "stdout" && $logfile != "stderr"} {
|
||
|
|
catch {close $logfile}
|
||
|
|
}
|
||
|
|
|
||
|
|
if {$file == ""} {
|
||
|
|
set logfile ""
|
||
|
|
} elseif {$file == "stdout" || $file == "stderr"} {
|
||
|
|
set logfile $file
|
||
|
|
} else {
|
||
|
|
set logfile [open $file w+]
|
||
|
|
fconfigure $logfile -buffering line -blocking 0
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# NAME: debug::trace_var
|
||
|
|
# SYNOPSIS: debug::trace_var {varName mode}
|
||
|
|
# DESC: Sets up variable trace. When the trace is activated,
|
||
|
|
# debugging messages will be displayed.
|
||
|
|
# ARGS: varName - the variable name
|
||
|
|
# mode - one of more of the following letters
|
||
|
|
# r - read
|
||
|
|
# w - write
|
||
|
|
# u - unset
|
||
|
|
# -----------------------------------------------------------------------------
|
||
|
|
proc trace_var {varName mode} {
|
||
|
|
variable tracedVars
|
||
|
|
lappend tracedVars [list $varName $mode]
|
||
|
|
uplevel \#0 trace variable $varName $mode ::debug::touched_by
|
||
|
|
}
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# NAME: debug::remove_trace
|
||
|
|
# SYNOPSIS: debug::remove_trace {var mode}
|
||
|
|
# DESC: Removes a trace set up with "trace_var".
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc remove_trace {var mode} {
|
||
|
|
uplevel \#0 trace vdelete $var $mode ::debug::touched_by
|
||
|
|
}
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# NAME: debug::remove_all_traces
|
||
|
|
# SYNOPSIS: debug::remove_all_traces
|
||
|
|
# DESC: Removes all traces set up with "trace_var".
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc remove_all_traces {} {
|
||
|
|
variable tracedVars
|
||
|
|
if {[info exists tracedVars]} {
|
||
|
|
foreach {elem} $tracedVars {
|
||
|
|
eval remove_trace $elem
|
||
|
|
}
|
||
|
|
unset tracedVars
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# NAME: debug::touched_by
|
||
|
|
# SYNOPSIS: debug::touched_by {v a m}
|
||
|
|
# DESC: Trace function used by trace_var. Currently writes standard
|
||
|
|
# debugging messages or priority "W".
|
||
|
|
# ARGS: v - variable
|
||
|
|
# a - array element or ""
|
||
|
|
# m - mode
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc touched_by {v a m} {
|
||
|
|
if {$a==""} {
|
||
|
|
upvar $v foo
|
||
|
|
dbug W "Variable $v touched in mode $m"
|
||
|
|
} else {
|
||
|
|
dbug W "Variable ${v}($a) touched in mode $m"
|
||
|
|
upvar $v($a) foo
|
||
|
|
}
|
||
|
|
dbug W "New value: $foo"
|
||
|
|
show_call_stack 2
|
||
|
|
}
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# NAME: debug::show_call_stack
|
||
|
|
# SYNOPSIS: debug::show_call_stack {{start_decr 0}}
|
||
|
|
# DESC: Function used by trace_var to print stack trace. Currently
|
||
|
|
# writes standard debugging messages or priority "W".
|
||
|
|
# ARGS: start_decr - how many levels to go up to start trace
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc show_call_stack {{start_decr 0}} {
|
||
|
|
set depth [expr {[info level] - $start_decr}]
|
||
|
|
if {$depth == 0} {
|
||
|
|
dbug W "Called at global scope"
|
||
|
|
} else {
|
||
|
|
dbug W "Stack Trace follows:"
|
||
|
|
for {set i $depth} {$i > 0} {incr i -1} {
|
||
|
|
dbug W "Level $i: [info level $i]"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# NAME: debug::createData
|
||
|
|
# SYNOPSIS: createData { name }
|
||
|
|
# DESC: Basically creates a data structure for storing profiling
|
||
|
|
# information about a function.
|
||
|
|
# ARGS: name - unique (full) function name
|
||
|
|
# -----------------------------------------------------------------------------
|
||
|
|
proc createData {name} {
|
||
|
|
lappend data::entries $name
|
||
|
|
|
||
|
|
namespace eval data::$name {
|
||
|
|
variable totaltimes 0
|
||
|
|
variable activetime 0
|
||
|
|
variable proccounts 0
|
||
|
|
variable timers 0
|
||
|
|
variable timerstart 0
|
||
|
|
variable nest 0
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
proc debugwin {obj} {
|
||
|
|
variable debugwin
|
||
|
|
set debugwin $obj
|
||
|
|
}
|
||
|
|
|
||
|
|
# -----------------------------------------------------------------------------
|
||
|
|
# NAME: debug::debug
|
||
|
|
#
|
||
|
|
# SYNOPSIS: debug { {msg ""} }
|
||
|
|
#
|
||
|
|
# DESC: Writes a message to the proper output. The priority of the
|
||
|
|
# message is assumed to be "I" (informational). This function
|
||
|
|
# is provided for compatibility with the previous debug function.
|
||
|
|
# For higher priority messages, use dbug.
|
||
|
|
#
|
||
|
|
# ARGS: msg - Message to be displayed.
|
||
|
|
# -----------------------------------------------------------------------------
|
||
|
|
|
||
|
|
proc debug {{msg ""}} {
|
||
|
|
set cls [string trimleft [uplevel namespace current] :]
|
||
|
|
if {$cls == ""} {
|
||
|
|
set cls "global"
|
||
|
|
}
|
||
|
|
|
||
|
|
set i [expr {[info level] - 1}]
|
||
|
|
if {$i > 0} {
|
||
|
|
set func [lindex [info level $i] 0]
|
||
|
|
set i [string first "::" $func]
|
||
|
|
if {$i != -1} {
|
||
|
|
# itcl proc has class prepended to func
|
||
|
|
# strip it off because we already have class in $cls
|
||
|
|
set func [string range $func [expr {$i+2}] end]
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
set func ""
|
||
|
|
}
|
||
|
|
|
||
|
|
::debug::_putdebug I $cls $func $msg
|
||
|
|
}
|
||
|
|
|
||
|
|
# -----------------------------------------------------------------------------
|
||
|
|
# NAME: debug::dbug
|
||
|
|
#
|
||
|
|
# SYNOPSIS: dbug { level msg }
|
||
|
|
#
|
||
|
|
# DESC: Writes a message to the proper output. Unlike debug, this
|
||
|
|
# function take a priority level.
|
||
|
|
#
|
||
|
|
# ARGS: msg - Message to be displayed.
|
||
|
|
# level - One of the following:
|
||
|
|
# "I" - Informational only
|
||
|
|
# "W" - Warning
|
||
|
|
# "E" - Error
|
||
|
|
# "X" - Fatal Error
|
||
|
|
# -----------------------------------------------------------------------------
|
||
|
|
proc dbug {level msg} {
|
||
|
|
set cls [string trimleft [uplevel namespace current] :]
|
||
|
|
if {$cls == ""} {
|
||
|
|
set cls "global"
|
||
|
|
}
|
||
|
|
|
||
|
|
set i [expr {[info level] - 1}]
|
||
|
|
if {$i > 0} {
|
||
|
|
set func [lindex [info level $i] 0]
|
||
|
|
} else {
|
||
|
|
set func ""
|
||
|
|
}
|
||
|
|
|
||
|
|
::debug::_putdebug $level $cls $func $msg
|
||
|
|
}
|
||
|
|
|
||
|
|
# -----------------------------------------------------------------------------
|
||
|
|
# NAME: debug::_putdebug
|
||
|
|
#
|
||
|
|
# SYNOPSIS: _putdebug { level cls func msg }
|
||
|
|
#
|
||
|
|
# DESC: Writes a message to the proper output. Will write to a debug
|
||
|
|
# window if one is defined. Otherwise will write to stdout.
|
||
|
|
#
|
||
|
|
# ARGS: msg - Message to be displayed.
|
||
|
|
# cls - name of calling itcl class or "global"
|
||
|
|
# func - name of calling function
|
||
|
|
# level - One of the following:
|
||
|
|
# "I" - Informational only
|
||
|
|
# "W" - Warning
|
||
|
|
# "E" - Error
|
||
|
|
# "X" - Fatal Error
|
||
|
|
# -----------------------------------------------------------------------------
|
||
|
|
proc _putdebug {lev cls func msg} {
|
||
|
|
variable debugwin
|
||
|
|
variable logfile
|
||
|
|
if {$debugwin != ""} {
|
||
|
|
$debugwin puts $lev $cls $func $msg
|
||
|
|
}
|
||
|
|
if {$logfile == "stdout"} {
|
||
|
|
if {$func != ""} { append cls ::$func }
|
||
|
|
puts $logfile "$lev: ($cls) $msg"
|
||
|
|
} elseif {$logfile != ""} {
|
||
|
|
puts $logfile [concat [list $lev] [list $cls] [list $func] [list $msg]]
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
proc _puttrace {enter lev func {ar ""}} {
|
||
|
|
variable debugwin
|
||
|
|
variable logfile
|
||
|
|
variable stoptrace
|
||
|
|
variable tracing
|
||
|
|
|
||
|
|
if {!$tracing} { return }
|
||
|
|
|
||
|
|
set func [string trimleft $func :]
|
||
|
|
if {$func == "DebugWin::put_trace" || $func == "DebugWin::_buildwin"} {
|
||
|
|
if {$enter} {
|
||
|
|
incr stoptrace
|
||
|
|
} else {
|
||
|
|
incr stoptrace -1
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
if {$stoptrace == 0} {
|
||
|
|
incr stoptrace
|
||
|
|
# strip off leading function name
|
||
|
|
set ar [lrange $ar 1 end]
|
||
|
|
if {$debugwin != ""} {
|
||
|
|
$debugwin put_trace $enter $lev $func $ar
|
||
|
|
}
|
||
|
|
|
||
|
|
if {$logfile != ""} {
|
||
|
|
puts $logfile [concat {T} [list $enter] [list $lev] [list $func] \
|
||
|
|
[list $ar]]
|
||
|
|
}
|
||
|
|
incr stoptrace -1
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# -----------------------------------------------------------------------------
|
||
|
|
# NAME: debug::init
|
||
|
|
# SYNOPSIS: init
|
||
|
|
# DESC: Installs hooks in all procs and methods to enable profiling
|
||
|
|
# and tracing.
|
||
|
|
# NOTES: Installing these hooks slows loading of the program. Running
|
||
|
|
# with the hooks installed will cause significant slowdown of
|
||
|
|
# program execution.
|
||
|
|
# -----------------------------------------------------------------------------
|
||
|
|
proc init {} {
|
||
|
|
variable VERSION
|
||
|
|
variable absolute
|
||
|
|
variable initialized
|
||
|
|
|
||
|
|
# create the arrays for the .global. level
|
||
|
|
createData .global.
|
||
|
|
|
||
|
|
# start the absolute timer
|
||
|
|
set absolute [clock clicks]
|
||
|
|
|
||
|
|
# rename waits, exit, and all the ways of declaring functions
|
||
|
|
rename ::vwait ::original_vwait
|
||
|
|
interp alias {} ::vwait {} [namespace current]::sagevwait
|
||
|
|
createData .wait.
|
||
|
|
|
||
|
|
rename ::tkwait ::original_tkwait
|
||
|
|
interp alias {} ::tkwait {} [namespace current]::sagetkwait
|
||
|
|
|
||
|
|
rename ::exit ::original_exit
|
||
|
|
interp alias {} ::exit {} [namespace current]::sageexit
|
||
|
|
|
||
|
|
rename ::proc ::original_proc
|
||
|
|
interp alias {} ::proc {} [namespace current]::sageproc
|
||
|
|
|
||
|
|
rename ::itcl::parser::method ::original_method
|
||
|
|
interp alias {} ::itcl::parser::method {} [namespace current]::sagemethod
|
||
|
|
|
||
|
|
rename ::itcl::parser::proc ::original_itclproc
|
||
|
|
interp alias {} ::itcl::parser::proc {} [namespace current]::sageitclproc
|
||
|
|
|
||
|
|
rename ::body ::original_itclbody
|
||
|
|
interp alias {} ::body {} [namespace current]::sageitclbody
|
||
|
|
|
||
|
|
# redefine core procs
|
||
|
|
# foreach p [uplevel \#0 info procs] {
|
||
|
|
# set args ""
|
||
|
|
# set default ""
|
||
|
|
# # get the list of args (some could be defaulted)
|
||
|
|
# foreach arg [info args $p] {
|
||
|
|
# if { [info default $p $arg default] } {
|
||
|
|
# lappend args [list $arg $default]
|
||
|
|
# } else {
|
||
|
|
# lappend args $arg
|
||
|
|
# }
|
||
|
|
# }
|
||
|
|
# uplevel \#0 proc [list $p] [list $args] [list [info body $p]]
|
||
|
|
#}
|
||
|
|
|
||
|
|
set initialized 1
|
||
|
|
resetWatch 0
|
||
|
|
procEntry .global.
|
||
|
|
startWatch
|
||
|
|
}
|
||
|
|
|
||
|
|
# -----------------------------------------------------------------------------
|
||
|
|
# NAME: ::debug::trace_start
|
||
|
|
# SYNOPSIS: ::debug::trace_start
|
||
|
|
# DESC: Starts logging of function trace information.
|
||
|
|
# -----------------------------------------------------------------------------
|
||
|
|
proc trace_start {} {
|
||
|
|
variable tracing
|
||
|
|
set tracing 1
|
||
|
|
}
|
||
|
|
|
||
|
|
# -----------------------------------------------------------------------------
|
||
|
|
# NAME: ::debug::trace_stop
|
||
|
|
# SYNOPSIS: ::debug::trace_stop
|
||
|
|
# DESC: Stops logging of function trace information.
|
||
|
|
# -----------------------------------------------------------------------------
|
||
|
|
proc trace_stop {} {
|
||
|
|
variable tracing
|
||
|
|
set tracing 0
|
||
|
|
}
|
||
|
|
|
||
|
|
# -----------------------------------------------------------------------------
|
||
|
|
# NAME: debug::sagetkwait
|
||
|
|
# SYNOPSIS: sagetkwait {args}
|
||
|
|
# DESC: A wrapper function around tkwait so we know how much time the
|
||
|
|
# program is spending in the wait state.
|
||
|
|
# ARGS: args - args to pass to tkwait
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc sagetkwait {args} {
|
||
|
|
# simulate going into the .wait. proc
|
||
|
|
stopWatch
|
||
|
|
procEntry .wait.
|
||
|
|
startWatch
|
||
|
|
uplevel ::original_tkwait $args
|
||
|
|
# simulate the exiting of this proc
|
||
|
|
stopWatch
|
||
|
|
procExit .wait.
|
||
|
|
startWatch
|
||
|
|
}
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# NAME: debug::sagevwait
|
||
|
|
# SYNOPSIS: sagevwait {args}
|
||
|
|
# DESC: A wrapper function around vwait so we know how much time the
|
||
|
|
# program is spending in the wait state.
|
||
|
|
# ARGS: args - args to pass to vwait
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc sagevwait {args} {
|
||
|
|
# simulate going into the .wait. proc
|
||
|
|
stopWatch
|
||
|
|
procEntry .wait.
|
||
|
|
startWatch
|
||
|
|
uplevel ::original_vwait $args
|
||
|
|
# simulate the exiting of this proc
|
||
|
|
stopWatch
|
||
|
|
procExit .wait.
|
||
|
|
startWatch
|
||
|
|
}
|
||
|
|
|
||
|
|
# -----------------------------------------------------------------------------
|
||
|
|
# NAME: debug::sageexit
|
||
|
|
# SYNOPSIS: sageexit {{value 0}}
|
||
|
|
# DESC: A wrapper function around exit so we can turn off profiling
|
||
|
|
# and tracing before exiting.
|
||
|
|
# ARGS: value - value to pass to exit
|
||
|
|
# -----------------------------------------------------------------------------
|
||
|
|
proc sageexit {{value 0}} {
|
||
|
|
variable program_name GDBtk
|
||
|
|
variable program_args ""
|
||
|
|
variable absolute
|
||
|
|
|
||
|
|
# stop the stopwatch
|
||
|
|
stopWatch
|
||
|
|
|
||
|
|
set totaltime [getWatch]
|
||
|
|
|
||
|
|
# stop the absolute timer
|
||
|
|
set stop [clock clicks]
|
||
|
|
|
||
|
|
# unwind the stack and turn off everyone's timers
|
||
|
|
stackUnwind
|
||
|
|
|
||
|
|
# disengage the proc callbacks
|
||
|
|
::original_proc procEntry {name} {}
|
||
|
|
::original_proc procExit {name args} {}
|
||
|
|
::original_proc methodEntry {name} {}
|
||
|
|
::original_proc methodExit {name args} {}
|
||
|
|
|
||
|
|
set absolute [expr {$stop - $absolute}]
|
||
|
|
|
||
|
|
# get the sage overhead time
|
||
|
|
set sagetime [expr {$absolute - $totaltime}]
|
||
|
|
|
||
|
|
# save the data
|
||
|
|
variable outfile
|
||
|
|
variable VERSION
|
||
|
|
set f [open $outfile w]
|
||
|
|
puts $f "set VERSION {$VERSION}"
|
||
|
|
puts $f "set program_name {$program_name}"
|
||
|
|
puts $f "set program_args {$program_args}"
|
||
|
|
puts $f "set absolute $absolute"
|
||
|
|
puts $f "set sagetime $sagetime"
|
||
|
|
puts $f "set totaltime $totaltime"
|
||
|
|
|
||
|
|
foreach procname $data::entries {
|
||
|
|
set totaltimes($procname) [set data::${procname}::totaltimes]
|
||
|
|
set proccounts($procname) [set data::${procname}::proccounts]
|
||
|
|
set timers($procname) [set data::${procname}::timers]
|
||
|
|
}
|
||
|
|
|
||
|
|
puts $f "array set totaltimes {[array get totaltimes]}"
|
||
|
|
puts $f "array set proccounts {[array get proccounts]}"
|
||
|
|
puts $f "array set timers {[array get timers]}"
|
||
|
|
close $f
|
||
|
|
original_exit $value
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
proc sageproc {name args body} {
|
||
|
|
# stop the watch
|
||
|
|
stopWatch
|
||
|
|
|
||
|
|
# update the name to include the namespace if it doesn't have one already
|
||
|
|
if {[string range $name 0 1] != "::"} {
|
||
|
|
# get the namespace this proc is being defined in
|
||
|
|
set ns [uplevel namespace current]
|
||
|
|
if { $ns == "::" } {
|
||
|
|
set ns ""
|
||
|
|
}
|
||
|
|
set name ${ns}::$name
|
||
|
|
}
|
||
|
|
|
||
|
|
createData $name
|
||
|
|
# create the callbacks for proc entry and exit
|
||
|
|
set ns [namespace current]
|
||
|
|
set extra "${ns}::stopWatch;"
|
||
|
|
append extra "set __.__ {};trace variable __.__ u {${ns}::stopWatch;${ns}::procExit $name;${ns}::startWatch};"
|
||
|
|
append extra "[namespace current]::procEntry $name;"
|
||
|
|
append extra "[namespace current]::startWatch;"
|
||
|
|
|
||
|
|
set args [list $args]
|
||
|
|
set body [list [concat $extra $body]]
|
||
|
|
|
||
|
|
startWatch
|
||
|
|
|
||
|
|
# define the proc with our extra stuff snuck in
|
||
|
|
uplevel ::original_proc $name $args $body
|
||
|
|
}
|
||
|
|
|
||
|
|
proc sageitclbody {name args body} {
|
||
|
|
# stop the watch
|
||
|
|
stopWatch
|
||
|
|
|
||
|
|
if {$name == "iwidgets::Scrolledwidget::_scrollWidget"} {
|
||
|
|
# Hack. This causes too many problems for the scrolled debug window
|
||
|
|
# so just don't include it in the profile functions.
|
||
|
|
uplevel ::original_itclbody $name [list $args] [list $body]
|
||
|
|
return
|
||
|
|
}
|
||
|
|
|
||
|
|
set fullname $name
|
||
|
|
# update the name to include the namespace if it doesn't have one already
|
||
|
|
if {[string range $name 0 1] != "::"} {
|
||
|
|
# get the namespace this proc is being defined in
|
||
|
|
set ns [uplevel namespace current]
|
||
|
|
if { $ns == "::" } {
|
||
|
|
set ns ""
|
||
|
|
}
|
||
|
|
set fullname ${ns}::$name
|
||
|
|
}
|
||
|
|
|
||
|
|
createData $fullname
|
||
|
|
# create the callbacks for proc entry and exit
|
||
|
|
set ns [namespace current]
|
||
|
|
set extra "${ns}::stopWatch;"
|
||
|
|
append extra "set __.__ {};trace variable __.__ u {${ns}::stopWatch;${ns}::procExit $fullname;${ns}::startWatch};"
|
||
|
|
append extra "[namespace current]::procEntry $fullname;"
|
||
|
|
append extra "[namespace current]::startWatch;"
|
||
|
|
|
||
|
|
set args [list $args]
|
||
|
|
set body [list [concat $extra $body]]
|
||
|
|
|
||
|
|
startWatch
|
||
|
|
|
||
|
|
# define the proc with our extra stuff snuck in
|
||
|
|
uplevel ::original_itclbody $name $args $body
|
||
|
|
}
|
||
|
|
|
||
|
|
proc sageitclproc {name args} {
|
||
|
|
# stop the watch
|
||
|
|
stopWatch
|
||
|
|
|
||
|
|
set body [lindex $args 1]
|
||
|
|
set args [lindex $args 0]
|
||
|
|
|
||
|
|
if {$body == ""} {
|
||
|
|
set args [list $args]
|
||
|
|
set args [concat $args $body]
|
||
|
|
} else {
|
||
|
|
# create the callbacks for proc entry and exit
|
||
|
|
set ns [namespace current]
|
||
|
|
set extra "${ns}::stopWatch;"
|
||
|
|
append extra "set __.__ {};trace variable __.__ u {${ns}::stopWatch;${ns}::methodExit $name;${ns}::startWatch};"
|
||
|
|
append extra "[namespace current]::methodEntry $name;"
|
||
|
|
append extra "[namespace current]::startWatch;"
|
||
|
|
|
||
|
|
set args [list $args [concat $extra $body]]
|
||
|
|
}
|
||
|
|
|
||
|
|
startWatch
|
||
|
|
uplevel ::original_itclproc $name $args
|
||
|
|
}
|
||
|
|
|
||
|
|
proc sagemethod {name args} {
|
||
|
|
# stop the watch
|
||
|
|
stopWatch
|
||
|
|
|
||
|
|
set body [lindex $args 1]
|
||
|
|
set args [lindex $args 0]
|
||
|
|
|
||
|
|
if {[string index $body 0] == "@" || $body == ""} {
|
||
|
|
set args [list $args]
|
||
|
|
set args [concat $args $body]
|
||
|
|
} else {
|
||
|
|
# create the callbacks for proc entry and exit
|
||
|
|
set ns [namespace current]
|
||
|
|
set extra "${ns}::stopWatch;"
|
||
|
|
append extra "set __.__ {};trace variable __.__ u {${ns}::stopWatch;${ns}::methodExit $name;${ns}::startWatch};"
|
||
|
|
append extra "[namespace current]::methodEntry $name;"
|
||
|
|
append extra "[namespace current]::startWatch;"
|
||
|
|
|
||
|
|
set args [list $args [concat $extra $body]]
|
||
|
|
}
|
||
|
|
|
||
|
|
startWatch
|
||
|
|
uplevel ::original_method $name $args
|
||
|
|
}
|
||
|
|
|
||
|
|
proc push {v} {
|
||
|
|
variable stack
|
||
|
|
variable level
|
||
|
|
lappend stack $v
|
||
|
|
incr level
|
||
|
|
}
|
||
|
|
|
||
|
|
proc pop {} {
|
||
|
|
variable stack
|
||
|
|
variable level
|
||
|
|
set v [lindex $stack end]
|
||
|
|
set stack [lreplace $stack end end]
|
||
|
|
incr level -1
|
||
|
|
return $v
|
||
|
|
}
|
||
|
|
|
||
|
|
proc look {} {
|
||
|
|
variable stack
|
||
|
|
return [lindex $stack end]
|
||
|
|
}
|
||
|
|
|
||
|
|
proc stackUnwind {} {
|
||
|
|
# Now unwind all the stacked procs by calling procExit on each.
|
||
|
|
# It is OK to use procExit on methods because the full name
|
||
|
|
# was pushed on the stack
|
||
|
|
while { [set procname [look]] != "" } {
|
||
|
|
procExit $procname
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# we need args because this is part of a trace callback
|
||
|
|
proc startWatch {args} {
|
||
|
|
variable watchstart
|
||
|
|
set watchstart [clock clicks]
|
||
|
|
}
|
||
|
|
|
||
|
|
proc resetWatch {value} {
|
||
|
|
variable watch
|
||
|
|
set watch $value
|
||
|
|
}
|
||
|
|
|
||
|
|
proc stopWatch {} {
|
||
|
|
variable watch
|
||
|
|
variable watchstart
|
||
|
|
set watch [expr {$watch + ([clock clicks] - $watchstart)}]
|
||
|
|
return $watch
|
||
|
|
}
|
||
|
|
|
||
|
|
proc getWatch {} {
|
||
|
|
variable watch
|
||
|
|
return $watch
|
||
|
|
}
|
||
|
|
|
||
|
|
proc startTimer {v} {
|
||
|
|
if { $v != "" } {
|
||
|
|
set data::${v}::timerstart [getWatch]
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
proc stopTimer {v} {
|
||
|
|
if { $v == "" } return
|
||
|
|
set stop [getWatch]
|
||
|
|
set data::${v}::timers [expr {[set data::${v}::timers] + ($stop - [set data::${v}::timerstart])}]
|
||
|
|
}
|
||
|
|
|
||
|
|
proc procEntry {procname} {
|
||
|
|
variable level
|
||
|
|
_puttrace 1 $level $procname [uplevel info level [uplevel info level]]
|
||
|
|
|
||
|
|
set time [getWatch]
|
||
|
|
|
||
|
|
# stop the timer of the caller
|
||
|
|
set caller [look]
|
||
|
|
stopTimer $caller
|
||
|
|
|
||
|
|
incr data::${procname}::proccounts
|
||
|
|
|
||
|
|
if { [set data::${procname}::nest] == 0 } {
|
||
|
|
set data::${procname}::activetime $time
|
||
|
|
}
|
||
|
|
incr data::${procname}::nest
|
||
|
|
|
||
|
|
# push this proc on the stack
|
||
|
|
push $procname
|
||
|
|
|
||
|
|
# start the timer for this
|
||
|
|
startTimer $procname
|
||
|
|
}
|
||
|
|
|
||
|
|
proc methodEntry {procname} {
|
||
|
|
variable level
|
||
|
|
|
||
|
|
set time [getWatch]
|
||
|
|
|
||
|
|
# stop the timer of the caller
|
||
|
|
set caller [look]
|
||
|
|
stopTimer $caller
|
||
|
|
|
||
|
|
# get the namespace this method is in
|
||
|
|
set ns [uplevel namespace current]
|
||
|
|
if { $ns == "::" } {
|
||
|
|
set ns ""
|
||
|
|
}
|
||
|
|
set name ${ns}::$procname
|
||
|
|
_puttrace 1 $level $name [uplevel info level [uplevel info level]]
|
||
|
|
|
||
|
|
if {![info exists data::${name}::proccounts]} {
|
||
|
|
createData $name
|
||
|
|
}
|
||
|
|
|
||
|
|
incr data::${name}::proccounts
|
||
|
|
|
||
|
|
if { [set data::${name}::nest] == 0 } {
|
||
|
|
set data::${name}::activetime $time
|
||
|
|
}
|
||
|
|
incr data::${name}::nest
|
||
|
|
|
||
|
|
# push this proc on the stack
|
||
|
|
push $name
|
||
|
|
|
||
|
|
# start the timer for this
|
||
|
|
startTimer $name
|
||
|
|
}
|
||
|
|
|
||
|
|
# we need the args because this is called from a vartrace handler
|
||
|
|
proc procExit {procname args} {
|
||
|
|
variable level
|
||
|
|
|
||
|
|
set time [getWatch]
|
||
|
|
# stop the timer of the proc
|
||
|
|
stopTimer [pop]
|
||
|
|
|
||
|
|
_puttrace 0 $level $procname
|
||
|
|
|
||
|
|
set r [incr data::${procname}::nest -1]
|
||
|
|
if { $r == 0 } {
|
||
|
|
set data::${procname}::totaltimes \
|
||
|
|
[expr {[set data::${procname}::totaltimes] \
|
||
|
|
+ ($time - [set data::${procname}::activetime])}]
|
||
|
|
}
|
||
|
|
|
||
|
|
# now restart the timer of the caller
|
||
|
|
startTimer [look]
|
||
|
|
}
|
||
|
|
|
||
|
|
proc methodExit {procname args} {
|
||
|
|
variable level
|
||
|
|
|
||
|
|
set time [getWatch]
|
||
|
|
# stop the timer of the proc
|
||
|
|
stopTimer [pop]
|
||
|
|
|
||
|
|
# get the namespace this method is in
|
||
|
|
set ns [uplevel namespace current]
|
||
|
|
if { $ns == "::" } {
|
||
|
|
set ns ""
|
||
|
|
}
|
||
|
|
set procname ${ns}::$procname
|
||
|
|
|
||
|
|
_puttrace 0 $level $procname
|
||
|
|
|
||
|
|
set r [incr data::${procname}::nest -1]
|
||
|
|
if { $r == 0 } {
|
||
|
|
set data::${procname}::totaltimes \
|
||
|
|
[expr {[set data::${procname}::totaltimes] \
|
||
|
|
+ ($time - [set data::${procname}::activetime])}]
|
||
|
|
}
|
||
|
|
|
||
|
|
# now restart the timer of the caller
|
||
|
|
startTimer [look]
|
||
|
|
}
|
||
|
|
}
|