debug.tcl

windows下的GDB insight前端

# -----------------------------------------------------------------------------
# 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
# ----------------------------------------------------------------------------