debug.tcl

windows下的GDB insight前端

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