share/redhat/gui/debug.tcl

# -----------------------------------------------------------------------------
# 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])}]
    }
    
    # now restart the timer of the caller
    startTimer [look]
  }

  proc methodExit {procname args} {
    variable level

    set time [getWatch]
    # stop the timer of the proc
    stopTimer [pop]
    
    # get the namespace this method is in
    set ns [uplevel namespace current]
    if { $ns == "::" } {
      set ns ""
    }
    set procname ${ns}::$procname

    _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])}]
    }
    
    # now restart the timer of the caller
    startTimer [look]
  }
}