neingeist
/
arduinisten
Archived
1
0
Fork 0
You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
This repo is archived. You can view files and clone it, but cannot push or open issues/pull-requests.

766 lines
21 KiB
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]
}
}