Subversion Repositories or1k

# -----------------------------------------------------------------------------

# 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])}]

    }