1052 lines
34 KiB
Tcl
Executable File
1052 lines
34 KiB
Tcl
Executable File
#!/usr/bin/tclsh
|
|
#
|
|
|
|
# for Usage:
|
|
# latency-histogram --help | -?
|
|
|
|
#-----------------------------------------------------------------------
|
|
# Copyright: 2012-2016
|
|
# Author: Dewey Garrett <dgarrett@panix.com>
|
|
#
|
|
# This program is free software; you can redistribute it and/or modify
|
|
# it under the terms of the GNU General Public License as published by
|
|
# the Free Software Foundation; either version 2 of the License, or
|
|
# (at your option) any later version.
|
|
#
|
|
# This program is distributed in the hope that it will be useful,
|
|
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
# GNU General Public License for more details.
|
|
#
|
|
# You should have received a copy of the GNU General Public License
|
|
# along with this program; if not, write to the Free Software
|
|
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
|
|
#-----------------------------------------------------------------------
|
|
|
|
# Mu sign is Unicode 00b5
|
|
set ::MICROSEC \u00b5s
|
|
|
|
#-----------------------------------------------------------------------
|
|
# lh_chart canvas bar-chart widget (replaces BLT, which has no Tcl/Tk 9
|
|
# port). Shared with hal-histogram via the installed hallib directory.
|
|
#-----------------------------------------------------------------------
|
|
source [file join [exec linuxcnc_var HALLIB_DIR] lh_chart.tcl]
|
|
|
|
proc set_defaults {} {
|
|
set ::LH(start) [clock seconds]
|
|
# don't include glxgears, error suffices
|
|
program_check {halrun halcmd lsmod pgrep pkill hostname}
|
|
set ::LH(realtime) [exec linuxcnc_var REALTIME]
|
|
program_check $::LH(realtime)
|
|
if {[string first rtai [string tolower $::tcl_platform(osVersion)]] >=0} {
|
|
set ::LH(rtai) rtai
|
|
}
|
|
|
|
set ::LH(use_x) 1
|
|
set ::LH(verbose) 0
|
|
set ::LH(opt,show) 0
|
|
|
|
set name [file tail [file rootname $::argv0]]
|
|
# Default comp is latencybinstream (atomic snapshot via HAL stream).
|
|
# --legacy switches to the original latencybins comp, which has a
|
|
# known race: it transfers bins one cycle at a time so the snapshot
|
|
# is smeared across hundreds of ms and stats desync from bins.
|
|
set ::LH(legacy) 0
|
|
set ::LH(compname) latencybinstream
|
|
# Default screenshot dir: ~/Pictures (XDG standard) if it exists,
|
|
# else $HOME, else /tmp/$name. Save dialog lets user pick anyway.
|
|
set ::LH(dir,screenshot) ""
|
|
foreach cand [list \
|
|
[file join $::env(HOME) Pictures] \
|
|
$::env(HOME) \
|
|
/tmp/$name] {
|
|
if {[file isdirectory $cand] || ![catch {file mkdir $cand}]} {
|
|
set ::LH(dir,screenshot) $cand
|
|
break
|
|
}
|
|
}
|
|
if {$::LH(dir,screenshot) eq ""} { set ::LH(dir,screenshot) ~ }
|
|
|
|
set ::LH(note,txt) ""
|
|
set ::LH(date) [clock format [clock seconds] -format "%d%b%Y"]
|
|
|
|
set ::LH(y,logscale) 1
|
|
|
|
set ::LH(threads) {base servo}
|
|
|
|
set ::LH(base,name) base
|
|
set ::LH(servo,name) servo
|
|
|
|
set ::LH(base,color) seagreen
|
|
set ::LH(servo,color) blue
|
|
|
|
set ::LH(base,period,ns) 25000
|
|
set ::LH(servo,period,ns) 1000000
|
|
|
|
set ::LH(base,period,ns,min) 5000
|
|
set ::LH(servo,period,ns,min) 25000
|
|
|
|
set ::LH(base,binsize,ns) 100
|
|
set ::LH(servo,binsize,ns) 100
|
|
|
|
# must be integer for window naming and .comp file usage:
|
|
set ::LH(base,maxbins) 200
|
|
set ::LH(servo,maxbins) 200
|
|
|
|
set ::LH(base,p,more) 0
|
|
set ::LH(base,n,more) 0
|
|
set ::LH(servo,p,more) 0
|
|
set ::LH(serve,n,more) 0
|
|
|
|
set ::LH(after,repeat) ''
|
|
} ;# set_defaults
|
|
|
|
|
|
proc which_exe {name} {
|
|
# replaces /usr/bin/which deprecated in debian/unstable
|
|
foreach dir [split $::env(PATH) :] {
|
|
set f [file join $dir $name]
|
|
if [file executable $f] { return $f }
|
|
}
|
|
return -code error "$name: executable not found"
|
|
} ;# which_exe
|
|
|
|
proc program_check {plist} {
|
|
foreach prog $plist {
|
|
if [catch {
|
|
set ::LH(prog,$prog) [which_exe $prog]
|
|
} chkmsg] {
|
|
set msg "Cannot find required program named: <$prog>"
|
|
set msg "$msg\n\nIf Run-in-Place, source rip-environment first"
|
|
set msg "$msg\n\n$chkmsg"
|
|
popup $msg
|
|
exit 1
|
|
}
|
|
}
|
|
} ;# program_check
|
|
|
|
proc config {} {
|
|
while {[llength $::argv] >0} {
|
|
# beware wish handling of reserved cmdline arguments
|
|
# lreplace shifts argv for no. of items for each iteration
|
|
set currentarg [lindex $::argv 0]
|
|
switch -- $currentarg {
|
|
-? - --help {usage;exit 0}
|
|
--logscale {set t [lindex $::argv 1]
|
|
set ::LH(y,logscale) $t
|
|
set ::argv [lreplace $::argv 0 0]
|
|
}
|
|
--base {set t [lindex $::argv 1]
|
|
set ::LH(base,period,ns) $t
|
|
set ::argv [lreplace $::argv 0 0]
|
|
if {$::LH(base,period,ns)
|
|
< $::LH(base,period,ns,min)} {
|
|
puts "base period too small\
|
|
min=$::LH(base,period,ns,min)"
|
|
exit 1
|
|
}
|
|
}
|
|
--servo {set t [lindex $::argv 1]
|
|
set ::LH(servo,period,ns) $t
|
|
set ::argv [lreplace $::argv 0 0]
|
|
if {$::LH(servo,period,ns)
|
|
< $::LH(servo,period,ns,min)} {
|
|
puts "servo period too small\
|
|
min=$::LH(servo,period,ns,min)"
|
|
exit 1
|
|
}
|
|
}
|
|
--bbinsize {set t [lindex $::argv 1]
|
|
set ::LH(base,binsize,ns) $t
|
|
set ::argv [lreplace $::argv 0 0]
|
|
}
|
|
--sbinsize {set t [lindex $::argv 1]
|
|
set ::LH(servo,binsize,ns) $t
|
|
set ::argv [lreplace $::argv 0 0]
|
|
}
|
|
--sbins {set t [lindex $::argv 1]
|
|
set ::LH(servo,maxbins) $t
|
|
set ::argv [lreplace $::argv 0 0]
|
|
}
|
|
--bbins {set t [lindex $::argv 1]
|
|
set ::LH(base,maxbins) $t
|
|
set ::argv [lreplace $::argv 0 0]
|
|
}
|
|
--text {set t [lindex $::argv 1]
|
|
set ::LH(note,txt) $t
|
|
set ::argv [lreplace $::argv 0 0]
|
|
}
|
|
--nobase {set ::LH(threads) {servo}
|
|
}
|
|
--show {set ::LH(opt,show) 1
|
|
}
|
|
--verbose {set ::LH(verbose) 1
|
|
}
|
|
--nox {set ::LH(use_x) 0
|
|
}
|
|
--legacy {set ::LH(legacy) 1
|
|
set ::LH(compname) latencybins
|
|
}
|
|
default {lappend unknownargs $currentarg}
|
|
}
|
|
set ::argv [lreplace $::argv 0 0]
|
|
} ;# while
|
|
if [info exists unknownargs] {
|
|
puts "\nIgnoring unknown args: <$unknownargs>"
|
|
}
|
|
if {$::LH(base,period,ns) > $::LH(servo,period,ns)} {
|
|
popup "base period must be less than servo period"
|
|
exit 1
|
|
}
|
|
|
|
set ::LH(title) "$::argv0"
|
|
|
|
foreach thd $::LH(threads) {
|
|
# initial delay for reading by index
|
|
set ms [expr $::LH($thd,period,ns)/1000000]
|
|
if {$ms > 1} {
|
|
set ::LH($thd,dly,ms) $ms
|
|
} else {
|
|
set ::LH($thd,dly,ms) 1 ;# minimum interval (ms) for after cmd
|
|
}
|
|
|
|
if {[expr $::LH($thd,binsize,ns) % 10] != 0} {
|
|
puts "$::argv0: \[sb\]binsize must be multiple of 10 ns"
|
|
exit 1
|
|
}
|
|
|
|
# guard for lat32 limit of 2.147 sec
|
|
if {[expr $::LH($thd,binsize,ns) * $::LH($thd,maxbins)] > 2000000000} {
|
|
puts "Measurement interval too big for $thd thread"
|
|
puts "Reduce bins or increase binsize"
|
|
exit 1
|
|
}
|
|
|
|
# uS display only
|
|
set ::LH($thd,binsize,us) [expr ($::LH($thd,binsize,ns)/1000.)]
|
|
}
|
|
set ::LH(info) [other_info]
|
|
set ::LH(processor) [processor_info]
|
|
} ;# config
|
|
|
|
proc other_info {} {
|
|
if [info exists ::env(DISPLAY)] {
|
|
set display "DISPLAY=$::env(DISPLAY)"
|
|
} else {
|
|
set display "DISPLAY=?"
|
|
}
|
|
set linuxcncversion [exec linuxcnc_var LINUXCNCVERSION]
|
|
return "\
|
|
$::tcl_platform(machine) \
|
|
$::tcl_platform(osVersion) \
|
|
$linuxcncversion \
|
|
$display \
|
|
"
|
|
} ;# other_info
|
|
|
|
proc processor_info {} {
|
|
set cmdline [exec cat /proc/cmdline]
|
|
set idx [string first isolcpus $cmdline]
|
|
if {$idx < 0} {
|
|
set isolcpus no_isolcpus
|
|
} else {
|
|
set tmp [string range $cmdline $idx end]
|
|
set tmp "$tmp " ;# add trailing blank
|
|
set isolcpus [string range $tmp 0 [expr -1 + [string first " " $tmp]]]
|
|
}
|
|
set fd [open /proc/cpuinfo]
|
|
while {![eof $fd]} {
|
|
gets $fd newline
|
|
set s [split $newline :]
|
|
set key [string trim [lindex $s 0]]
|
|
set key [string map "\" \" _" $key]
|
|
set v [lindex $s 1]
|
|
set procinfo($key) $v
|
|
}
|
|
close $fd
|
|
|
|
set cores "1_core"
|
|
catch {set cores "$procinfo(cpu_cores) cores"};# item may not exist
|
|
catch {set cores "[exec getconf _NPROCESSORS_ONLN] cores"};# could fail?
|
|
|
|
set model ""
|
|
catch {set model $procinfo(model_name)} ;# item may not exist
|
|
set model [string trim $model]
|
|
|
|
set vendor_id ""
|
|
catch {set vendor_id $procinfo(vendor_id)} ;# item may not exist
|
|
|
|
# collapse multiple blanks:
|
|
while 1 {if ![regsub " " $model " " model] break}
|
|
|
|
return "\
|
|
$cores \
|
|
$isolcpus \
|
|
$vendor_id \
|
|
$model \
|
|
"
|
|
} ;# processor_info
|
|
|
|
proc load_packages {} {
|
|
# Tclx is unavailable on Tcl 9 (Fedora 42+). Stub `signal` if missing
|
|
# so the rest of the script (one signal trap call) keeps working.
|
|
if {[catch {package require Tclx}]} {
|
|
proc signal {args} {} ;# no-op stub: Ctrl-C in terminal will not run finish
|
|
}
|
|
|
|
if $::LH(use_x) {
|
|
package require Tk
|
|
wm title . $::LH(title)
|
|
wm protocol . WM_DELETE_WINDOW finish
|
|
wm withdraw .
|
|
# BLT no longer required: lh_chart provides the histogram widget on
|
|
# Tk canvas, so we work on Tcl/Tk 8.6 and 9 alike. Stipple bitmaps
|
|
# for off-chart bars are created on demand by lh_chart::install_stipples.
|
|
}
|
|
|
|
if { [catch {exec pgrep linuxcnc} msg] \
|
|
&& [catch {exec pgrep halcmd} msg]} {
|
|
# puts "ok--not already running hal"
|
|
} else {
|
|
wm withdraw .
|
|
popup "Stop linuxcnc and hal first (try: \$ halrun -U)"
|
|
exit 1
|
|
}
|
|
|
|
exec $::LH(realtime) start >@stdout 2>@stderr
|
|
|
|
# augment ::auto_path for special case:
|
|
# 1) RIP build (no install)
|
|
# 2) linuxcnc script called from Application menu
|
|
if { [info exists ::env(LINUXCNC_TCL_DIR)]
|
|
&& ([lsearch $::auto_path $::env(LINUXCNC_TCL_DIR)] < 0)
|
|
} {
|
|
# prepend
|
|
set ::auto_path [lreplace $::auto_path 0 -1 $::env(LINUXCNC_TCL_DIR)]
|
|
}
|
|
if [catch {package require Hal} msg] {
|
|
puts $msg
|
|
puts "For a RIP linuxcnc build, source rip-environment in this shell"
|
|
exit 1
|
|
}
|
|
} ;# load_packages
|
|
|
|
proc rt_status_items {} {
|
|
# Returns {text color} pairs; color is "" except where it needs attention.
|
|
set red "#cc4444"
|
|
set items {}
|
|
|
|
# realtime: type from 'realtime verify' stdout, yes/no from its exit status.
|
|
set rt_text "no realtime"
|
|
set rt_ok 0
|
|
if {![catch {open [list | $::LH(realtime) verify 2> /dev/null] r} chan]} {
|
|
set out [string trim [read $chan]]
|
|
set rt_ok [expr {![catch {close $chan}]}]
|
|
if {$out ne ""} {set rt_text $out}
|
|
}
|
|
lappend items [list $rt_text [expr {$rt_ok ? "" : $red}]]
|
|
|
|
# cpu governor: red when not 'performance'
|
|
set gov ""
|
|
catch {set gov [string trim [exec cat /sys/devices/system/cpu/cpu0/cpufreq/scaling_governor]]}
|
|
if {$gov eq ""} {set gov "gov?"}
|
|
if {$gov eq "performance"} {
|
|
lappend items [list $gov ""]
|
|
} else {
|
|
lappend items [list $gov $red]
|
|
}
|
|
|
|
# isolcpus
|
|
set cmdline ""
|
|
catch {set cmdline [exec cat /proc/cmdline]}
|
|
if {[regexp {isolcpus=(\S+)} $cmdline -> iso]} {
|
|
lappend items [list "isolcpus=$iso" ""]
|
|
} else {
|
|
lappend items [list "no_isolcpus" ""]
|
|
}
|
|
return $items
|
|
} ;# rt_status_items
|
|
|
|
proc make_gui { {w .} } {
|
|
set f [frame ${w}fa]
|
|
pack $f -side top -fill x -expand 1
|
|
set hname [exec hostname]
|
|
set user $::tcl_platform(user)
|
|
pack [label $f.l -anchor w \
|
|
-text "$::LH(date) $hname $user $::LH(note,txt)"
|
|
] -fill x -expand 1
|
|
|
|
set f [frame ${w}fb]
|
|
pack $f -side top -fill x -expand 1
|
|
pack [label $f.l -anchor w -text $::LH(info)] -fill x -expand 1
|
|
|
|
set f [frame ${w}fc]
|
|
pack $f -side top -fill x -expand 1
|
|
pack [label $f.l -anchor w -text $::LH(processor)] -fill x -expand 1
|
|
|
|
set fmain [frame ${w}fmain]
|
|
pack $fmain -side top
|
|
|
|
foreach thd $::LH(threads) {
|
|
set f1 [frame $fmain.$thd -relief groove -bd 2]
|
|
pack $f1 -side left
|
|
|
|
set f [frame $f1.t]
|
|
pack $f -side top
|
|
|
|
set ::LH(w,$thd) $f.graph
|
|
catch {destroy $::LH(w,$thd)}
|
|
set per [expr $::LH($thd,period,ns)/1000.0]
|
|
lh_chart::create $::LH(w,$thd) \
|
|
-plotbackground honeydew1 \
|
|
-cursor arrow \
|
|
-title "Latency ($::MICROSEC) $thd thread ($per $::MICROSEC period, binsize=$::LH($thd,binsize,us) $::MICROSEC)" \
|
|
-width 480 -height 384
|
|
pack $::LH(w,$thd) -side left
|
|
|
|
xaxis $thd
|
|
$::LH(w,$thd) axis configure y -logscale $::LH(y,logscale)
|
|
|
|
set f [frame $f1.extra12]
|
|
pack $f -side top -anchor w -fill x -expand 1
|
|
|
|
pack [label $f.min -text "min ($::MICROSEC)"] \
|
|
-side left -anchor e
|
|
set e [entry $f.emin -textvariable ::LH($thd,latency_min,us) \
|
|
-state readonly -justify right -width 9]
|
|
pack $e -side left -anchor e
|
|
|
|
pack [label $f.sdev -text " sdev ($::MICROSEC)"] \
|
|
-side left
|
|
set e [entry $f.esdev -textvariable ::LH($thd,latency_sdev,us) \
|
|
-state readonly -justify right -width 9]
|
|
pack $e -side left -anchor e
|
|
|
|
set e [entry $f.emax -textvariable ::LH($thd,latency_max,us) \
|
|
-state readonly -justify right -width 9]
|
|
pack $e -side right -anchor e
|
|
pack [label $f.max -text " max ($::MICROSEC)"] \
|
|
-side right -anchor e
|
|
|
|
if $::LH(opt,show) {
|
|
set f [frame $f1.extra2]
|
|
pack $f -side top -anchor w -fill x -expand 1
|
|
set e [entry $f.emin -textvariable ::LH($thd,n,more) \
|
|
-state readonly -justify right -width 9]
|
|
pack $e -side left -anchor e
|
|
pack [label $f.min -text "<--off-chart neg bin ct"] \
|
|
-side left -anchor e
|
|
set ::LH(w,$thd,negbins) $e
|
|
|
|
set e [entry $f.emax -textvariable ::LH($thd,p,more) \
|
|
-state readonly -justify right -width 9]
|
|
pack $e -side right -anchor e
|
|
pack [label $f.max -text "off-chart pos bin ct-->"] \
|
|
-side right -anchor e
|
|
set ::LH(w,$thd,posbins) $e
|
|
} else {
|
|
set ::LH(w,$thd,negbins) placeholder
|
|
set ::LH(w,$thd,posbins) placeholder
|
|
proc placeholder {args} return
|
|
}
|
|
|
|
set f [frame $f1.bins]
|
|
pack $f -side top -anchor w -fill x -expand 1
|
|
pack [label $f.l -text "Display +/- bins:"] -side left
|
|
|
|
set values ""
|
|
foreach d {100 50 20 10 5 2 1} {
|
|
# avoid dividebyzero for small number of bins
|
|
if [catch {set v [expr $::LH($thd,maxbins)/$d]} msg] continue
|
|
if {$v == 0} continue
|
|
lappend values $v
|
|
}
|
|
|
|
foreach v $values {
|
|
pack [radiobutton $f.b$v \
|
|
-text $v -value $v -variable ::LH($thd,maxbins) \
|
|
-command "xaxis $thd"] -side left
|
|
}
|
|
|
|
}
|
|
|
|
# --- realtime status bar (true footer): one line of axis-style sunken
|
|
# cells split into equal thirds, left/centre/right aligned ---
|
|
set sb [frame ${w}statusbar]
|
|
pack $sb -side bottom -fill x
|
|
set sbitems [rt_status_items]
|
|
# Fixed-width sides (chars), elastic middle gets the rest.
|
|
# Left fits the longest RT label (RT-Xenomai-EVL); right fits isolcpus up to ~4 cpus.
|
|
set sbwidth {14 0 18}
|
|
set sbweight {0 1 0}
|
|
set sbanch {w center e}
|
|
set i 0
|
|
foreach item $sbitems {
|
|
lassign $item text color
|
|
label $sb.s$i -text $text -relief sunken -bd 1 -anchor [lindex $sbanch $i] -padx 6
|
|
set wdt [lindex $sbwidth $i]
|
|
if {$wdt > 0} {$sb.s$i configure -width $wdt}
|
|
if {$color ne ""} {$sb.s$i configure -fg $color}
|
|
grid $sb.s$i -row 0 -column $i -sticky we
|
|
grid columnconfigure $sb $i -weight [lindex $sbweight $i]
|
|
incr i
|
|
}
|
|
|
|
set f [frame ${w}bot]
|
|
pack $f -side bottom -anchor w -fill x -expand 1
|
|
pack [button $f.b -padx 0 -pady 0 -text Reset -command reset_data ] \
|
|
-side left -anchor w
|
|
pack [checkbutton $f.c -text ylogscale -variable ::LH(y,logscale)] \
|
|
-side left
|
|
|
|
pack [button $f.exit -padx 0 -pady 0 -text Exit -command finish ] \
|
|
-side right
|
|
|
|
pack [entry $f.e -textvariable ::LH(elapsed) \
|
|
-state readonly -justify right -width 6] \
|
|
-side right -anchor e
|
|
pack [label $f.el -text "Elapsed Time:"] -side right -anchor e
|
|
|
|
set fg [frame $f.fg]
|
|
pack $fg -side right -anchor center -fill none -expand 1
|
|
pack [label $fg.gct -textvariable ::LH(glxgears,ct)] \
|
|
-side right -anchor center
|
|
pack [button $fg.gears -padx 0 -pady 0 -text Glxgears \
|
|
-command [list exec glxgears &]] \
|
|
-side right -anchor center -fill none -expand 1
|
|
|
|
pack [button $f.sshot -padx 0 -pady 0 -text Screenshot \
|
|
-command [list windowToFile .]] \
|
|
-side right -anchor center -fill none -expand 1
|
|
|
|
wm deiconify .
|
|
wm resizable . 0 0
|
|
|
|
after 0 count_glxgears
|
|
} ;# make_gui
|
|
|
|
proc count_glxgears {} {
|
|
set l {}
|
|
if [catch {set l [exec pgrep glxgears 2>/dev/null]} msg] {
|
|
# puts "l=$l,msg=$msg"
|
|
}
|
|
set ::LH(glxgears,ct) [llength $l]
|
|
after 1000 count_glxgears ;# reschedule
|
|
} ;# count_glxgears
|
|
|
|
proc xaxis {thd} {
|
|
set bins $::LH($thd,maxbins)
|
|
set binsize $::LH($thd,binsize,us)
|
|
foreach v {-1 -2 -5 -10 0 10 5 2 1} {
|
|
if {$v == 0} {
|
|
lappend ticklist 0
|
|
} else {
|
|
lappend ticklist [expr int(1.0*$bins/$v*$binsize)]
|
|
}
|
|
}
|
|
set fullscale [expr $bins * $binsize]
|
|
$::LH(w,$thd) axis configure x \
|
|
-hide 0 \
|
|
-logscale 0 \
|
|
-showticks 1 \
|
|
-min -$fullscale -max $fullscale \
|
|
-majorticks $ticklist
|
|
} ;# xaxis
|
|
|
|
proc finish {} {
|
|
after cancel [after info]
|
|
foreach thd $::LH(threads) {
|
|
if {[info exists ::LH($thd,stream,h)]} {
|
|
catch {hal_stream detach $::LH($thd,stream,h)}
|
|
unset ::LH($thd,stream,h)
|
|
}
|
|
if {$::LH(elapsed) == 0} break
|
|
progress "$thd reread,ct/sec=[format %.3f \
|
|
[expr 1.0*$::LH($thd,reread,ct)/$::LH(elapsed)]]"
|
|
progress "$thd bump,ct/sec=[format %.3f \
|
|
[expr 1.0*$::LH($thd,bump,ct)/$::LH(elapsed)]]"
|
|
}
|
|
progress $::LH(title)\n
|
|
catch {exec pkill glxgears}
|
|
progress "Fini"
|
|
exec halrun -U
|
|
exit 0
|
|
} ;# finish
|
|
|
|
|
|
proc repeat {} {
|
|
after cancel $::LH(after,repeat)
|
|
set ::LH(elapsed) [expr [clock seconds] - $::LH(start)]
|
|
scan [time { foreach thd $::LH(threads) {
|
|
update_bin_data $thd
|
|
}
|
|
}] "%d %s" tus notused
|
|
|
|
set tms [expr $tus/1000]
|
|
set ::LH(after,repeat) [after [expr 2*$tms] repeat] ;# nohogging
|
|
} ;# repeat
|
|
|
|
proc reset_data {} {
|
|
progress "Reset data"
|
|
foreach thd $::LH(threads) {
|
|
hal setp $::LH($thd,name).reset 1
|
|
$::LH(w,$thd,posbins) conf -fg black
|
|
$::LH(w,$thd,negbins) conf -fg black
|
|
set ::LH($thd,pextra) 0
|
|
set ::LH($thd,nextra) 0
|
|
set ::LH($thd,p,more) 0
|
|
set ::LH($thd,n,more) 0
|
|
set ::LH($thd,latency_min,us) ""
|
|
set ::LH($thd,latency_max,us) ""
|
|
set ::LH($thd,latency_sdev,us) ""
|
|
}
|
|
after 100
|
|
foreach thd $::LH(threads) {
|
|
hal setp $::LH($thd,name).reset 0
|
|
}
|
|
set ::LH(start) [clock seconds]
|
|
set ::LH(elapsed) 0
|
|
if $::LH(use_x) { make_chart }
|
|
return
|
|
} ;# reset_data
|
|
|
|
proc start_collection {} {
|
|
set i 1; set args ""
|
|
foreach thd $::LH(threads) {
|
|
set args "$args name$i=t_$thd period$i=$::LH($thd,period,ns)"
|
|
incr i
|
|
}
|
|
eval hal loadrt threads "$args"
|
|
|
|
set names ""; set ct 0
|
|
foreach thd $::LH(threads) {
|
|
if $ct {
|
|
set names "$names,$::LH($thd,name)"
|
|
} else {
|
|
set names "$::LH($thd,name)"
|
|
}
|
|
incr ct
|
|
}
|
|
if {$::LH(legacy)} {
|
|
hal loadrt $::LH(compname) names=$names
|
|
} else {
|
|
# latencybinstream needs a unique shmem key per instance via the
|
|
# `keys=` modparam. Derive deterministic keys from this PID so two
|
|
# latency-histogram processes can coexist.
|
|
set keys ""
|
|
set kct 0
|
|
set basekey [expr {[pid] & 0x7fff}]
|
|
foreach thd $::LH(threads) {
|
|
set k [expr {$basekey + $kct}]
|
|
set ::LH($thd,streamkey) $k
|
|
if {$kct == 0} { set keys $k } else { set keys "$keys,$k" }
|
|
incr kct
|
|
}
|
|
hal loadrt $::LH(compname) names=$names keys=$keys
|
|
}
|
|
foreach thd $::LH(threads) {
|
|
set ::LH($thd,reread,ct) 0
|
|
set ::LH($thd,bump,ct) 0
|
|
set ::LH($thd,timeout,ct) 0
|
|
set ::LH($thd,timeout,warned) 0
|
|
set availablebins [hal getp $::LH($thd,name).availablebins]
|
|
if {$availablebins < $::LH($thd,maxbins)} {
|
|
if $::LH(use_x) { wm iconify . }
|
|
puts ""
|
|
puts "The compiled-in number of available bins for $::LH(compname).comp:"
|
|
puts " <$availablebins>"
|
|
puts "is less than the requested maxbins:"
|
|
puts " <$::LH($thd,maxbins) for the $thd thread>"
|
|
puts ""
|
|
puts "To fix:"
|
|
puts " 1) Increase binsize"
|
|
puts "or"
|
|
puts " 2) Decrease thread interval"
|
|
puts "or"
|
|
puts " 3) Set bins explicitly (< $availablebins)"
|
|
puts ""
|
|
exec halrun -U
|
|
exit 1
|
|
}
|
|
hal addf $::LH($thd,name) t_$thd
|
|
hal setp $::LH($thd,name).maxbinnumber $::LH($thd,maxbins)
|
|
hal setp $::LH($thd,name).nsbinsize $::LH($thd,binsize,ns)
|
|
# Acquisition bin count stays at this startup value: the "Display
|
|
# +/- bins" radio only zooms the chart, the streamed snapshot size
|
|
# must not follow it.
|
|
set ::LH($thd,acqbins) $::LH($thd,maxbins)
|
|
if {!$::LH(legacy)} {
|
|
# Comp boots with reset=1 so bins start clean. Drop reset and let
|
|
# samples flow.
|
|
hal setp $::LH($thd,name).reset 0
|
|
}
|
|
}
|
|
hal start
|
|
if {!$::LH(legacy)} {
|
|
# Attach the Tcl hal_stream binding (added in halsh.c) to each
|
|
# thread's latencybinstream FIFO. The handle stays open for the
|
|
# session and is detached in finish.
|
|
foreach thd $::LH(threads) {
|
|
if {[catch {set h [hal_stream attach $::LH($thd,streamkey) u]} err]} {
|
|
popup "hal_stream attach for $thd failed: $err"
|
|
exec halrun -U
|
|
exit 1
|
|
}
|
|
set ::LH($thd,stream,h) $h
|
|
}
|
|
}
|
|
if $::LH(use_x) { make_chart }
|
|
after 100
|
|
set ::LH(elapsed) 0
|
|
} ;# start_collection
|
|
|
|
proc make_chart {} {
|
|
foreach thd $::LH(threads) {
|
|
set w $::LH(w,$thd)
|
|
$w legend configure -hide 1 ;# too many bins for legend
|
|
for {set bin 0} {$bin <= $::LH($thd,maxbins)} {incr bin} {
|
|
lappend pxd [expr $bin*$::LH($thd,binsize,us)]
|
|
lappend pyd 0
|
|
if {$bin == 0} continue
|
|
lappend nxd [expr -$bin*$::LH($thd,binsize,us)]
|
|
lappend nyd 0
|
|
}
|
|
if [$w element exists ndata] {
|
|
set op configure
|
|
} else {
|
|
set op create
|
|
}
|
|
$w element $op pdata -xdata $pxd \
|
|
-ydata $pyd \
|
|
-fg $::LH($thd,color) \
|
|
-relief solid \
|
|
-bd 0 -barwidth $::LH($thd,binsize,us) \
|
|
-bg lightblue
|
|
$w element $op pmaxdata \
|
|
-xdata [expr $::LH($thd,maxbins) * $::LH($thd,binsize,us)] \
|
|
-ydata 0 \
|
|
-fg $::LH($thd,color) \
|
|
-relief solid \
|
|
-bd 0 -barwidth $::LH($thd,binsize,us) \
|
|
-bg lightblue
|
|
if {$bin == 0} continue
|
|
$w element $op ndata -xdata $nxd \
|
|
-ydata $nyd \
|
|
-fg $::LH($thd,color) \
|
|
-relief solid \
|
|
-bd 0 -barwidth $::LH($thd,binsize,us) \
|
|
-bg lightblue
|
|
$w element $op nmaxdata \
|
|
-xdata [expr -$::LH($thd,maxbins) * $::LH($thd,binsize,us)] \
|
|
-ydata 0 \
|
|
-fg $::LH($thd,color) \
|
|
-relief solid \
|
|
-bd 0 -barwidth $::LH($thd,binsize,us) \
|
|
-bg lightblue
|
|
if {$bin == 0} continue
|
|
|
|
}
|
|
} ;# make_chart
|
|
|
|
proc update_bin_data {thd} {
|
|
set N $::LH($thd,maxbins)
|
|
set bs $::LH($thd,binsize,us)
|
|
set pxd {}; set pyd {}; set nxd {}; set nyd {}
|
|
set pmore 0; set nmore 0
|
|
|
|
if {$::LH(legacy)} {
|
|
# Per-bin polling against the legacy latencybins comp. Has known
|
|
# RT/non-RT race: bins read one cycle at a time so the snapshot
|
|
# is smeared and stats desync from bins.
|
|
set dly $::LH($thd,dly,ms)
|
|
for {set bin 0} {$bin <= $N} {incr bin} {
|
|
hal setp $::LH($thd,name).index $bin
|
|
set ct 0
|
|
while 1 {
|
|
after $dly
|
|
set chk [hal getp $::LH($thd,name).check]
|
|
if {$bin == $chk} break
|
|
incr ct
|
|
incr ::LH($thd,reread,ct)
|
|
if {$ct > 1} {
|
|
incr dly
|
|
incr ::LH($thd,bump,ct)
|
|
}
|
|
}
|
|
set pbin [hal getp $::LH($thd,name).pbinvalue]
|
|
set nbin [hal getp $::LH($thd,name).nbinvalue]
|
|
if {$pbin == 1} {set pbin 1.1}
|
|
if {$nbin == 1} {set nbin 1.1}
|
|
lappend pxd [expr $bin * $bs]
|
|
lappend pyd $pbin
|
|
if {$bin != 0} {
|
|
lappend nxd -[expr $bin * $bs]
|
|
lappend nyd $nbin
|
|
}
|
|
if {$bin > $N} {
|
|
set pmore [expr $pmore + $pbin]
|
|
set nmore [expr $nmore + $nbin]
|
|
}
|
|
}
|
|
set ::LH($thd,pextra) [hal getp $::LH($thd,name).pextra]
|
|
set ::LH($thd,nextra) [hal getp $::LH($thd,name).nextra]
|
|
} else {
|
|
# Atomic snapshot via latencybinstream FIFO. Rising edge on
|
|
# `stream` makes RT push 2A+3 records, where A is the startup
|
|
# acquisition bin count (comp maxbinnumber). The display bin count
|
|
# N may be smaller after a "Display +/- bins" change; only the
|
|
# first N bins of the snapshot are shown. Wait for FIFO depth,
|
|
# drain via the Tcl hal_stream binding, lower trigger.
|
|
set A $::LH($thd,acqbins)
|
|
if {$N > $A} { set N $A }
|
|
set need [expr {2*$A + 3}]
|
|
set h $::LH($thd,stream,h)
|
|
hal setp $::LH($thd,name).stream 1
|
|
# Wait until exactly `need` records are queued. Reading early can
|
|
# produce a partial set; the FIFO is sized so a full set always
|
|
# fits, so reaching depth==need means RT pushed a clean snapshot.
|
|
set tries 0
|
|
while {[hal_stream depth $h] < $need} {
|
|
after 1
|
|
incr tries
|
|
if {$tries > 250} {
|
|
hal setp $::LH($thd,name).stream 0
|
|
if {[hal getp $::LH($thd,name).stream-error]} {
|
|
# Hard error: the RT side reports the FIFO cannot hold a full
|
|
# set, so it never streams. This cannot recover, so report it
|
|
# visibly and quit rather than leaving a dead window spinning.
|
|
fatal "$thd: stream-error set (FIFO too small for $need records).\n\nThe latencybinstream FIFO cannot hold a complete data set.\nThis is a build/configuration error and will not recover."
|
|
}
|
|
# A plain timeout may be transient. Surface it visibly once it
|
|
# persists rather than only spamming the console each cycle.
|
|
puts "$thd: stream timeout (depth [hal_stream depth $h] < $need)"
|
|
incr ::LH($thd,timeout,ct)
|
|
if {$::LH($thd,timeout,ct) >= 5 && !$::LH($thd,timeout,warned)} {
|
|
set ::LH($thd,timeout,warned) 1
|
|
popup "$thd: repeated stream timeouts (depth < $need).\n\nThe histogram is not updating for this thread."
|
|
}
|
|
return
|
|
}
|
|
}
|
|
set ::LH($thd,timeout,ct) 0
|
|
set vals [hal_stream drain $h]
|
|
hal setp $::LH($thd,name).stream 0
|
|
# After drain the FIFO must be empty; non-zero means we read out of
|
|
# phase and the snapshot is suspect.
|
|
set leftover [hal_stream depth $h]
|
|
if {[llength $vals] != $need || $leftover != 0} {
|
|
puts "$thd: stream out-of-sync ([llength $vals]/$need, leftover=$leftover)"
|
|
return
|
|
}
|
|
set ntail [lindex $vals 0]
|
|
set ptail [lindex $vals end]
|
|
# Stream order: ntail, nbin[A..1], pbin[0..A], ptail. Display uses
|
|
# only bins 0..N (N <= A).
|
|
for {set k 0} {$k <= $N} {incr k} {
|
|
lappend pxd [expr $k * $bs]
|
|
set v [lindex $vals [expr {$A + 1 + $k}]]
|
|
if {$v == 1} { set v 1.1 }
|
|
lappend pyd $v
|
|
}
|
|
for {set k 1} {$k <= $N} {incr k} {
|
|
lappend nxd [expr -$k * $bs]
|
|
set v [lindex $vals [expr {$A - $k + 1}]]
|
|
if {$v == 1} { set v 1.1 }
|
|
lappend nyd $v
|
|
}
|
|
set ::LH($thd,pextra) $ptail
|
|
set ::LH($thd,nextra) $ntail
|
|
}
|
|
|
|
set ::LH($thd,latency_min,us) [format %.1f \
|
|
[expr 1e-3 * [hal getp $::LH($thd,name).latency-min]]]
|
|
set ::LH($thd,latency_max,us) [format %.1f \
|
|
[expr 1e-3 * [hal getp $::LH($thd,name).latency-max]]]
|
|
|
|
set variance [hal getp $::LH($thd,name).variance]
|
|
if [catch {
|
|
set ::LH($thd,latency_sdev,us) [format %.1f \
|
|
[expr 1e-3 * sqrt(abs($variance))]]
|
|
} msg] {
|
|
puts "msg=$msg (variance=$variance)"
|
|
}
|
|
|
|
set ::LH($thd,p,more) [expr $pmore + $::LH($thd,pextra)]
|
|
set ::LH($thd,n,more) [expr $nmore + $::LH($thd,nextra)]
|
|
if !$::LH(use_x) {
|
|
puts [format "%5d s %6s min:%8.3f us max:%8.3f us sdev:%8.3f us" \
|
|
$::LH(elapsed) \
|
|
$thd \
|
|
$::LH($thd,latency_min,us) \
|
|
$::LH($thd,latency_max,us) \
|
|
$::LH($thd,latency_sdev,us) \
|
|
]
|
|
return
|
|
}
|
|
|
|
set pcolor $::LH($thd,color)
|
|
set pmaxcolor white
|
|
if {$::LH($thd,pextra) > 0} {
|
|
set pcolor red
|
|
set pmaxcolor $pcolor
|
|
$::LH(w,$thd,posbins) conf -fg $pcolor
|
|
} elseif {$::LH($thd,p,more) > 0} {
|
|
$::LH(w,$thd,posbins) conf -fg $::LH($thd,color)
|
|
} else {
|
|
$::LH(w,$thd,posbins) conf -fg black
|
|
}
|
|
|
|
set ncolor $::LH($thd,color)
|
|
set nmaxcolor white
|
|
if {$::LH($thd,nextra) > 0} {
|
|
set ncolor red
|
|
set nmaxcolor $ncolor
|
|
$::LH(w,$thd,negbins) conf -fg $ncolor
|
|
} elseif {$::LH($thd,n,more) > 0} {
|
|
$::LH(w,$thd,negbins) conf -fg $::LH($thd,color)
|
|
} else {
|
|
$::LH(w,$thd,negbins) conf -fg black
|
|
}
|
|
|
|
set pyd_max_pos [expr [lindex $pyd end] + $::LH($thd,p,more)]
|
|
set nyd_max_neg [expr [lindex $nyd end] + $::LH($thd,n,more)]
|
|
|
|
# display fmt
|
|
set ::LH($thd,p,more) [format %.3g $::LH($thd,p,more)]
|
|
set ::LH($thd,n,more) [format %.3g $::LH($thd,n,more)]
|
|
|
|
# remove end bin
|
|
set pyd [lrange $pyd 0 [expr -1 + $::LH($thd,maxbins)]]
|
|
set pxd [lrange $pxd 0 [expr -1 + $::LH($thd,maxbins)]]
|
|
|
|
set nyd [lrange $nyd 0 [expr -2 + $::LH($thd,maxbins)]]
|
|
set nxd [lrange $nxd 0 [expr -2 + $::LH($thd,maxbins)]]
|
|
|
|
set w $::LH(w,$thd)
|
|
$w element configure pdata -xdata $pxd -ydata $pyd
|
|
$w element configure ndata -xdata $nxd -ydata $nyd
|
|
|
|
$w element configure pmaxdata \
|
|
-xdata [expr $::LH($thd,maxbins) * $::LH($thd,binsize,us)] \
|
|
-ydata $pyd_max_pos \
|
|
-stipple pbmap \
|
|
-fg $::LH($thd,color) -bg $pmaxcolor
|
|
$w element configure nmaxdata \
|
|
-xdata [expr -1*$::LH($thd,maxbins) * $::LH($thd,binsize,us)] \
|
|
-ydata $nyd_max_neg \
|
|
-stipple nbmap \
|
|
-fg $::LH($thd,color) -bg $nmaxcolor
|
|
|
|
# a y axis configure is needed, updates may fail without it
|
|
$::LH(w,$thd) axis configure y -logscale $::LH(y,logscale)
|
|
update
|
|
} ;# update_bin_data
|
|
|
|
proc popup {msg} { \
|
|
package require Tk
|
|
set answer [tk_messageBox \
|
|
-parent . \
|
|
-icon error \
|
|
-type ok \
|
|
-title "Message" \
|
|
-message "$msg" \
|
|
]
|
|
puts $msg
|
|
} ;# popup
|
|
|
|
# Report an unrecoverable error visibly, then tear down and quit so the
|
|
# tool never lingers in a broken, non-updating state.
|
|
proc fatal {msg} {
|
|
catch {after cancel $::LH(after,repeat)}
|
|
popup $msg
|
|
foreach thd $::LH(threads) {
|
|
if {[info exists ::LH($thd,stream,h)]} {
|
|
catch {hal_stream detach $::LH($thd,stream,h)}
|
|
unset ::LH($thd,stream,h)
|
|
}
|
|
}
|
|
catch {exec pkill glxgears}
|
|
catch {exec halrun -U}
|
|
exit 1
|
|
} ;# fatal
|
|
|
|
proc progress {txt} {
|
|
if !$::LH(verbose) return
|
|
puts stderr "$::argv0: [expr [clock seconds] - $::LH(start)]s $txt"
|
|
} ;# progress
|
|
|
|
proc usage {} {
|
|
set prog [file tail $::argv0]
|
|
puts ""
|
|
puts "Usage:"
|
|
puts " $prog --help | -?"
|
|
puts "or"
|
|
puts " $prog \[Options\]"
|
|
puts ""
|
|
puts "Options:"
|
|
puts " --base ns (base thread interval, default: $::LH(base,period,ns), min: $::LH(base,period,ns,min))"
|
|
puts " --servo ns (servo thread interval, default: $::LH(servo,period,ns), min: $::LH(servo,period,ns,min))"
|
|
|
|
puts " --bbinsize ns (base bin size, default: $::LH(base,binsize,ns))"
|
|
puts " --sbinsize ns (servo bin size, default: $::LH(servo,binsize,ns))"
|
|
|
|
puts " --bbins n (base bins, default: $::LH(base,maxbins))"
|
|
puts " --sbins n (servo bins, default: $::LH(servo,maxbins))"
|
|
|
|
puts " --logscale 0|1 (y axis log scale, default: $::LH(y,logscale))"
|
|
puts " --text note (additional note, default: \"$::LH(note,txt)\")"
|
|
puts " --show (show count of undisplayed bins)"
|
|
puts " --nobase (servo thread only)"
|
|
puts " --verbose (progress and debug)"
|
|
puts " --nox (no gui, display elapsed,min,max,sdev for each thread)"
|
|
puts " --legacy (use original latencybins comp; has RT/non-RT data race)"
|
|
|
|
puts ""
|
|
puts "Notes:"
|
|
puts " Linuxcnc and Hal should not be running, stop with halrun -U."
|
|
puts " Large number of bins and/or small binsizes will slow updates."
|
|
puts " For single thread, specify --nobase (and options for servo thread)."
|
|
puts " Measured latencies outside of the +/- bin range are reported"
|
|
puts " with special end bars. Use --show to show count for"
|
|
puts " the off-chart \[pos|neg\] bin"
|
|
exit 0
|
|
} ;# usage
|
|
|
|
#------------------------------------------------------------------
|
|
proc windowToFile { win } {
|
|
if {[catch {set image [lh_chart::capture_window $win]} msg]} {
|
|
popup $msg
|
|
return
|
|
}
|
|
set types {{"Image Files" {.png}}}
|
|
set ifile $::tcl_platform(user)-$::LH(date)-$::LH(elapsed).png
|
|
set filename [tk_getSaveFile -filetypes $types \
|
|
-initialfile $ifile \
|
|
-initialdir $::LH(dir,screenshot) \
|
|
-defaultextension .png]
|
|
if {[llength $filename]} {
|
|
set ::LH(dir,screenshot) [file dirname $filename]
|
|
$image write -format png $filename
|
|
}
|
|
image delete $image
|
|
} ;# windowToFile
|
|
#------------------------------------------------------------------
|
|
|
|
# allow re-sourcing for testing with tkcon
|
|
if ![info exists ::LH(start)] {
|
|
set_defaults
|
|
config
|
|
progress "Loading packages"
|
|
load_packages
|
|
signal trap SIGINT finish
|
|
progress "Making gui"
|
|
if $::LH(use_x) make_gui
|
|
progress "Start_collection"
|
|
start_collection
|
|
progress "Begin repeats"
|
|
repeat
|
|
} else {
|
|
puts "$::argv0 already running"
|
|
}
|
|
if !$::LH(use_x) { vwait ::forever }
|