[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[http://www.tcl.tk/man/tcl8.4/TclCmd/trace.htm] 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
 }



----
[Category Performance] | [Category Debugging] | [Category Dev. Tools] | [Category Development]