home *** CD-ROM | disk | FTP | other *** search
/ H4CK3R 5 / hacker05 / 05_HACK_05.ISO / programacao / freewrap / TCLLIBsampleApp.exe / sample / tcllib / tcllib1.0 / profiler / profiler.tcl < prev   
Encoding:
Text File  |  2001-08-17  |  11.4 KB  |  446 lines
  1. # profiler.tcl --
  2. #
  3. #    Tcl code profiler.
  4. #
  5. # Copyright (c) 1998-2000 by Ajuba Solutions.
  6. #
  7. # See the file "license.terms" for information on usage and redistribution
  8. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  9. # 
  10. # RCS: @(#) $Id: profiler.tcl,v 1.16 2001/08/02 16:38:07 andreas_kupries Exp $
  11.  
  12. package require Tcl 8.3        ;# uses [clock clicks -milliseconds]
  13. package provide profiler 0.1
  14.  
  15. namespace eval ::profiler {
  16.     variable enabled 1
  17. }
  18.  
  19. # ::profiler::tZero --
  20. #
  21. #    Start a named timer instance
  22. #
  23. # Arguments:
  24. #    tag    name for the timer instance; if none is given, defaults to ""
  25. #
  26. # Results:
  27. #    None.
  28.  
  29. proc ::profiler::tZero { { tag "" } } {
  30.     set ms [ clock clicks -milliseconds ]
  31.     set us [ clock clicks ]
  32.     regsub -all -- {:} $tag {} tag
  33.     # FRINK: nocheck
  34.     set ::profiler::T$tag [ list $us $ms ] 
  35.     return
  36. }
  37.  
  38. # ::profiler::tMark --
  39. #
  40. #    Return the delta time since the start of a named timer.
  41. #
  42. # Arguments:
  43. #    tag    Tag for which to return a delta; if none is given, defaults to
  44. #        "" 
  45. #
  46. # Results:
  47. #    dt    Time difference between start of the timer and the current
  48. #        time, in microseconds.
  49.  
  50. proc ::profiler::tMark { { tag "" } } {
  51.      set ut [ clock clicks ]
  52.      set mt [ clock clicks -milliseconds ]
  53.      regsub -all -- {:} $tag {} tag
  54.  
  55.     # Per tag a variable was created within the profiler
  56.     # namespace. But we should check if the tag does ecxist.
  57.  
  58.     if {![info exists ::profiler::T$tag]} {
  59.     error "Unknown tag \"$tag\""
  60.     }
  61.     # FRINK: nocheck
  62.      set ust [ lindex [ set ::profiler::T$tag ] 0 ] 
  63.     # FRINK: nocheck
  64.      set mst [ lindex [ set ::profiler::T$tag ] 1 ]
  65.      set udt [ expr { ($ut-$ust) } ]
  66.      set mdt [ expr { ($mt-$mst) } ]000
  67.      set dt $udt
  68.      ;## handle wrapping of the microsecond clock
  69.      if { $dt < 0 || $dt > 1000000 } { set dt $mdt }
  70.      set dt
  71. }
  72.  
  73. # ::profiler::stats --
  74. #
  75. #    Compute statistical information for a set of values, including
  76. #    the mean, the standard deviation, and the covariance.
  77. #
  78. # Arguments:
  79. #    args    Values for which to compute information.
  80. #
  81. # Results:
  82. #    A list with three elements:  the mean, the standard deviation, and the
  83. #    covariance.
  84.  
  85. proc ::profiler::stats {args} {
  86.      set sum      0
  87.      set mean     0
  88.      set sigma_sq 0
  89.      set sigma    0
  90.      set cov      0
  91.      set N [ llength $args ]
  92.      if { $N > 1 } { 
  93.         foreach val $args {
  94.            set sum [ expr { $sum+$val } ]
  95.         }
  96.         set mean [ expr { $sum/$N } ]
  97.         foreach val $args {
  98.            set sigma_sq [ expr { $sigma_sq+pow(($val-$mean),2) } ]
  99.         }
  100.         set sigma_sq [ expr { $sigma_sq/($N-1) } ] 
  101.         set sigma [ expr { round(sqrt($sigma_sq)) } ]
  102.         set cov [ expr { (($sigma*1.0)/$mean)*100 } ]
  103.         set cov [ expr { round($cov*10)/10.0 } ]
  104.      }   
  105.      return [ list $mean $sigma $cov ]
  106. }
  107.  
  108. # ::profiler::Handler --
  109. #
  110. #    Profile a function.  This function works together with profProc, which
  111. #    replaces the proc command.  When a new procedure is defined, it creates
  112. #    and alias to this function; when that procedure is called, it calls
  113. #    this handler first, which gathers profiling information from the call.
  114. #
  115. # Arguments:
  116. #    name    name of the function to profile.
  117. #    args    arguments to pass to the original function.
  118. #
  119. # Results:
  120. #    res    result from the original function.
  121.  
  122. proc ::profiler::Handler {name args} {
  123.     variable enabled
  124.     if { $enabled } {
  125.     if { [info level] == 1 } {
  126.         set caller GLOBAL
  127.     } else {
  128.         # Get the name of the calling procedure
  129.         set caller [lindex [info level -1] 0]
  130.         # Remove the ORIG suffix
  131.         set caller [string range $caller 0 end-4]
  132.     }
  133.     if { [catch {incr ::profiler::callers($name,$caller)}] } {
  134.         set ::profiler::callers($name,$caller) 1
  135.     }
  136.     ::profiler::tZero $name.$caller
  137.     }
  138.  
  139.     set CODE [uplevel 1 [list ${name}ORIG] $args]
  140.     if { $enabled } {
  141.     set t [::profiler::tMark $name.$caller]
  142.     lappend ::profiler::statTime($name) $t
  143.  
  144.     if { [incr ::profiler::callCount($name)] == 1 } {
  145.         set ::profiler::compileTime($name) $t
  146.     }
  147.     incr ::profiler::totalRuntime($name) $t
  148.     if { [catch {incr ::profiler::descendantTime($caller) $t}] } {
  149.         set ::profiler::descendantTime($caller) $t
  150.     }
  151.     if { [catch {incr ::profiler::descendants($caller,$name)}] } {
  152.         set ::profiler::descendants($caller,$name) 1
  153.     }
  154.     }
  155.     return $CODE
  156. }
  157.  
  158. # ::profiler::profProc --
  159. #
  160. #    Replacement for the proc command that adds rudimentary profiling
  161. #    capabilities to Tcl.
  162. #
  163. # Arguments:
  164. #    name        name of the procedure
  165. #    arglist        list of arguments
  166. #    body        body of the procedure
  167. #
  168. # Results:
  169. #    None.
  170.  
  171. proc ::profiler::profProc {name arglist body} {
  172.     variable callCount
  173.     variable compileTime
  174.     variable totalRuntime
  175.     variable descendantTime
  176.     variable statTime
  177.     
  178.     # Get the fully qualified name of the proc
  179.     set ns [uplevel [list namespace current]]
  180.     # If the proc call did not happen at the global context and it did not
  181.     # have an absolute namespace qualifier, we have to prepend the current
  182.     # namespace to the command name
  183.     if { ![string equal $ns "::"] } {
  184.     if { ![regexp -- "^::" $name] } {
  185.         set name "${ns}::${name}"
  186.     }
  187.     }
  188.     if { ![regexp -- "^::" $name] } {
  189.     set name "::$name"
  190.     }
  191.  
  192.     # Set up accounting for this procedure
  193.     set callCount($name) 0
  194.     set compileTime($name) 0
  195.     set totalRuntime($name) 0
  196.     set descendantTime($name) 0
  197.     set statTime($name) {}
  198.  
  199.     uplevel 1 [list ::_oldProc ${name}ORIG $arglist $body]
  200.     uplevel 1 [list interp alias {} $name {} ::profiler::Handler $name]
  201.     return
  202. }
  203.  
  204. # ::profiler::init --
  205. #
  206. #    Initialize the profiler.
  207. #
  208. # Arguments:
  209. #    None.
  210. #
  211. # Results:
  212. #    None.  Renames proc to _oldProc and sets an alias for proc to 
  213. #        profiler::profProc
  214.  
  215. proc ::profiler::init {} {
  216.     rename ::proc ::_oldProc
  217.     interp alias {} proc {} ::profiler::profProc
  218.  
  219.     return
  220. }
  221.  
  222. # ::profiler::print --
  223. #
  224. #    Print information about a proc.
  225. #
  226. # Arguments:
  227. #    pattern    pattern of the proc's to get info for; default is *.
  228. #
  229. # Results:
  230. #    A human readable printout of info.
  231.  
  232. proc ::profiler::print {{pattern *}} {
  233.     variable callCount
  234.     variable compileTime
  235.     variable totalRuntime
  236.     variable descendantTime
  237.     variable descendants
  238.     variable statTime
  239.     variable callers
  240.     
  241.     set result ""
  242.     foreach name [lsort [array names callCount $pattern]] {
  243.     set avgRuntime 0
  244.     set sigmaRuntime 0
  245.     set covRuntime 0
  246.     set avgDesTime 0
  247.     if { $callCount($name) > 0 } {
  248.         foreach {m s c} [eval ::profiler::stats $statTime($name)] { break }
  249.         set avgRuntime   $m
  250.         set sigmaRuntime $s
  251.         set covRuntime   $c
  252.         set avgDesTime \
  253.             [expr {$descendantTime($name)/$callCount($name)}]
  254.     }
  255.  
  256.     append result "Profiling information for $name\n"
  257.     append result "[string repeat = 60]\n"
  258.     append result "            Total calls:  $callCount($name)\n"
  259.     if { !$callCount($name) } {
  260.         append result "\n"
  261.         continue
  262.     }
  263.     append result "    Caller distribution:\n"
  264.     set i [expr {[string length $name] + 1}]
  265.     foreach index [lsort [array names callers $name,*]] {
  266.         append result "  [string range $index $i end]:  $callers($index)\n"
  267.     }
  268.     append result "           Compile time:  $compileTime($name)\n"
  269.     append result "          Total runtime:  $totalRuntime($name)\n"
  270.     append result "        Average runtime:  $avgRuntime\n"
  271.     append result "          Runtime StDev:  $sigmaRuntime\n"
  272.     append result "         Runtime cov(%):  $covRuntime\n"
  273.     append result "  Total descendant time:  $descendantTime($name)\n"
  274.     append result "Average descendant time:  $avgDesTime\n"
  275.     append result "Descendants:\n"
  276.     if { !$descendantTime($name) } {
  277.         append result "  none\n"
  278.     }
  279.     foreach index [lsort [array names descendants $name,*]] {
  280.         append result "  [string range $index $i end]: \
  281.             $descendants($index)\n"
  282.     }
  283.     append result "\n"
  284.     }
  285.     return $result
  286. }
  287.  
  288. # ::profiler::dump --
  289. #
  290. #    Dump out the information for a proc in a big blob.
  291. #
  292. # Arguments:
  293. #    pattern    pattern of the proc's to lookup; default is *.
  294. #
  295. # Results:
  296. #    data    data about the proc's.
  297.  
  298. proc ::profiler::dump {{pattern *}} {
  299.     variable callCount
  300.     variable compileTime
  301.     variable totalRuntime
  302.     variable callers
  303.     variable descendantTime
  304.     variable descendants
  305.     variable statTime
  306.  
  307.     foreach name [lsort [array names callCount $pattern]] {
  308.     set i [expr {[string length $name] + 1}]
  309.     catch {unset thisCallers}
  310.     foreach index [lsort [array names callers $name,*]] {
  311.         set thisCallers([string range $index $i end]) $callers($index)
  312.     }
  313.     set avgRuntime 0
  314.     set sigmaRuntime 0
  315.     set covRuntime 0
  316.     set avgDesTime 0
  317.     if { $callCount($name) > 0 } {
  318.         foreach {m s c} [eval ::profiler::stats $statTime($name)] { break }
  319.         set avgRuntime   $m
  320.         set sigmaRuntime $s
  321.         set covRuntime   $c
  322.         set avgDesTime \
  323.             [expr {$descendantTime($name)/$callCount($name)}]
  324.     }
  325.     set descendantList [list ]
  326.     foreach index [lsort [array names descendants $name,*]] {
  327.         lappend descendantList [string range $index $i end]
  328.     }
  329.     lappend result $name [list callCount $callCount($name) \
  330.         callerDist [array get thisCallers] \
  331.         compileTime $compileTime($name) \
  332.         totalRuntime $totalRuntime($name) \
  333.         averageRuntime $avgRuntime \
  334.         stddevRuntime  $sigmaRuntime \
  335.         covpercentRuntime $covRuntime \
  336.         descendantTime $descendantTime($name) \
  337.         averageDescendantTime $avgDesTime \
  338.         descendants $descendantList]
  339.     }
  340.     return $result
  341. }
  342.  
  343. # ::profiler::sortFunctions --
  344. #
  345. #    Return a list of functions sorted by a particular field and the
  346. #    value of that field.
  347. #
  348. # Arguments:
  349. #    field    field to sort by
  350. #
  351. # Results:
  352. #    slist    sorted list of lists, sorted by the field in question.
  353.  
  354. proc ::profiler::sortFunctions {{field ""}} {
  355.     switch -glob -- $field {
  356.     "calls" {
  357.         upvar ::profiler::callCount data
  358.     }
  359.     "compileTime" {
  360.         upvar ::profiler::compileTime data
  361.     }
  362.     "totalRuntime" {
  363.         upvar ::profiler::totalRuntime data
  364.     }
  365.     "avgRuntime" -
  366.     "averageRuntime" {
  367.         variable callCount
  368.         variable totalRuntime
  369.         foreach fxn [array names callCount] {
  370.         if { $callCount($fxn) > 1 } {
  371.             set data($fxn) \
  372.                 [expr {$totalRuntime($fxn)/($callCount($fxn) - 1)}]
  373.         }
  374.         }
  375.     }
  376.     "exclusiveRuntime" {
  377.         variable totalRuntime
  378.         variable descendantTime
  379.         foreach fxn [array names totalRuntime] {
  380.         set data($fxn) \
  381.             [expr {$totalRuntime($fxn) - $descendantTime($fxn)}]
  382.         }
  383.     }
  384.     "avgExclusiveRuntime" {
  385.         variable totalRuntime
  386.         variable callCount
  387.         variable descendantTime
  388.         foreach fxn [array names totalRuntime] {
  389.         if { $callCount($fxn) } {
  390.             set data($fxn) \
  391.                 [expr {($totalRuntime($fxn) - \
  392.                 $descendantTime($fxn)) / $callCount($fxn)}]
  393.         }
  394.         }
  395.     }
  396.     "nonCompileTime" {
  397.         variable compileTime
  398.         variable totalRuntime
  399.         foreach fxn [array names totalRuntime] {
  400.         set data($fxn) [expr {$totalRuntime($fxn)-$compileTime($fxn)}]
  401.         }
  402.     }
  403.     default {
  404.         error "unknown statistic \"$field\": should be calls,\
  405.             compileTime, exclusiveRuntime, nonCompileTime,\
  406.             totalRuntime, avgExclusiveRuntime, or avgRuntime"
  407.     }
  408.     }
  409.         
  410.     set result [list ]
  411.     foreach fxn [array names data] {
  412.     lappend result [list $fxn $data($fxn)]
  413.     }
  414.     return [lsort -integer -index 1 $result]
  415. }
  416.  
  417. # ::profiler::reset --
  418. #
  419. #    Reset collected data for functions matching a given pattern.
  420. #
  421. # Arguments:
  422. #    pattern        pattern of functions to reset; default is *.
  423. #
  424. # Results:
  425. #    None.
  426.  
  427. proc ::profiler::reset {{pattern *}} {
  428.     variable callCount
  429.     variable compileTime
  430.     variable totalRuntime
  431.     variable callers
  432.     variable statTime
  433.  
  434.     foreach name [array names callCount $pattern] {
  435.     set callCount($name) 0
  436.     set compileTime($name) 0
  437.     set totalRuntime($name) 0
  438.     set statTime($name) {}
  439.     foreach caller [array names callers $name,*] {
  440.         unset callers($caller)
  441.     }
  442.     }
  443.     return
  444. }
  445.  
  446.