diff --git a/lib/hallib/lh_chart.tcl b/lib/hallib/lh_chart.tcl new file mode 100644 index 00000000000..e1e2b8d049c --- /dev/null +++ b/lib/hallib/lh_chart.tcl @@ -0,0 +1,538 @@ +# lh_chart.tcl: minimal canvas-based bar chart + window capture helper. +# +#----------------------------------------------------------------------- +# Copyright: 2012-2016 (lh_chart by Dewey Garrett +# and later contributors) +# +# 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. +#----------------------------------------------------------------------- + +#----------------------------------------------------------------------- +# lh_chart: minimal canvas-based bar chart implementing the subset of +# blt::barchart used by latency-histogram and hal-histogram. Goal: +# visual + behavioral parity without depending on BLT (which has no +# Tcl/Tk 9 port). +# +# Public API (used at $w via command rename + dispatch): +# $w axis configure x|y -min -max -majorticks -logscale -hide -showticks +# $w element create|configure NAME -xdata -ydata -fg -bg -barwidth -stipple +# $w element exists NAME +# $w legend configure -hide 0|1 +# Constructor: +# lh_chart::create $w -title T -width W -height H \ +# -plotbackground COLOR -cursor C +#----------------------------------------------------------------------- +namespace eval lh_chart { + variable state + variable stipple_map + array set stipple_map {} +} + +proc lh_chart::install_stipples {} { + variable stipple_map + if {[info exists stipple_map(_installed)]} return + set dir /tmp/lh_chart_stipples_[pid] + catch {file mkdir $dir} + # Tk's XBM reader is picky: needs static char (signed, not unsigned) + # and the data block in K&R-style continuation form with a trailing + # closing-brace-semicolon on its own line. One-liners are rejected. + foreach {name bits} { + pbmap {0xe3 0xf1 0xf8 0x7c 0x3e 0x1f 0x8f 0xc7} + nbmap {0xc7 0x8f 0x1f 0x3e 0x7c 0xf8 0xf1 0xe3} + } { + set fp [open $dir/$name.xbm w] + puts $fp "#define ${name}_width 8" + puts $fp "#define ${name}_height 8" + puts $fp "static char ${name}_bits\[\] = \{" + puts $fp " [join $bits {, }]\};" + close $fp + set stipple_map($name) "@$dir/$name.xbm" + } + set stipple_map(_installed) 1 +} + +proc lh_chart::create {w args} { + variable state + install_stipples + array set opts { + -title "" + -width 480 + -height 384 + -plotbackground honeydew1 + -cursor arrow + } + array set opts $args + canvas $w \ + -width $opts(-width) \ + -height $opts(-height) \ + -bg "#d9d9d9" \ + -bd 0 -highlightthickness 0 \ + -cursor $opts(-cursor) + set state($w,title) $opts(-title) + set state($w,width) $opts(-width) + set state($w,height) $opts(-height) + set state($w,plotbg) $opts(-plotbackground) + set state($w,xmin) -1.0 + set state($w,xmax) 1.0 + set state($w,ymin) 0.0 + set state($w,ymax) 1.0 + set state($w,ylogscale) 0 + set state($w,xticks) {} + set state($w,elements) {} + set state($w,legend_hide) 1 + set state($w,dirty) 1 + set state($w,redraw_pending) 0 + bind $w [list lh_chart::on_configure $w] + rename ::$w ::lh_chart::_orig_$w + proc ::$w {args} "::lh_chart::dispatch $w {*}\$args" + lh_chart::schedule_redraw $w + return $w +} + +proc lh_chart::dispatch {w args} { + set sub [lindex $args 0] + set rest [lrange $args 1 end] + switch -- $sub { + axis { return [lh_chart::cmd_axis $w {*}$rest] } + element { return [lh_chart::cmd_element $w {*}$rest] } + legend { return [lh_chart::cmd_legend $w {*}$rest] } + default { return [::lh_chart::_orig_$w {*}$args] } + } +} + +proc lh_chart::cmd_axis {w sub which args} { + variable state + if {$sub ne "configure"} { error "lh_chart axis: unsupported subcommand $sub" } + array set opts $args + if {$which eq "x"} { + if {[info exists opts(-min)]} { set state($w,xmin) $opts(-min) } + if {[info exists opts(-max)]} { set state($w,xmax) $opts(-max) } + if {[info exists opts(-majorticks)]} { set state($w,xticks) $opts(-majorticks) } + } elseif {$which eq "y"} { + if {[info exists opts(-logscale)]} { set state($w,ylogscale) $opts(-logscale) } + if {[info exists opts(-min)]} { set state($w,ymin) $opts(-min) } + if {[info exists opts(-max)]} { set state($w,ymax) $opts(-max) } + } + schedule_redraw $w +} + +proc lh_chart::cmd_element {w op name args} { + variable state + variable stipple_map + switch -- $op { + exists { + return [expr {[lsearch -exact $state($w,elements) $name] >= 0}] + } + create { + if {[lsearch -exact $state($w,elements) $name] < 0} { + lappend state($w,elements) $name + } + set state($w,el,$name,xdata) {} + set state($w,el,$name,ydata) {} + set state($w,el,$name,fg) black + set state($w,el,$name,bg) lightblue + set state($w,el,$name,barwidth) 1.0 + set state($w,el,$name,stipple) {} + cmd_element_apply $w $name $args + } + configure { + cmd_element_apply $w $name $args + } + default { error "lh_chart element: unsupported op $op" } + } + schedule_redraw $w +} + +proc lh_chart::cmd_element_apply {w name optlist} { + variable state + variable stipple_map + array set opts $optlist + foreach {k storekey} { + -xdata xdata + -ydata ydata + -fg fg + -bg bg + -barwidth barwidth + } { + if {[info exists opts($k)]} { + set state($w,el,$name,$storekey) $opts($k) + } + } + if {[info exists opts(-stipple)]} { + set s $opts(-stipple) + if {[info exists stipple_map($s)]} { set s $stipple_map($s) } + set state($w,el,$name,stipple) $s + } +} + +proc lh_chart::cmd_legend {w sub args} { + variable state + if {$sub eq "configure"} { + array set opts $args + if {[info exists opts(-hide)]} { set state($w,legend_hide) $opts(-hide) } + } +} + +proc lh_chart::on_configure {w} { + variable state + if {![info exists state($w,width)]} return + set state($w,width) [winfo width $w] + set state($w,height) [winfo height $w] + schedule_redraw $w +} + +proc lh_chart::schedule_redraw {w} { + variable state + set state($w,dirty) 1 + if {$state($w,redraw_pending)} return + set state($w,redraw_pending) 1 + after idle [list lh_chart::redraw $w] +} + +proc lh_chart::redraw {w} { + variable state + set state($w,redraw_pending) 0 + if {![winfo exists $w]} return + if {!$state($w,dirty)} return + set state($w,dirty) 0 + set c ::lh_chart::_orig_$w + $c delete all + + set W $state($w,width) + set H $state($w,height) + if {$W <= 1} { set W $state($w,width) } + + set ml 55 ; set mr 18 ; set mt 20 ; set mb 42 + set pw [expr {$W - $ml - $mr}] + set ph [expr {$H - $mt - $mb}] + if {$pw < 50 || $ph < 50} return + # Data inset: keep off-chart end bars (red-stippled at xmin/xmax) + # visibly inward from the border, matching BLT's plot margin. + set pad 8 + set ml_d [expr {$ml + $pad}] + set mt_d [expr {$mt + $pad}] + set pw_d [expr {$pw - 2*$pad}] + set ph_d [expr {$ph - 2*$pad}] + + set xmin $state($w,xmin) + set xmax $state($w,xmax) + set xrange [expr {double($xmax - $xmin)}] + if {$xrange == 0} { set xrange 1.0 } + + # auto-scale Y from element data + set ymax_data 1.0 + foreach name $state($w,elements) { + foreach v $state($w,el,$name,ydata) { + if {$v > $ymax_data} { set ymax_data $v } + } + } + if {$state($w,ylogscale)} { + set ymin 1.0 + if {$ymax_data < 10} { + set ymax 10.0 + } else { + # Nice ceiling: 1, 2, 5 times the decade — keeps Y range + # tight so a small data growth doesn't jump a full decade. + set decade [expr {pow(10, floor(log10($ymax_data)))}] + set ratio [expr {$ymax_data / $decade}] + if {$ratio <= 1.0} { + set ymax $decade + } elseif {$ratio <= 2.0} { + set ymax [expr {2.0 * $decade}] + } elseif {$ratio <= 5.0} { + set ymax [expr {5.0 * $decade}] + } else { + set ymax [expr {10.0 * $decade}] + } + } + } else { + set ymin 0.0 + # Nice ceiling for ymax: pick 1, 2, 2.5, 5, or 10 times a decade + # so the 5 equal ticks become round numbers (e.g. 0, 600, 1200, + # 1800, 2400, 3000) instead of (0, 580, 1160, ...). + if {$ymax_data <= 0} { + set ymax 1.0 + } else { + set goal [expr {$ymax_data * 1.05}] + set decade [expr {pow(10, floor(log10($goal)))}] + set ratio [expr {$goal / $decade}] + if {$ratio <= 1.0} { + set ymax $decade + } elseif {$ratio <= 2.0} { + set ymax [expr {2.0 * $decade}] + } elseif {$ratio <= 2.5} { + set ymax [expr {2.5 * $decade}] + } elseif {$ratio <= 5.0} { + set ymax [expr {5.0 * $decade}] + } else { + set ymax [expr {10.0 * $decade}] + } + } + } + set state($w,ymin) $ymin + set state($w,ymax) $ymax + + set lxmin [expr {$state($w,ylogscale) ? log10($ymin) : 0}] + set lxmax [expr {$state($w,ylogscale) ? log10($ymax) : 0}] + set lyrange [expr {$lxmax - $lxmin}] + if {$lyrange == 0} { set lyrange 1 } + + # plot area background (no border yet, axis lines drawn last) + $c create rectangle $ml $mt [expr {$ml+$pw}] [expr {$mt+$ph}] \ + -fill $state($w,plotbg) -outline "" + + # title + if {$state($w,title) ne ""} { + $c create text [expr {$ml + $pw/2}] [expr {$mt - 9}] \ + -text $state($w,title) -anchor center -font {Helvetica -12} + } + + # Y axis: build tick lists + draw gridlines now (ticks/labels at end). + # Major ticks get a label and a long tick line; minor ticks at every + # sub-decade gridline get a short tick line only (matches BLT). + set y_ticks {} ;# list of {value label} — major + set y_minor_ticks {} ;# list of values — minor + if {$state($w,ylogscale)} { + # Minor gridlines at 2..9 within each decade + set d 1.0 + while {$d < $ymax + 0.1} { + for {set k 2} {$k <= 9} {incr k} { + set v [expr {$d * $k}] + if {$v > $ymax + 0.1} break + set y [lh_chart::ymap_log $mt_d $ph_d $ymin $ymax $v] + $c create line $ml $y [expr {$ml+$pw}] $y \ + -fill gray70 -dash {1 1} + lappend y_minor_ticks $v + } + set d [expr {$d * 10}] + } + # Major gridlines at each decade + set d 1.0 + set exp 0 + while {$d <= $ymax + 0.001} { + set y [lh_chart::ymap_log $mt_d $ph_d $ymin $ymax $d] + $c create line $ml $y [expr {$ml+$pw}] $y -fill gray70 -dash {1 1} + lappend y_ticks [list $d "1E$exp"] + set d [expr {$d * 10}] + incr exp + } + # Cap tick at ymax if it sits between decades (2x or 5x of decade) + set top_decade [expr {pow(10, floor(log10($ymax) + 1e-9))}] + set top_ratio [expr {$ymax / $top_decade}] + if {$top_ratio > 1.5} { + set top_exp [expr {int(floor(log10($ymax) + 1e-9))}] + set top_mant [expr {int(round($top_ratio))}] + lappend y_ticks [list $ymax "${top_mant}E$top_exp"] + } + } else { + set steps 5 + for {set i 0} {$i <= $steps} {incr i} { + set v [expr {$ymin + ($ymax - $ymin) * $i / double($steps)}] + set y [lh_chart::ymap_lin $mt_d $ph_d $ymin $ymax $v] + $c create line $ml $y [expr {$ml+$pw}] $y -fill gray80 -dash {2 2} + lappend y_ticks [list $v [lh_chart::fmt_num $v]] + } + } + + # baseline (y=0 in linear or y=1 in log) using inset mapping + set y0 [expr {$state($w,ylogscale) \ + ? [lh_chart::ymap_log $mt_d $ph_d $ymin $ymax 1.0] \ + : [lh_chart::ymap_lin $mt_d $ph_d $ymin $ymax 0.0]}] + + # Bars: BLT semantics — `-fg` is the fill color, `-bg` shows through + # stipple. We draw solid fg-fill with matching outline so narrow bars + # render as a single fg-colored column (1-2 px) without any sub-bar + # outline lines splitting adjacent bars. For stippled bars (off-chart + # indicators) we paint bg first, then a stippled fg layer on top. + foreach name $state($w,elements) { + set xd $state($w,el,$name,xdata) + set yd $state($w,el,$name,ydata) + set bw $state($w,el,$name,barwidth) + set fg $state($w,el,$name,fg) + set bg $state($w,el,$name,bg) + set st $state($w,el,$name,stipple) + set hbw [expr {$bw / 2.0}] + foreach x $xd y $yd { + if {$y <= 0} continue + if {$state($w,ylogscale) && $y < $ymin} continue + set xa [expr {$x - $hbw}] + set xb [expr {$x + $hbw}] + if {$xb < $xmin || $xa > $xmax} continue + if {$xa < $xmin} { set xa $xmin } + if {$xb > $xmax} { set xb $xmax } + set pxa [lh_chart::xmap $ml_d $pw_d $xmin $xrange $xa] + set pxb [lh_chart::xmap $ml_d $pw_d $xmin $xrange $xb] + # Pixel-snap so sub-pixel bars (e.g. 0.1us bins at ~1.2 px each) + # always paint at least one full pixel and adjacent bars touch. + set pxa [expr {int(floor($pxa))}] + set pxb [expr {int(ceil($pxb))}] + if {$pxb <= $pxa} { set pxb [expr {$pxa + 1}] } + # Off-chart (stippled) end-of-range bars: minimum 2 px so the + # stipple pattern is actually visible and matches BLT. + if {$st ne "" && [expr {$pxb - $pxa}] < 2} { + set pxb [expr {$pxa + 2}] + } + if {$state($w,ylogscale)} { + set py [lh_chart::ymap_log $mt_d $ph_d $ymin $ymax $y] + } else { + set py [lh_chart::ymap_lin $mt_d $ph_d $ymin $ymax $y] + } + if {$st ne ""} { + $c create rectangle $pxa $py $pxb $y0 \ + -fill $bg -outline $bg -width 0 + $c create rectangle $pxa $py $pxb $y0 \ + -fill $fg -outline $fg -width 0 -stipple $st + } else { + $c create rectangle $pxa $py $pxb $y0 \ + -fill $fg -outline $fg -width 0 + } + } + # Continuous baseline: 1 px line in the element's fg color along + # the bottom of the data area, so the bottom doesn't look broken + # where bins have zero counts. + if {[llength $xd] > 0} { + $c create line \ + [lh_chart::xmap $ml_d $pw_d $xmin $xrange $xmin] $y0 \ + [lh_chart::xmap $ml_d $pw_d $xmin $xrange $xmax] $y0 \ + -fill $fg + } + } + + # Plot frame: 3D raised look. Only TOP and LEFT have a black outline + # (the lit edges); BOTTOM and RIGHT are left without an outer black + # line. Inside, top+left have a darker shadow line and bottom+right + # a lighter highlight, giving the panel-edge relief BLT used. + set xR [expr {$ml+$pw}] + set yB [expr {$mt+$ph}] + $c create line $ml $mt $xR $mt -fill black + $c create line $ml $mt $ml $yB -fill black + $c create line [expr {$ml+1}] [expr {$mt+1}] [expr {$xR-1}] [expr {$mt+1}] \ + -fill gray45 + $c create line [expr {$ml+1}] [expr {$mt+1}] [expr {$ml+1}] [expr {$yB-1}] \ + -fill gray45 + $c create line [expr {$ml+1}] [expr {$yB-1}] [expr {$xR-1}] [expr {$yB-1}] \ + -fill white + $c create line [expr {$xR-1}] [expr {$mt+1}] [expr {$xR-1}] [expr {$yB-1}] \ + -fill white + + # Axis line: separate black line OUTSIDE the plot border, with a + # small gap between them. Spans only the data-inset range so its + # endpoints sit right at the topmost and bottommost ticks (BLT + # behavior — the axis "ends with the last tick"). + set axis_gap 4 + set tick_long 10 + set tick_short 5 + set axis_x [expr {$ml - $axis_gap}] ;# left axis (Y) + set axis_y [expr {$yB + $axis_gap}] ;# bottom axis (X) + set axis_top $mt_d ;# = $mt + pad + set axis_bottom [expr {$mt_d + $ph_d}] + set axis_left $ml_d ;# = $ml + pad + set axis_right [expr {$ml_d + $pw_d}] + $c create line $axis_x $axis_top $axis_x $axis_bottom -fill black + $c create line $axis_left $axis_y $axis_right $axis_y -fill black + + # Tick marks attach to (touch) the axis line and point OUTWARD + # toward the labels. Major ticks long, minor ticks (Y only) short. + foreach v $y_minor_ticks { + set y [lh_chart::ymap_log $mt_d $ph_d $ymin $ymax $v] + $c create line [expr {$axis_x - $tick_short}] $y $axis_x $y \ + -fill black + } + foreach pair $y_ticks { + lassign $pair v label + if {$state($w,ylogscale)} { + set y [lh_chart::ymap_log $mt_d $ph_d $ymin $ymax $v] + } else { + set y [lh_chart::ymap_lin $mt_d $ph_d $ymin $ymax $v] + } + $c create line [expr {$axis_x - $tick_long}] $y $axis_x $y \ + -fill black + $c create text [expr {$axis_x - $tick_long - 2}] $y \ + -text $label -anchor e -font {Helvetica -10} + } + set xticks $state($w,xticks) + if {[llength $xticks] == 0} { + set xticks [list $xmin [expr {($xmin+$xmax)/2.0}] $xmax] + } + foreach t $xticks { + if {$t < $xmin - 1e-9 || $t > $xmax + 1e-9} continue + set x [lh_chart::xmap $ml_d $pw_d $xmin $xrange $t] + $c create line $x $axis_y $x [expr {$axis_y + $tick_long}] \ + -fill black + $c create text $x [expr {$axis_y + $tick_long + 2}] \ + -text [format %g $t] -anchor n -font {Helvetica -10} + } +} + +proc lh_chart::fmt_num {v} { + # Format a number for axis labels. Switch to sci notation (e.g. + # 2E5, 1.5E6) once we'd otherwise need 5+ digits, so labels stay + # narrow enough to fit in the left margin. + if {$v == 0} { return "0" } + set av [expr {abs($v)}] + if {$av >= 10000 || $av < 0.01} { + set exp [expr {int(floor(log10($av) + 1e-9))}] + set mant [expr {$v / pow(10, $exp)}] + if {abs($mant - round($mant)) < 0.05} { + return [format "%dE%d" [expr {int(round($mant))}] $exp] + } else { + return [format "%.1fE%d" $mant $exp] + } + } + if {$v == int($v)} { return [format %.0f $v] } + return [format %g $v] +} + +proc lh_chart::xmap {ml pw xmin xrange v} { + return [expr {$ml + ($v - $xmin) / $xrange * $pw}] +} +proc lh_chart::ymap_lin {mt ph ymin ymax v} { + set r [expr {$ymax - $ymin}] + if {$r == 0} { set r 1 } + return [expr {$mt + $ph - ($v - $ymin) / double($r) * $ph}] +} +proc lh_chart::ymap_log {mt ph ymin ymax v} { + if {$v < $ymin} { set v $ymin } + set lmin [expr {log10($ymin)}] + set lmax [expr {log10($ymax)}] + set r [expr {$lmax - $lmin}] + if {$r == 0} { set r 1 } + set lv [expr {log10($v)}] + return [expr {$mt + $ph - ($lv - $lmin) / $r * $ph}] +} + +#------------------------------------------------------------------ +# Window capture without BLT. Strategy: +# 1. Tk 8.7+/9: image create photo -format window can grab a window. +# 2. Else: use ImageMagick `import -window ` to a temp PNG. +# Returns a tk photo image; caller is responsible for `image delete`. +proc lh_chart::capture_window {win} { + update idletasks + set img [image create photo] + if {![catch {$img read $win -format window} err]} { + return $img + } + image delete $img + set wid [winfo id $win] + set tmp /tmp/lh_snap_[pid]_[clock clicks].png + if {[catch {exec import -window $wid $tmp} err]} { + catch {file delete $tmp} + error "screenshot needs ImageMagick (apt install imagemagick): $err" + } + set img [image create photo -file $tmp] + catch {file delete $tmp} + return $img +} +#------------------------------------------------------------------ diff --git a/scripts/hal-histogram b/scripts/hal-histogram index d76d5af20ba..aecf183c64c 100755 --- a/scripts/hal-histogram +++ b/scripts/hal-histogram @@ -26,6 +26,9 @@ # started without using the linuxcnc script and # ::env(HALLIB_DIR) will not exist. source [file join [exec linuxcnc_var HALLIB_DIR] hal_procs_lib.tcl] +# lh_chart canvas bar-chart widget (replaces BLT, which has no Tcl/Tk 9 +# port). Shared with latency-histogram. +source [file join [exec linuxcnc_var HALLIB_DIR] lh_chart.tcl] proc threadname_for_pin {pinname} { thread_info tmp @@ -114,8 +117,18 @@ proc set_defaults {} { # 1 mS is minimum interval for after cmd # for 100bins *10mS = 1 sec update interval + # Default comp is histobinstream (atomic snapshot via HAL stream). + # --legacy switches to the original histobins comp, which transfers + # one bin per cycle so the snapshot is smeared across many ms and + # stats can desync from bins. + set ::HH(legacy) 0 + set ::HH(compname) histobinstream + # Streaming uses one shmem key per instance. histobins instances are + # loaded once and shared by every hal-histogram process, so the keys + # must be deterministic (not PID-derived): instance idx uses base+idx. + set ::HH(streamkey,base) 21000 + # housekeeping - set ::HH(compname) histobins set ::HH(instancename,prefix) histo set ::HH(nsamples) 0 set ::HH(info) "" @@ -175,6 +188,9 @@ proc config {} { } --show {set ::HH(opt,show) 1 } --verbose {set ::HH(opt,verbose) 1 } + --legacy {set ::HH(legacy) 1 + set ::HH(compname) histobins + } -* {usage "Unknown args:$::argv"} default { if {[llength $::argv] > 1} { usage "Too many pins were specified: <$::argv>" @@ -217,17 +233,13 @@ proc config {} { } ;# config proc load_packages {} { - if [catch {package require Tclx} msg] { - puts $msg - puts "To install: sudo apt-get install tclx" - exit 1 - } - signal trap SIGINT finish ;# uses Tclx - if [catch {package require BLT} msg] { - puts $msg - puts "To install: sudo apt-get install blt" - exit 1 + # Tclx is unavailable on Tcl 9; stub `signal` so the one trap call still + # works (Ctrl-C then won't run finish, but the GUI Exit button does). + if {[catch {package require Tclx}]} { + proc signal {args} {} ;# no-op stub } + signal trap SIGINT finish + # BLT no longer required: lh_chart draws the histogram on a Tk canvas. # augment ::auto_path for special case: # 1) RIP build (no install) @@ -243,14 +255,6 @@ proc load_packages {} { puts "For a RIP linuxcnc build, source rip-environment in this shell" exit 1 } - blt::bitmap define nbmap { - {8 8} - {0xc7,0x8f,0x1f,0x3e,0x7c, 0xf8,0xf1,0xe3} - } - blt::bitmap define pbmap { - {8 8} - {0xe3,0xf1,0xf8,0x7c, 0x3e,0x1f,0x8f,0xc7} - } } ;# load_packages proc make_gui { {w .} } { @@ -283,10 +287,11 @@ OS: $::tcl_platform(osVersion) [exec hostname]" \ set ::HH(widget) $f.graph catch {destroy $::HH(widget)} - blt::barchart $::HH(widget) \ + lh_chart::create $::HH(widget) \ -plotbackground honeydew1 \ -cursor arrow \ - -title "" + -title "" \ + -width 480 -height 384 pack $::HH(widget) -side left xaxis @@ -409,6 +414,10 @@ proc finish {} { after cancel [after info] progress $::HH(title)\n progress "Fini" + if {[info exists ::HH(stream,h)]} { + catch {hal_stream detach $::HH(stream,h)} + unset ::HH(stream,h) + } catch { hal delf $::HH(instance) $::HH(threadname) hal unlinkp $::HH(inputpinname) @@ -528,7 +537,17 @@ proc setup_hal {} { set names "$names,$::HH(instancename,prefix)-$i" } set names [string trimleft $names ,] - hal loadrt $::HH(compname) names=$names + if {$::HH(legacy)} { + hal loadrt $::HH(compname) names=$names + } else { + # One deterministic shmem key per instance so any hal-histogram + # process can attach to the instance it claims. + set keys "" + for {set i 0} {$i < $::HH(max_histos)} {incr i} { + lappend keys [expr {$::HH(streamkey,base) + $i}] + } + hal loadrt $::HH(compname) names=$names keys=[join $keys ,] + } set idx 0 ;# first one used } else { set ::HH(instance) \ @@ -547,13 +566,6 @@ proc setup_hal {} { set ::HH(threadname) [threadname_for_pin $::HH(pinname)] - thread_info tinfo - if !$tinfo($::HH(threadname),fp) { - usage \ -"\n$::HH(pinname) must be running on a thread with floating point enabled -Use the loadrt motmod option: base_thread_fp=1" - } - if {[is_connected $::HH(pinname) signame] == "not_connected"} { set ::HH(signame) $::HH(signame,prefix,$::HH(pintype))-$idx set ::HH(signame_is_new) 1 @@ -594,6 +606,20 @@ Use the loadrt motmod option: base_thread_fp=1" exit 1 } set ::HH(info) "Pin: $::HH(pinname) Sig: $::HH(signame) ($::HH(instance))" + + if {!$::HH(legacy)} { + # Attach the Tcl hal_stream binding to this instance's FIFO. The + # handle stays open for the session and is detached in finish. + set ::HH(streamkey) [expr {$::HH(streamkey,base) + $idx}] + if {[catch {set h [hal_stream attach $::HH(streamkey) u]} err]} { + popup "hal_stream attach failed for $::HH(instance): $err" + exit 1 + } + set ::HH(stream,h) $h + # An instance may be reused after a prior process exited; drop any + # stale records so the first real snapshot reads in phase. + catch {hal_stream drain $h} + } } ;# setup_hal proc start_collection {} { @@ -661,85 +687,135 @@ proc xaxis {} { } ;# xaxis proc update_chart {} { - set w $::HH(widget) + if {$::HH(legacy)} { + set data [acquire_bins_legacy] + } else { + set data [acquire_bins_stream] + if {$data eq ""} return ;# timeout / out-of-sync: skip this cycle + } + render_chart {*}$data +} ;# update_chart + +proc acquire_bins_legacy {} { + # Per-bin polling against the histobins comp. Has a known RT/non-RT + # race: bins are read one cycle at a time so the snapshot is smeared + # and stats can desync from bins. Sets ::HH(pextra)/::HH(nextra) from + # pins; returns [list pxd pyd]. set dly $::HH(dly,ms) - set pmore 0 ;# not currently used - set nmore 0 ;# not currently used + set pxd {}; set pyd {} for {set bin 0} {$bin < $::HH(nbins)} {incr bin} { hal setp $::HH(instance).index $bin set ct 0 while 1 { after $dly set chk [hal getp $::HH(instance).check] - if {$bin == $chk} { - break - } else { - # retry (probably only needed for (irrelevant) non-realtime threads) - incr ct - set retry_ct 100 - if {$ct > $retry_ct} { - parrah ::HH - puts "$::HH(prog):update_chart: retry exceeded $retry_ct" - puts [hal show funct $::HH(instancename)] - puts "EXITHERE" - finish - } - incr ::HH(reread,ct) - if {$ct > 1} { - incr dly - incr ::HH(bump,ct) - } + if {$bin == $chk} break + # retry (probably only needed for (irrelevant) non-realtime threads) + incr ct + set retry_ct 100 + if {$ct > $retry_ct} { + puts "$::HH(prog):update_chart: retry exceeded $retry_ct" + puts [hal show funct $::HH(instancename)] + finish + } + incr ::HH(reread,ct) + if {$ct > 1} { + incr dly + incr ::HH(bump,ct) } } set pbin [hal getp $::HH(instance).binvalue] # 1.1 value makes single unit nbins show as pips when using log y scale: if {$pbin == 1} {set pbin 1.1} - - lappend pxd [expr $::HH(minvalue) +(0.5 + $bin) * $::HH(binsize)] + lappend pxd [expr {$::HH(minvalue) + (0.5 + $bin) * $::HH(binsize)}] lappend pyd $pbin - } ;# for bin - + } set ::HH(pextra) [hal getp $::HH(instance).pextra] set ::HH(nextra) [hal getp $::HH(instance).nextra] + return [list $pxd $pyd] +} ;# acquire_bins_legacy + +proc acquire_bins_stream {} { + # Atomic snapshot via the histobinstream FIFO. Rising edge on `stream` + # makes RT push nbins+2 records (ntail, bins, ptail). Wait for FIFO + # depth, drain via the Tcl hal_stream binding, lower the trigger. Sets + # ::HH(pextra)/::HH(nextra) from the stream; returns [list pxd pyd], or + # "" if the snapshot could not be read cleanly. + set N $::HH(nbins) + set need [expr {$N + 2}] + set h $::HH(stream,h) + hal setp $::HH(instance).stream 1 + # Wait until exactly `need` records are queued. 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 $::HH(instance).stream 0 + if {[hal getp $::HH(instance).stream-error]} { + puts "$::HH(prog): stream-error set (FIFO too small for $need records)" + } else { + puts "$::HH(prog): stream timeout (depth [hal_stream depth $h] < $need)" + } + return "" + } + } + set vals [hal_stream drain $h] + hal setp $::HH(instance).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 "$::HH(prog): stream out-of-sync ([llength $vals]/$need, leftover=$leftover)" + return "" + } + # Stream order: ntail, bin[0..N-1], ptail + set ::HH(nextra) [lindex $vals 0] + set ::HH(pextra) [lindex $vals end] + set pxd {}; set pyd {} + for {set bin 0} {$bin < $N} {incr bin} { + set v [lindex $vals [expr {$bin + 1}]] + if {$v == 1} {set v 1.1} + lappend pxd [expr {$::HH(minvalue) + (0.5 + $bin) * $::HH(binsize)}] + lappend pyd $v + } + return [list $pxd $pyd] +} ;# acquire_bins_stream + +proc render_chart {pxd pyd} { + set w $::HH(widget) + set pmore 0 ;# not currently used + set nmore 0 ;# not currently used set ::HH(input_min) [format %.3g [hal getp $::HH(instance).input-min]] set ::HH(input_max) [format %.3g [hal getp $::HH(instance).input-max]] - - set nsamples [format %u [hal getp $::HH(instance).nsamples]] - set ::HH(nsamples) $nsamples - - set mean [hal getp $::HH(instance).mean] + set ::HH(nsamples) [format %u [hal getp $::HH(instance).nsamples]] set variance [hal getp $::HH(instance).variance] - set sdev [expr sqrt($variance)] set mean [hal getp $::HH(instance).mean] -# puts [format "m=%10.3f %8.3f s=%8.3f %d" \ -# $mean $variance $sdev $nsamples] - set ::HH(sdev) [format %.3g $sdev] + set ::HH(sdev) [format %.3g [expr {sqrt(abs($variance))}]] set ::HH(mean) [format %.3g $mean] - set ::HH(p,more) [expr $pmore + $::HH(pextra)] - set ::HH(n,more) [expr $nmore + $::HH(nextra)] + set ::HH(p,more) [expr {$pmore + $::HH(pextra)}] + set ::HH(n,more) [expr {$nmore + $::HH(nextra)}] if {$::HH(p,more) == 1} {set ::HH(p,more) 1.1} ;# show as pip if {$::HH(n,more) == 1} {set ::HH(n,more) 1.1} ;# show as pip - set pcolor $::HH(color) set pmaxcolor white if {$::HH(pextra) > 0} { - set pcolor red - set pmaxcolor $pcolor - $::HH(widget,posbins) conf -fg $pcolor + set pmaxcolor red + $::HH(widget,posbins) conf -fg red } elseif {$::HH(p,more) > 0} { $::HH(widget,posbins) conf -fg $::HH(color) } else { $::HH(widget,posbins) conf -fg black } - set ncolor $::HH(color) set nmaxcolor white if {$::HH(nextra) > 0} { - set ncolor blue - set nmaxcolor $ncolor - $::HH(widget,negbins) conf -fg $ncolor + set nmaxcolor blue + $::HH(widget,negbins) conf -fg blue } elseif {$::HH(n,more) > 0} { $::HH(widget,negbins) conf -fg $::HH(color) } else { @@ -754,13 +830,13 @@ proc update_chart {} { set ::HH(n,more) [format %.0f $::HH(n,more)] ;# clear pip $w element configure pmindata \ - -xdata [expr -0.5*$::HH(binsize) + $::HH(minvalue)] \ + -xdata [expr {-0.5*$::HH(binsize) + $::HH(minvalue)}] \ -ydata $nyd_max_pos \ -stipple nbmap \ -fg $::HH(color) -bg $nmaxcolor $w element configure pdata -xdata $pxd -ydata $pyd $w element configure pmaxdata \ - -xdata [expr +0.5*$::HH(binsize) + $::HH(maxvalue)]\ + -xdata [expr {+0.5*$::HH(binsize) + $::HH(maxvalue)}] \ -ydata $pyd_max_pos \ -stipple pbmap \ -fg $::HH(color) -bg $pmaxcolor @@ -768,7 +844,7 @@ proc update_chart {} { # a y axis configure is needed, updates may fail without it $::HH(widget) axis configure y -logscale $::HH(y,logscale) update -} ;# update_chart +} ;# render_chart proc is_int {v} { set v [format %.30g $v] ;# first: expand if v is in exponential format @@ -854,6 +930,7 @@ proc usage { {errtxt ""} } { puts " --text note (text display, default: \"$::HH(note,txt)\" )" puts " --show (show count of undisplayed nbins, default off)" puts " --verbose (progress and debug, default off)" + puts " --legacy (use original histobins comp; has RT/non-RT data race)" puts "" puts "Notes:" @@ -861,9 +938,6 @@ proc usage { {errtxt ""} } { puts " 2) If no pinname is specified, default is: $::HH(pinname)" puts " 3) This app may be opened for $::HH(max_histos) pins" puts " 4) pintypes float, s32, u32, bit are supported" - puts " 5) The pin must be associated with a thread supporting floating point" - puts " For a base thread, this may require using:" - puts " loadrt motmod ... base_thread_fp=1" if {"$errtxt" != ""} { puts "" @@ -875,14 +949,11 @@ proc usage { {errtxt ""} } { } ;# usage #------------------------------------------------------------------ -proc bltCaptureWindow { win } { - set image [image create photo] - blt::winop snap $win $image - return $image -} ;# bltCaptureWindow - proc windowToFile { win } { - set image [bltCaptureWindow $win] + if {[catch {set image [lh_chart::capture_window $win]} msg]} { + popup $msg + return + } set types {{"Image Files" {.png}}} set ifile $::tcl_platform(user)-$::HH(date)-$::HH(elapsed).png set filename [tk_getSaveFile -filetypes $types \ diff --git a/scripts/latency-histogram b/scripts/latency-histogram index 99e2542df7d..014b63f582f 100755 --- a/scripts/latency-histogram +++ b/scripts/latency-histogram @@ -27,498 +27,10 @@ set ::MICROSEC \u00b5s #----------------------------------------------------------------------- -# lh_chart: minimal canvas-based bar chart implementing the subset of -# blt::barchart used by this script. Goal: visual + behavioral parity -# without depending on BLT (which has no Tcl/Tk 9 port). -# -# Public API (used at $w via command rename + dispatch): -# $w axis configure x|y -min -max -majorticks -logscale -hide -showticks -# $w element create|configure NAME -xdata -ydata -fg -bg -barwidth -stipple -# $w element exists NAME -# $w legend configure -hide 0|1 -# Constructor: -# lh_chart::create $w -title T -width W -height H \ -# -plotbackground COLOR -cursor C -#----------------------------------------------------------------------- -namespace eval lh_chart { - variable state - variable stipple_map - array set stipple_map {} -} - -proc lh_chart::install_stipples {} { - variable stipple_map - if {[info exists stipple_map(_installed)]} return - set dir /tmp/lh_chart_stipples_[pid] - catch {file mkdir $dir} - # Tk's XBM reader is picky: needs static char (signed, not unsigned) - # and the data block in K&R-style continuation form with a trailing - # closing-brace-semicolon on its own line. One-liners are rejected. - foreach {name bits} { - pbmap {0xe3 0xf1 0xf8 0x7c 0x3e 0x1f 0x8f 0xc7} - nbmap {0xc7 0x8f 0x1f 0x3e 0x7c 0xf8 0xf1 0xe3} - } { - set fp [open $dir/$name.xbm w] - puts $fp "#define ${name}_width 8" - puts $fp "#define ${name}_height 8" - puts $fp "static char ${name}_bits\[\] = \{" - puts $fp " [join $bits {, }]\};" - close $fp - set stipple_map($name) "@$dir/$name.xbm" - } - set stipple_map(_installed) 1 -} - -proc lh_chart::create {w args} { - variable state - install_stipples - array set opts { - -title "" - -width 480 - -height 384 - -plotbackground honeydew1 - -cursor arrow - } - array set opts $args - canvas $w \ - -width $opts(-width) \ - -height $opts(-height) \ - -bg "#d9d9d9" \ - -bd 0 -highlightthickness 0 \ - -cursor $opts(-cursor) - set state($w,title) $opts(-title) - set state($w,width) $opts(-width) - set state($w,height) $opts(-height) - set state($w,plotbg) $opts(-plotbackground) - set state($w,xmin) -1.0 - set state($w,xmax) 1.0 - set state($w,ymin) 0.0 - set state($w,ymax) 1.0 - set state($w,ylogscale) 0 - set state($w,xticks) {} - set state($w,elements) {} - set state($w,legend_hide) 1 - set state($w,dirty) 1 - set state($w,redraw_pending) 0 - bind $w [list lh_chart::on_configure $w] - rename ::$w ::lh_chart::_orig_$w - proc ::$w {args} "::lh_chart::dispatch $w {*}\$args" - lh_chart::schedule_redraw $w - return $w -} - -proc lh_chart::dispatch {w args} { - set sub [lindex $args 0] - set rest [lrange $args 1 end] - switch -- $sub { - axis { return [lh_chart::cmd_axis $w {*}$rest] } - element { return [lh_chart::cmd_element $w {*}$rest] } - legend { return [lh_chart::cmd_legend $w {*}$rest] } - default { return [::lh_chart::_orig_$w {*}$args] } - } -} - -proc lh_chart::cmd_axis {w sub which args} { - variable state - if {$sub ne "configure"} { error "lh_chart axis: unsupported subcommand $sub" } - array set opts $args - if {$which eq "x"} { - if {[info exists opts(-min)]} { set state($w,xmin) $opts(-min) } - if {[info exists opts(-max)]} { set state($w,xmax) $opts(-max) } - if {[info exists opts(-majorticks)]} { set state($w,xticks) $opts(-majorticks) } - } elseif {$which eq "y"} { - if {[info exists opts(-logscale)]} { set state($w,ylogscale) $opts(-logscale) } - if {[info exists opts(-min)]} { set state($w,ymin) $opts(-min) } - if {[info exists opts(-max)]} { set state($w,ymax) $opts(-max) } - } - schedule_redraw $w -} - -proc lh_chart::cmd_element {w op name args} { - variable state - variable stipple_map - switch -- $op { - exists { - return [expr {[lsearch -exact $state($w,elements) $name] >= 0}] - } - create { - if {[lsearch -exact $state($w,elements) $name] < 0} { - lappend state($w,elements) $name - } - set state($w,el,$name,xdata) {} - set state($w,el,$name,ydata) {} - set state($w,el,$name,fg) black - set state($w,el,$name,bg) lightblue - set state($w,el,$name,barwidth) 1.0 - set state($w,el,$name,stipple) {} - cmd_element_apply $w $name $args - } - configure { - cmd_element_apply $w $name $args - } - default { error "lh_chart element: unsupported op $op" } - } - schedule_redraw $w -} - -proc lh_chart::cmd_element_apply {w name optlist} { - variable state - variable stipple_map - array set opts $optlist - foreach {k storekey} { - -xdata xdata - -ydata ydata - -fg fg - -bg bg - -barwidth barwidth - } { - if {[info exists opts($k)]} { - set state($w,el,$name,$storekey) $opts($k) - } - } - if {[info exists opts(-stipple)]} { - set s $opts(-stipple) - if {[info exists stipple_map($s)]} { set s $stipple_map($s) } - set state($w,el,$name,stipple) $s - } -} - -proc lh_chart::cmd_legend {w sub args} { - variable state - if {$sub eq "configure"} { - array set opts $args - if {[info exists opts(-hide)]} { set state($w,legend_hide) $opts(-hide) } - } -} - -proc lh_chart::on_configure {w} { - variable state - if {![info exists state($w,width)]} return - set state($w,width) [winfo width $w] - set state($w,height) [winfo height $w] - schedule_redraw $w -} - -proc lh_chart::schedule_redraw {w} { - variable state - set state($w,dirty) 1 - if {$state($w,redraw_pending)} return - set state($w,redraw_pending) 1 - after idle [list lh_chart::redraw $w] -} - -proc lh_chart::redraw {w} { - variable state - set state($w,redraw_pending) 0 - if {![winfo exists $w]} return - if {!$state($w,dirty)} return - set state($w,dirty) 0 - set c ::lh_chart::_orig_$w - $c delete all - - set W $state($w,width) - set H $state($w,height) - if {$W <= 1} { set W $state($w,width) } - - set ml 55 ; set mr 18 ; set mt 20 ; set mb 42 - set pw [expr {$W - $ml - $mr}] - set ph [expr {$H - $mt - $mb}] - if {$pw < 50 || $ph < 50} return - # Data inset: keep off-chart end bars (red-stippled at xmin/xmax) - # visibly inward from the border, matching BLT's plot margin. - set pad 8 - set ml_d [expr {$ml + $pad}] - set mt_d [expr {$mt + $pad}] - set pw_d [expr {$pw - 2*$pad}] - set ph_d [expr {$ph - 2*$pad}] - - set xmin $state($w,xmin) - set xmax $state($w,xmax) - set xrange [expr {double($xmax - $xmin)}] - if {$xrange == 0} { set xrange 1.0 } - - # auto-scale Y from element data - set ymax_data 1.0 - foreach name $state($w,elements) { - foreach v $state($w,el,$name,ydata) { - if {$v > $ymax_data} { set ymax_data $v } - } - } - if {$state($w,ylogscale)} { - set ymin 1.0 - if {$ymax_data < 10} { - set ymax 10.0 - } else { - # Nice ceiling: 1, 2, 5 times the decade — keeps Y range - # tight so a small data growth doesn't jump a full decade. - set decade [expr {pow(10, floor(log10($ymax_data)))}] - set ratio [expr {$ymax_data / $decade}] - if {$ratio <= 1.0} { - set ymax $decade - } elseif {$ratio <= 2.0} { - set ymax [expr {2.0 * $decade}] - } elseif {$ratio <= 5.0} { - set ymax [expr {5.0 * $decade}] - } else { - set ymax [expr {10.0 * $decade}] - } - } - } else { - set ymin 0.0 - # Nice ceiling for ymax: pick 1, 2, 2.5, 5, or 10 times a decade - # so the 5 equal ticks become round numbers (e.g. 0, 600, 1200, - # 1800, 2400, 3000) instead of (0, 580, 1160, ...). - if {$ymax_data <= 0} { - set ymax 1.0 - } else { - set goal [expr {$ymax_data * 1.05}] - set decade [expr {pow(10, floor(log10($goal)))}] - set ratio [expr {$goal / $decade}] - if {$ratio <= 1.0} { - set ymax $decade - } elseif {$ratio <= 2.0} { - set ymax [expr {2.0 * $decade}] - } elseif {$ratio <= 2.5} { - set ymax [expr {2.5 * $decade}] - } elseif {$ratio <= 5.0} { - set ymax [expr {5.0 * $decade}] - } else { - set ymax [expr {10.0 * $decade}] - } - } - } - set state($w,ymin) $ymin - set state($w,ymax) $ymax - - set lxmin [expr {$state($w,ylogscale) ? log10($ymin) : 0}] - set lxmax [expr {$state($w,ylogscale) ? log10($ymax) : 0}] - set lyrange [expr {$lxmax - $lxmin}] - if {$lyrange == 0} { set lyrange 1 } - - # plot area background (no border yet, axis lines drawn last) - $c create rectangle $ml $mt [expr {$ml+$pw}] [expr {$mt+$ph}] \ - -fill $state($w,plotbg) -outline "" - - # title - if {$state($w,title) ne ""} { - $c create text [expr {$ml + $pw/2}] [expr {$mt - 9}] \ - -text $state($w,title) -anchor center -font {Helvetica -12} - } - - # Y axis: build tick lists + draw gridlines now (ticks/labels at end). - # Major ticks get a label and a long tick line; minor ticks at every - # sub-decade gridline get a short tick line only (matches BLT). - set y_ticks {} ;# list of {value label} — major - set y_minor_ticks {} ;# list of values — minor - if {$state($w,ylogscale)} { - # Minor gridlines at 2..9 within each decade - set d 1.0 - while {$d < $ymax + 0.1} { - for {set k 2} {$k <= 9} {incr k} { - set v [expr {$d * $k}] - if {$v > $ymax + 0.1} break - set y [lh_chart::ymap_log $mt_d $ph_d $ymin $ymax $v] - $c create line $ml $y [expr {$ml+$pw}] $y \ - -fill gray70 -dash {1 1} - lappend y_minor_ticks $v - } - set d [expr {$d * 10}] - } - # Major gridlines at each decade - set d 1.0 - set exp 0 - while {$d <= $ymax + 0.001} { - set y [lh_chart::ymap_log $mt_d $ph_d $ymin $ymax $d] - $c create line $ml $y [expr {$ml+$pw}] $y -fill gray70 -dash {1 1} - lappend y_ticks [list $d "1E$exp"] - set d [expr {$d * 10}] - incr exp - } - # Cap tick at ymax if it sits between decades (2x or 5x of decade) - set top_decade [expr {pow(10, floor(log10($ymax) + 1e-9))}] - set top_ratio [expr {$ymax / $top_decade}] - if {$top_ratio > 1.5} { - set top_exp [expr {int(floor(log10($ymax) + 1e-9))}] - set top_mant [expr {int(round($top_ratio))}] - lappend y_ticks [list $ymax "${top_mant}E$top_exp"] - } - } else { - set steps 5 - for {set i 0} {$i <= $steps} {incr i} { - set v [expr {$ymin + ($ymax - $ymin) * $i / double($steps)}] - set y [lh_chart::ymap_lin $mt_d $ph_d $ymin $ymax $v] - $c create line $ml $y [expr {$ml+$pw}] $y -fill gray80 -dash {2 2} - lappend y_ticks [list $v [lh_chart::fmt_num $v]] - } - } - - # baseline (y=0 in linear or y=1 in log) using inset mapping - set y0 [expr {$state($w,ylogscale) \ - ? [lh_chart::ymap_log $mt_d $ph_d $ymin $ymax 1.0] \ - : [lh_chart::ymap_lin $mt_d $ph_d $ymin $ymax 0.0]}] - - # Bars: BLT semantics — `-fg` is the fill color, `-bg` shows through - # stipple. We draw solid fg-fill with matching outline so narrow bars - # render as a single fg-colored column (1-2 px) without any sub-bar - # outline lines splitting adjacent bars. For stippled bars (off-chart - # indicators) we paint bg first, then a stippled fg layer on top. - foreach name $state($w,elements) { - set xd $state($w,el,$name,xdata) - set yd $state($w,el,$name,ydata) - set bw $state($w,el,$name,barwidth) - set fg $state($w,el,$name,fg) - set bg $state($w,el,$name,bg) - set st $state($w,el,$name,stipple) - set hbw [expr {$bw / 2.0}] - foreach x $xd y $yd { - if {$y <= 0} continue - if {$state($w,ylogscale) && $y < $ymin} continue - set xa [expr {$x - $hbw}] - set xb [expr {$x + $hbw}] - if {$xb < $xmin || $xa > $xmax} continue - if {$xa < $xmin} { set xa $xmin } - if {$xb > $xmax} { set xb $xmax } - set pxa [lh_chart::xmap $ml_d $pw_d $xmin $xrange $xa] - set pxb [lh_chart::xmap $ml_d $pw_d $xmin $xrange $xb] - # Pixel-snap so sub-pixel bars (e.g. 0.1us bins at ~1.2 px each) - # always paint at least one full pixel and adjacent bars touch. - set pxa [expr {int(floor($pxa))}] - set pxb [expr {int(ceil($pxb))}] - if {$pxb <= $pxa} { set pxb [expr {$pxa + 1}] } - # Off-chart (stippled) end-of-range bars: minimum 2 px so the - # stipple pattern is actually visible and matches BLT. - if {$st ne "" && [expr {$pxb - $pxa}] < 2} { - set pxb [expr {$pxa + 2}] - } - if {$state($w,ylogscale)} { - set py [lh_chart::ymap_log $mt_d $ph_d $ymin $ymax $y] - } else { - set py [lh_chart::ymap_lin $mt_d $ph_d $ymin $ymax $y] - } - if {$st ne ""} { - $c create rectangle $pxa $py $pxb $y0 \ - -fill $bg -outline $bg -width 0 - $c create rectangle $pxa $py $pxb $y0 \ - -fill $fg -outline $fg -width 0 -stipple $st - } else { - $c create rectangle $pxa $py $pxb $y0 \ - -fill $fg -outline $fg -width 0 - } - } - # Continuous baseline: 1 px line in the element's fg color along - # the bottom of the data area, so the bottom doesn't look broken - # where bins have zero counts. - if {[llength $xd] > 0} { - $c create line \ - [lh_chart::xmap $ml_d $pw_d $xmin $xrange $xmin] $y0 \ - [lh_chart::xmap $ml_d $pw_d $xmin $xrange $xmax] $y0 \ - -fill $fg - } - } - - # Plot frame: 3D raised look. Only TOP and LEFT have a black outline - # (the lit edges); BOTTOM and RIGHT are left without an outer black - # line. Inside, top+left have a darker shadow line and bottom+right - # a lighter highlight, giving the panel-edge relief BLT used. - set xR [expr {$ml+$pw}] - set yB [expr {$mt+$ph}] - $c create line $ml $mt $xR $mt -fill black - $c create line $ml $mt $ml $yB -fill black - $c create line [expr {$ml+1}] [expr {$mt+1}] [expr {$xR-1}] [expr {$mt+1}] \ - -fill gray45 - $c create line [expr {$ml+1}] [expr {$mt+1}] [expr {$ml+1}] [expr {$yB-1}] \ - -fill gray45 - $c create line [expr {$ml+1}] [expr {$yB-1}] [expr {$xR-1}] [expr {$yB-1}] \ - -fill white - $c create line [expr {$xR-1}] [expr {$mt+1}] [expr {$xR-1}] [expr {$yB-1}] \ - -fill white - - # Axis line: separate black line OUTSIDE the plot border, with a - # small gap between them. Spans only the data-inset range so its - # endpoints sit right at the topmost and bottommost ticks (BLT - # behavior — the axis "ends with the last tick"). - set axis_gap 4 - set tick_long 10 - set tick_short 5 - set axis_x [expr {$ml - $axis_gap}] ;# left axis (Y) - set axis_y [expr {$yB + $axis_gap}] ;# bottom axis (X) - set axis_top $mt_d ;# = $mt + pad - set axis_bottom [expr {$mt_d + $ph_d}] - set axis_left $ml_d ;# = $ml + pad - set axis_right [expr {$ml_d + $pw_d}] - $c create line $axis_x $axis_top $axis_x $axis_bottom -fill black - $c create line $axis_left $axis_y $axis_right $axis_y -fill black - - # Tick marks attach to (touch) the axis line and point OUTWARD - # toward the labels. Major ticks long, minor ticks (Y only) short. - foreach v $y_minor_ticks { - set y [lh_chart::ymap_log $mt_d $ph_d $ymin $ymax $v] - $c create line [expr {$axis_x - $tick_short}] $y $axis_x $y \ - -fill black - } - foreach pair $y_ticks { - lassign $pair v label - if {$state($w,ylogscale)} { - set y [lh_chart::ymap_log $mt_d $ph_d $ymin $ymax $v] - } else { - set y [lh_chart::ymap_lin $mt_d $ph_d $ymin $ymax $v] - } - $c create line [expr {$axis_x - $tick_long}] $y $axis_x $y \ - -fill black - $c create text [expr {$axis_x - $tick_long - 2}] $y \ - -text $label -anchor e -font {Helvetica -10} - } - set xticks $state($w,xticks) - if {[llength $xticks] == 0} { - set xticks [list $xmin [expr {($xmin+$xmax)/2.0}] $xmax] - } - foreach t $xticks { - if {$t < $xmin - 1e-9 || $t > $xmax + 1e-9} continue - set x [lh_chart::xmap $ml_d $pw_d $xmin $xrange $t] - $c create line $x $axis_y $x [expr {$axis_y + $tick_long}] \ - -fill black - $c create text $x [expr {$axis_y + $tick_long + 2}] \ - -text [format %g $t] -anchor n -font {Helvetica -10} - } -} - -proc lh_chart::fmt_num {v} { - # Format a number for axis labels. Switch to sci notation (e.g. - # 2E5, 1.5E6) once we'd otherwise need 5+ digits, so labels stay - # narrow enough to fit in the left margin. - if {$v == 0} { return "0" } - set av [expr {abs($v)}] - if {$av >= 10000 || $av < 0.01} { - set exp [expr {int(floor(log10($av) + 1e-9))}] - set mant [expr {$v / pow(10, $exp)}] - if {abs($mant - round($mant)) < 0.05} { - return [format "%dE%d" [expr {int(round($mant))}] $exp] - } else { - return [format "%.1fE%d" $mant $exp] - } - } - if {$v == int($v)} { return [format %.0f $v] } - return [format %g $v] -} - -proc lh_chart::xmap {ml pw xmin xrange v} { - return [expr {$ml + ($v - $xmin) / $xrange * $pw}] -} -proc lh_chart::ymap_lin {mt ph ymin ymax v} { - set r [expr {$ymax - $ymin}] - if {$r == 0} { set r 1 } - return [expr {$mt + $ph - ($v - $ymin) / double($r) * $ph}] -} -proc lh_chart::ymap_log {mt ph ymin ymax v} { - if {$v < $ymin} { set v $ymin } - set lmin [expr {log10($ymin)}] - set lmax [expr {log10($ymax)}] - set r [expr {$lmax - $lmin}] - if {$r == 0} { set r 1 } - set lv [expr {log10($v)}] - return [expr {$mt + $ph - ($lv - $lmin) / $r * $ph}] -} +# 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] @@ -1409,30 +921,8 @@ proc usage {} { } ;# usage #------------------------------------------------------------------ -# Window capture without BLT. Strategy: -# 1. Tk 8.7+/9: image create photo -format window can grab a window. -# 2. Else: use ImageMagick `import -window ` to a temp PNG. -# Returns a tk photo image; caller is responsible for `image delete`. -proc captureWindow {win} { - update idletasks - set img [image create photo] - if {![catch {$img read $win -format window} err]} { - return $img - } - image delete $img - set wid [winfo id $win] - set tmp /tmp/lh_snap_[pid]_[clock clicks].png - if {[catch {exec import -window $wid $tmp} err]} { - catch {file delete $tmp} - error "screenshot needs ImageMagick (apt install imagemagick): $err" - } - set img [image create photo -file $tmp] - catch {file delete $tmp} - return $img -} ;# captureWindow - proc windowToFile { win } { - if {[catch {set image [captureWindow $win]} msg]} { + if {[catch {set image [lh_chart::capture_window $win]} msg]} { popup $msg return } diff --git a/src/hal/components/histobinstream.comp b/src/hal/components/histobinstream.comp new file mode 100644 index 00000000000..cf536c02426 --- /dev/null +++ b/src/hal/components/histobinstream.comp @@ -0,0 +1,255 @@ +component histobinstream "histogram bins utility for scripts/hal-histogram"; +description """ +Calculates a histogram of an input pin's value. +The histogram data is sent in a HAL stream for maximum transfer speed and to prevent any RT to non-RT data race conditions. +This is the streaming counterpart to the *histobins* component. + +Read the *availablebins* pin for the number of bins available. +Set the *minvalue*, *binsize* and *nbins* pins and ensure *nbins* ≤ *availablebins*. + +For *nbins* = N, the bins are numbered 0 ... N-1. +The value range covered is [*minvalue* ... *minvalue* + N * *binsize*). +Any input below *minvalue* is counted in the negative overflow (*ntail*). +Any input at or above the upper edge is counted in the positive overflow (*ptail*). + +The input used is selected based on pintype: +[options="header",cols="^1,1"] +|=== +^h|pintype +^h|inputpin + +|0|input +|1|input-s32 +|2|input-u32 +|3|input-bit +|=== + +Stream format and how to obtain the histogram data: + +* Set the *stream* pin to high. +* Read the fifo data when it becomes available. The data streamed has the + following sequence: +** 'ntail bin[0] ... bin[N-1] ptail' +** This gives 'nbins + 2' values streamed (all unsigned counts). +* Read the statistics pins (*input-min*, *input-max*, *mean*, *variance*, + *nsamples*) that reflect the values at the time when *stream* was asserted. +* Set the *stream* pin to low. + +The reset pin may be used to restart. +Note that the reset pin is set to high at startup. +You must set it to low before data collection begins. + +The *method* input pin selects an alternate variance calculation (0: Welford +incremental, 1: sum / sum-of-squares). + +Maintainers note: hardcoded for MAXBINNUMBER==200 +"""; +// "} make vim syntax highligting happy + +pin in u32 pintype "Select the input pin (0:input 1:input-s32 2:input-u32 3:input-bit)."; +pin in float input "Floating point input value (pintype 0)."; +pin in s32 input_s32 "Signed input value (pintype 1)."; +pin in u32 input_u32 "Unsigned input value (pintype 2)."; +pin in bit input_bit "Bit input value (pintype 3)."; + +pin in u32 nbins = 20 "Number of active bins N (0 ... N-1)."; +pin in float binsize = 1 "Width of one bin in input units."; +pin in float minvalue = 0 "Lower edge of bin 0."; + +pin in bit reset = 1 "Reset state and bins."; +pin in bit stream = 0 "Set to high to stream all bins and tails on rising edge."; +pin in bit method = 0 "Variance method (0:Welford incremental, 1:sum of squares)."; + +pin out bit stream_error "Set if the data stream did not fit and was never sent."; +pin out bit input_error "Set when input rules are violated; updates are invalid until fixed and a reset."; + +pin out float input_min "Minimum input value seen (latched on stream rising edge)."; +pin out float input_max "Maximum input value seen (latched on stream rising edge)."; +pin out u32 nsamples "Number of samples accumulated (latched on stream rising edge)."; +pin out float variance "Variance of the input (latched on stream rising edge)."; +pin out float mean "Mean of the input (latched on stream rising edge)."; +pin out s64 stream_time "The time it took for the stream data to be pushed out in nanoseconds (ns)."; + +// user may interrogate availablebins to determine this compiled-in limit +pin out s32 availablebins = 200; //MAXBINNUMBER + +option period no; +function _; +option extra_setup; +modparam dummy keys "Stream shmem unique key for each instance"; + +include ; +include ; + +variable int first = 1; +variable unsigned last_nbins = 0; +variable real_t last_binsize = 0; +variable real_t last_minvalue = 0; +variable real_t maxvalue = 0; + +variable hal_stream_data_u bins[200]; // MAXBINNUMBER +variable hal_stream_data_u ptail; // count of inputs >= upper edge +variable hal_stream_data_u ntail; // count of inputs < minvalue + +variable rtapi_u64 run_nsamples = 0; +variable real_t run_min = 1e99; +variable real_t run_max = -1e99; +variable real_t run_mean = 0; +variable real_t run_variance = 0; +variable real_t sum = 0; +variable real_t sq_sum = 0; +variable real_t m2 = 0; + +variable bool last_stream = 0; +variable hal_stream_t fifo; + +license "GPL"; +author "Dewey Garrett, B.Stultiens, LinuxCNC contributors"; +;; + +#define MAXBINNUMBER 200 + +#define MAX_INST 8 +static int keys[MAX_INST] = {}; +RTAPI_MP_ARRAY_INT(keys, MAX_INST, "Stream shmem keys"); + +// Note: the extra setup is run _before_ the pins are created +EXTRA_SETUP() { + (void)prefix; + + if (extra_arg < 0 || extra_arg >= MAX_INST || !keys[extra_arg]) + return -EINVAL; + + int err; + // The stream buffer should be able to contain one complete set of data: + // the negative tail, every bin and the positive tail. + if (0 != (err = hal_stream_create(&fifo, comp_id, keys[extra_arg], MAXBINNUMBER + 2, "u"))) + return err; + // The other side should run hal_stream_attach(&fifo, comp_id, key, "u") + return 0; +} + +FUNCTION(_) { + rtapi_s64 now = rtapi_get_time(); + + // Cache some pins + rtapi_u32 c_nbins= nbins; + real_t c_binsize = binsize; + real_t c_minvalue = minvalue; + + // Select the input according to pintype. + real_t invalue; + switch (pintype) { + case 0: invalue = input; break; + case 1: invalue = input_s32; break; + case 2: invalue = input_u32; break; + case 3: invalue = input_bit; break; + default: invalue = input; break; + } + + // Validate the requested bin geometry. binsize must be > 0 to avoid a + // divide by zero and to keep the bin index monotonic. + if (c_nbins < 1 || c_nbins > (unsigned)availablebins || c_binsize <= 0.0) { + input_error = 1; + last_stream = stream; // do not act on a stream edge while in error + return; + } + + if (reset) { + first = 1; + input_error = 0; + } + + if ( first + || c_nbins != last_nbins + || c_binsize != last_binsize + || c_minvalue != last_minvalue) { + first = 0; + maxvalue = c_minvalue + (real_t)c_nbins * c_binsize; + for (unsigned i = 0; i < c_nbins; i++) + bins[i].u = 0; + ptail.u = 0; + ntail.u = 0; + run_nsamples = 0; + run_min = 1e99; + run_max = -1e99; + run_mean = 0; + run_variance = 0; + sum = 0; + sq_sum = 0; + m2 = 0; + } else { + // Compare against minvalue for the low tail: a negative quotient + // truncates toward zero and would misfile such samples in bin 0. + // Index-test the high tail to avoid the bin[nbins] overflow that + // histobins writes at invalue == maxvalue. + if (invalue < c_minvalue) { + ntail.u++; + } else { + int idx = (int)((invalue - c_minvalue) / c_binsize); + if (idx >= (int)c_nbins) { + ptail.u++; + } else { + bins[idx].u++; + } + } + + if (invalue < run_min) run_min = invalue; + if (invalue > run_max) run_max = invalue; + + ++run_nsamples; + if (run_nsamples >= 2) { + if (method == 0) { + real_t delta = invalue - run_mean; + run_mean += delta / run_nsamples; + m2 += delta * (invalue - run_mean); + run_variance = m2 / (run_nsamples - 1); + } else { + sum += invalue; + sq_sum += invalue * invalue; + run_mean = sum / run_nsamples; + run_variance = (sq_sum - (sum * sum) / run_nsamples) / (run_nsamples - 1); + } + } else { + // First sample: Welford needs the mean seeded; the sum method + // needs its accumulators primed so a later switch stays correct. + run_mean = invalue; + sum = invalue; + sq_sum = invalue * invalue; + } + } + + last_nbins = c_nbins; + last_binsize = c_binsize; + last_minvalue = c_minvalue; + + bool b = stream; + // On the low-to-high transition latch the statistics and push the bins. + if (b && !last_stream) { + nsamples = (hal_u32_t)run_nsamples; + mean = run_mean; + variance = run_variance; + input_min = run_nsamples ? run_min : 0; + input_max = run_nsamples ? run_max : 0; + + unsigned need = c_nbins + 2; + int avail = hal_stream_maxdepth(&fifo) - hal_stream_depth(&fifo); + if (avail >= (int)need) { + // Negative overflow + hal_stream_write(&fifo, &ntail); + // All bins, in ascending order + for (unsigned i = 0; i < c_nbins; i++) + hal_stream_write(&fifo, &bins[i]); + // Positive overflow + hal_stream_write(&fifo, &ptail); + stream_error = 0; + stream_time = rtapi_get_time() - now; + } else { + // Not enough room to stream an entire set; never stream an + // incomplete data set. + stream_error = 1; + } + } + last_stream = b; +} +// vim: ts=4 sw=4 et