George Peter Staplin Dec 28, 2005 - I wanted the ability to profile my whole program without wrapping many commands with time, so I created a version of proc that logs the time. The cost of the logging and tracing[L1 ] increases the time, but it seems to be a good way to find hot spots in a program.
# By George Peter Staplin
# Dec 2005
array set ::debug_state {}
proc debug_callback {args} {
global debug_state
set proc [lindex [lindex $args 0] 0]
set type [lindex $args end]
if {"enter" eq $type} {
set debug_state($proc) [clock clicks]
} else {
set end [clock clicks]
set fd [open $::debug_log_file a]
#catches to stop failure during recursive calls - !todo: proper handling of recursion
catch {puts $fd "$proc took: [expr {$end - $::debug_state($proc)}]"}
close $fd
catch {unset debug_state($proc)}
}
}
proc debug_trace cmd {
trace add execution $cmd enter debug_callback
trace add execution $cmd leave debug_callback
}
set ::debug_log_file debug.log
rename proc _proc
_proc proc {name arglist body} {
if {![string match ::* $name]} {
#not already an 'absolute' namespace path
#qualify it so that traces can find it
set name [uplevel 1 namespace current]::[set name]
}
_proc $name $arglist $body
debug_trace $name
}Possible future improvements might include keeping a log of the entire runtime, and then averaging the runtime by the number of calls. I however didn't need that for my usage, because I was killing the program with ^C. :)
JMN 2005-12-30 - Added kludgy 'catch' statements around ::debug_state array access so that recursive calls to a proc don't stop the program. Also replaced the _proc procedure with a version that works for creating procedures in 'other' namespaces. e.g The following script would fail before:
namespace eval ::a {}
namespace eval ::b {proc ::a::myproc {} {return a-myproc}}
OLD VERSION:
_proc proc {name arglist body} {
set ns [uplevel 1 namespace current]
set p [set ns]::[set name]
_proc $p $arglist $body
debug_trace $p
}George Peter Staplin Dec 30, 2005 - Thank you JMN. You have given me some ideas for improvements that would handle recursion in a better manner. I will most likely post a followup to this code based on your improvements later.
Barney Blankenship June 15, 2006 - Thanks George, and JMN, here is my contribution:
#================================================================= # TIME PROFILER # by Barney Blankenship (based on work by George Peter Staplin) # # Insert this snippet above the function definitions you want # to have profiled. Note: I use "if { true } # # TO INITIALIZE OR CLEAR/RESET THE PROFILER... # global TimeProfilerMode # if { info exists TimeProfilerMode } { # global ProfilerArray # array unset ProfilerArray # } # # TO PRODUCE THE OUTPUT (currently hard-coded to "TimingDump.txt" # file output "append" in the current working directory)... # global TimeProfilerMode # if { info exists TimeProfilerMode } { # TimeProfilerDump description # } # (description: text string shown at the top of the output) # # PROFILING DATA COLLECTION # (This describes what is included in the output) # Provides total elapsed time in milliseconds between reset and dump. # Provides function call statistics... # for each function defined after this snippet, provide... # Number of times called # Average milliseconds per call # Total milliseconds used # Ratio of above to total elapsed time (XX.XXX percent) # In addition, the function call statistics are sorted # in descending values of Ratio (above). # # TO DISABLE PROFILING WITHOUT REMOVING THE PROFILER # Comment out the "set TimeProfilerMode 0" below... #================================================================= global TimeProfilerMode #set TimeProfilerMode 0
if { info exists TimeProfilerMode } {
proc TimeProfiler {args} {
global ProfilerArray
# Intialize the elapsed time counters if needed...
if { ![info exists ProfilerArray(ElapsedClicks)] } {
set ProfilerArray(ElapsedClicks) [expr double([clock clicks])]
set ProfilerArray(Elapsedms) [expr double([clock clicks -milliseconds])]
}
set fun [lindex [lindex $args 0] 0]
if { [lindex $args end] == "enter" } {
# Initalize the count of functions if needed...
if { ![info exists ProfilerArray(funcount)] } {
set ProfilerArray(funcount) 0
}
# See if this function is here for the first time...
for { set fi 0 } { $fi < $ProfilerArray(funcount) } { incr fi } {
if { [string equal $ProfilerArray($fi) $fun] } {
break
}
}
if { $fi == $ProfilerArray(funcount) } {
# Yes, function first time visit, add...
set ProfilerArray($fi) $fun
set ProfilerArray(funcount) [expr $fi + 1]
}
# Intialize the "EnterStack" if needed...
if { ![info exists ProfilerArray(ES0)] } {
set esi 1
} else {
set esi [expr $ProfilerArray(ES0) + 1]
}
# Append a "enter clicks" and "enter function name index" to the EnterStack...
set ProfilerArray(ES0) $esi
set ProfilerArray(ES$esi) [clock clicks]
# Note: the above is last thing done so timing start is closest to
# function operation start as possible.
} else {
# Right away stop timing...
set deltaclicks [clock clicks]
# Do not bother if TimeProfilerDump wiped the ProfilerArray
# just prior to this "leave"...
if { [info exists ProfilerArray(ES0)] } {
# Pull an "enter clicks" off the EnterStack...
set esi $ProfilerArray(ES0)
set deltaclicks [expr $deltaclicks - $ProfilerArray(ES$esi)]
incr esi -1
set ProfilerArray(ES0) $esi
# Correct for recursion and nesting...
if { $esi } {
# Add our elapsed clicks to the previous stacked values to compensate...
for { set fix $esi } { $fix > 0 } { incr fix -1 } {
set ProfilerArray(ES$fix) [expr $ProfilerArray(ES$fix) + $deltaclicks]
}
}
# Intialize the delta clicks array if needed...
if { ![info exists ProfilerArray($fun,0)] } {
set cai 1
} else {
set cai [expr $ProfilerArray($fun,0) + 1]
}
# Add another "delta clicks" reading...
set ProfilerArray($fun,0) $cai
set ProfilerArray($fun,$cai) $deltaclicks
}
}
}
proc TimeProfilerDump {description} {
global ProfilerArray
# Stop timing elapsed time and calculate conversion factor for clicks to ms...
set EndClicks [expr {double([clock clicks]) - $ProfilerArray(ElapsedClicks)}]
set Endms [expr {double([clock clicks -milliseconds]) - $ProfilerArray(Elapsedms)}]
set msPerClick [expr $Endms / $EndClicks]
# Visit each function and generate the statistics for it...
for { set fi 0 ; set PerfList "" } { $fi < $ProfilerArray(funcount) } { incr fi } {
set fun $ProfilerArray($fi)
if { ![info exists ProfilerArray($fun,0)] } {
continue
}
for { set ctotal 0.0 ; set cai 1 } { $cai <= $ProfilerArray($fun,0) } { incr cai } {
set ctotal [expr {$ctotal + double($ProfilerArray($fun,$cai))}]
}
set cavg [expr {$ctotal / double($ProfilerArray($fun,0))}]
set ProfilerArray($fun,avgms) [expr $cavg * $msPerClick]
set ProfilerArray($fun,totalms) [expr $ctotal * $msPerClick]
set ProfilerArray($fun,ratio) [expr {double($ctotal / $EndClicks) * 100.0}]
# Append to the new list the pairs of ratio values and function indexes...
lappend PerfList [list $ProfilerArray($fun,ratio) $fi]
}
# Sort the profile data by Ratio...
set PerfList [lsort -real -decreasing -index 0 $PerfList]
# Finally, generate the results...
set fd [open "TimingDump.txt" a]
puts $fd "\n===================================================================="
puts $fd [format " T I M I N G D U M P <%s>" $description]
puts $fd [format "\n Elapsed time: %.0f ms" $Endms]
puts $fd "===================================================================="
for { set li 0 } { $li < [llength $PerfList] } { incr li } {
set fun $ProfilerArray([lindex [lindex $PerfList $li] 1])
puts $fd [format ">>>>> FUNCTION: %s" $fun]
puts $fd [format " CALLS: %d" $ProfilerArray($fun,0)]
puts $fd [format " AVG TIME: %.3f ms" $ProfilerArray($fun,avgms)]
puts $fd [format " TOTAL TIME: %.3f ms" $ProfilerArray($fun,totalms)]
puts $fd [format " RATIO: %.3f%c\n" $ProfilerArray($fun,ratio) 37]
}
close $fd
# Reset the world...
array unset ProfilerArray
}
#=================================================================
# Overload "proc" so that functions defined after
# this point have added trace handlers for entry and exit.
# [George Peter Staplin]
#=================================================================
rename proc _proc
_proc proc {name arglist body} {
#===================================
# Allow multiple namespace use [JMN]
if { ![string match ::* $name] } {
# Not already an 'absolute' namespace path,
# qualify it so that traces can find it...
set name [uplevel 1 namespace current]::[set name]
}
#===================================
_proc $name $arglist $body
trace add execution $name enter TimeProfiler
trace add execution $name leave TimeProfiler
}}
Category Performance | Category Debugging | Category Dev. Tools | Category Development