[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
 }

[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]