Attachment "test_scrollbar_perf.tcl" to
ticket [7caf9e9e]
added by
mtmcp_
2026-06-13 11:35:19.
Also attachment "test_scrollbar_perf.tcl" to
ticket [7caf9e9e]
added by
mtmcp_
2026-06-09 01:45:05.
# ttk image-element scrollbar performance test
#
# Exercises the ttkImage.c hot path (ImageElementDraw) with a custom
# image-based ttk::scrollbar so the effect of the element pixmap cache
# patch is measurable.
#
# Usage:
# wish test_scrollbar_perf.tcl
#
# Live metrics:
# Drag-resize the window. Each <Configure> on the vertical
# scrollbar is timed (stamp at event, resample at next idle) and
# the running count / last / avg / min / max are shown in the
# status bar at the bottom, the popout log window, AND printed to
# stdout.
#
# Key-triggered benchmarks (focus the toplevel first):
# h horizontal sweep toplevel WIDTH min<->max with forced
# redraws at each step. Per-step times come
# from the <Configure> binding; the bench also
# reports total ms and ms/step.
# v vertical same, sweeping HEIGHT.
# d diagonal same, sweeping width and height together.
# r reset zero the running resize stats.
# o opacity toggle trough AND thumb between fully opaque (default)
# and translucent (checkerboard trough, soft-cornered
# thumb), via the "alternate" state. The two scenarios:
# opaque -> the per-node cache hits (fast); translucent
# -> elements re-seed and miss (slow).
# a animate toggle the background colour animation. Every ~2s the
# scrollbars' "selected" state flips; the .background
# element maps it to a different colour, which auto-
# redraws. With a translucent trough the colour shows
# through the checkerboard holes -- the z-order node-cache
# invalidation check. On by default; toggle off (a) and
# keep the trough opaque for a clean perf number.
#
# A popout "Perf log" window collects every report line so they can
# be copy-pasted. "Copy all" puts the buffer on the clipboard,
# "Clear" empties it.
#
# Compare numbers between patched and unpatched Tk to validate the
# fix in tk-9.0-ttk-image-el-cache.diff.
# ------------------------------------------------------------------
package require Tk
# Hide the root while we build everything; deiconify it last so it
# ends up on top of the perf-log popout in the stacking order.
wm withdraw .
# ------------------------------------------------------------------
# Custom ttk image-element scrollbar (exercises ttkImage.c hot path).
# ------------------------------------------------------------------
image create photo img_thumb -width 14 -height 24
img_thumb put [string repeat {{#505050} } 14] -to 0 0 14 24
img_thumb transparency set 0 0 1
img_thumb transparency set 13 0 1
img_thumb transparency set 0 23 1
img_thumb transparency set 13 23 1
img_thumb put {{#80505050}} -to 1 0 2 1
img_thumb put {{#80505050}} -to 12 0 13 1
img_thumb put {{#80505050}} -to 1 23 2 24
img_thumb put {{#80505050}} -to 12 23 13 24
# Opaque thumb variant (default state); the 'o' opacity toggle adds the
# "alternate" state, mapped to the translucent img_thumb above.
image create photo img_thumb_solid -width 14 -height 24
img_thumb_solid put [string repeat {{#505050} } 14] -to 0 0 14 24
# Checkerboard trough: opaque cells alternating with fully transparent
# cells, so the background element beneath shows through the holes. 4px
# cells with the 4px 9-slice border keep the tiled pattern aligned at
# any size. This is the translucent node-cache test surface: the holes
# must always show the *current* background, recomposited on each redraw.
image create photo img_trough -width 16 -height 16
for {set cy 0} {$cy < 4} {incr cy} {
for {set cx 0} {$cx < 4} {incr cx} {
set col [expr {(($cx + $cy) % 2) ? "#00000000" : "#2a2a2a"}]
set x0 [expr {$cx * 4}] ; set y0 [expr {$cy * 4}]
img_trough put [string repeat "{$col} " 4] -to $x0 $y0 [expr {$x0+4}] [expr {$y0+4}]
}
}
# Opaque trough variant (default state); toggling opacity (o) adds the
# "alternate" state, mapped to the checkerboard (translucent) image above,
# so the cache's opaque (hit) vs translucent (miss) paths can be compared.
image create photo img_trough_solid -width 16 -height 16
img_trough_solid put [string repeat {{#2a2a2a} } 16] -to 0 0 16 16
image create photo img_uparrow -width 14 -height 10
img_uparrow put [string repeat {{#3a3a3a} } 14] -to 0 0 14 10
image create photo img_downarrow -width 14 -height 10
img_downarrow put [string repeat {{#3a3a3a} } 14] -to 0 0 14 10
# Horizontal-orientation arrows used by the horizontal scrollbar
image create photo img_leftarrow -width 10 -height 14
img_leftarrow put [string repeat {{#3a3a3a} } 10] -to 0 0 10 14
image create photo img_rightarrow -width 10 -height 14
img_rightarrow put [string repeat {{#3a3a3a} } 10] -to 0 0 10 14
# Background element: sits UNDER the trough as the layout root. Two
# solid colours selected by widget state (see the state map on the
# .background element); flipping the scrollbar's state swaps the colour
# AND auto-schedules a redraw -- that is what drives the test.
image create photo img_bgA -width 4 -height 4
img_bgA put [string repeat {{#1d6fa5} } 4] -to 0 0 4 4
image create photo img_bgB -width 4 -height 4
img_bgB put [string repeat {{#a5501d} } 4] -to 0 0 4 4
ttk::style element create MyCustom.Vscroll.trough image {img_trough_solid alternate img_trough} -border {4 4 4 4} -sticky nswe
ttk::style element create MyCustom.Vscroll.thumb image {img_thumb_solid alternate img_thumb} -border {4 6 4 6} -sticky nswe
ttk::style element create MyCustom.Vscroll.uparrow image img_uparrow
ttk::style element create MyCustom.Vscroll.downarrow image img_downarrow
ttk::style element create MyCustom.Hscroll.trough image {img_trough_solid alternate img_trough} -border {4 4 4 4} -sticky nswe
ttk::style element create MyCustom.Hscroll.thumb image {img_thumb_solid alternate img_thumb} -border {6 4 6 4} -sticky nswe
ttk::style element create MyCustom.Hscroll.leftarrow image img_leftarrow
ttk::style element create MyCustom.Hscroll.rightarrow image img_rightarrow
ttk::style element create MyCustom.Vscroll.background image {img_bgA selected img_bgB} -sticky nswe
ttk::style element create MyCustom.Hscroll.background image {img_bgA selected img_bgB} -sticky nswe
ttk::style layout Vertical.TScrollbar {
MyCustom.Vscroll.background -sticky nswe -children {
MyCustom.Vscroll.trough -sticky nswe -children {
MyCustom.Vscroll.uparrow -side top -sticky {}
MyCustom.Vscroll.downarrow -side bottom -sticky {}
MyCustom.Vscroll.thumb -sticky nswe
}
}
}
ttk::style layout Horizontal.TScrollbar {
MyCustom.Hscroll.background -sticky nswe -children {
MyCustom.Hscroll.trough -sticky nswe -children {
MyCustom.Hscroll.leftarrow -side left -sticky {}
MyCustom.Hscroll.rightarrow -side right -sticky {}
MyCustom.Hscroll.thumb -sticky nswe
}
}
}
# ------------------------------------------------------------------
# Build UI
#
# IMPORTANT: pack the fixed-height widgets (.status, .log popout
# trigger area) BEFORE the expanding .f frame. With pack, the
# widget packed first gets its required space first; an expanding
# widget packed first can push later widgets off-screen as the
# toplevel shrinks. Packing .status first keeps it visible at any
# window size.
# ------------------------------------------------------------------
label .status -anchor w -justify left -font {Courier 9} -text "press o=opacity a=animate h=width-sweep v=height-sweep d=diagonal-sweep r=reset" -relief sunken -padx 4 -pady 2
pack .status -fill x -side bottom
# Toolbar: same actions as the hotkeys. -takefocus 0 keeps focus on
# the toplevel so keypresses still work after clicking a button.
frame .toolbar -relief raised -borderwidth 1
ttk::button .toolbar.h -text "Width sweep (h)" -takefocus 0 -command {resizeBench h}
ttk::button .toolbar.v -text "Height sweep (v)" -takefocus 0 -command {resizeBench v}
ttk::button .toolbar.d -text "Diagonal sweep (d)" -takefocus 0 -command {resizeBench d}
ttk::button .toolbar.r -text "Reset stats (r)" -takefocus 0 -command {perf::reset}
ttk::button .toolbar.a -text "Animate (a)" -takefocus 0 -command {bgflip::toggle}
ttk::button .toolbar.o -text "Opacity (o)" -takefocus 0 -command {opacity::toggle}
ttk::button .toolbar.l -text "Show log" -takefocus 0 -command {log::show}
pack .toolbar.o .toolbar.a .toolbar.h .toolbar.v .toolbar.d .toolbar.r -side left -padx 2 -pady 2
pack .toolbar.l -side right -padx 2 -pady 2
pack .toolbar -fill x -side top
frame .f
text .f.t -wrap none -width 60 -height 30 -yscrollcommand {.f.vs set} -xscrollcommand {.f.hs set}
ttk::scrollbar .f.vs -orient vertical -command {.f.t yview}
ttk::scrollbar .f.hs -orient horizontal -command {.f.t xview}
grid .f.t -row 0 -column 0 -sticky nswe
grid .f.vs -row 0 -column 1 -sticky ns
grid .f.hs -row 1 -column 0 -sticky ew
grid rowconfigure .f 0 -weight 1
grid columnconfigure .f 0 -weight 1
pack .f -fill both -expand 1 -side top
for {set i 1} {$i <= 200} {incr i} {
.f.t insert end "Line $i: [string repeat {abcdefgh } 20]\n"
}
.f.t see 1.0
wm title . "Scrollbar Perf Test"
wm geometry . 600x500
wm minsize . 200 120
# ------------------------------------------------------------------
# Popout log window — copy-pastable stream of every report line.
# ------------------------------------------------------------------
namespace eval log {
proc build {} {
if {[winfo exists .log]} { return }
toplevel .log
wm title .log "Perf log"
wm geometry .log 640x320
frame .log.btns
button .log.btns.copy -text "Copy all" -command [namespace code copyAll]
button .log.btns.clear -text "Clear" -command [namespace code clear]
button .log.btns.save -text "Save..." -command [namespace code saveFile]
pack .log.btns.copy -side left -padx 2 -pady 2
pack .log.btns.clear -side left -padx 2 -pady 2
pack .log.btns.save -side left -padx 2 -pady 2
pack .log.btns -side top -fill x
# pack already manages .log (for .log.btns), so the text
# widget and its scrollbars live in their own frame where
# we can use grid.
frame .log.body
text .log.body.t -wrap none -font {Courier 9} -state disabled -yscrollcommand {.log.body.vs set} -xscrollcommand {.log.body.hs set}
ttk::scrollbar .log.body.vs -orient vertical -command {.log.body.t yview}
ttk::scrollbar .log.body.hs -orient horizontal -command {.log.body.t xview}
grid .log.body.t -row 0 -column 0 -sticky nswe
grid .log.body.vs -row 0 -column 1 -sticky ns
grid .log.body.hs -row 1 -column 0 -sticky ew
grid rowconfigure .log.body 0 -weight 1
grid columnconfigure .log.body 0 -weight 1
pack .log.body -side top -fill both -expand 1
# Closing the popout just hides it; data is preserved.
wm protocol .log WM_DELETE_WINDOW [list wm withdraw .log]
}
proc show {} {
build
wm deiconify .log
raise .log
}
proc append_line {msg} {
build
.log.body.t configure -state normal
.log.body.t insert end "$msg\n"
.log.body.t configure -state disabled
.log.body.t see end
}
proc copyAll {} {
clipboard clear
clipboard append [.log.body.t get 1.0 end-1c]
}
proc clear {} {
.log.body.t configure -state normal
.log.body.t delete 1.0 end
.log.body.t configure -state disabled
}
proc saveFile {} {
set f [tk_getSaveFile -defaultextension .log -initialfile scrollbar_perf.log]
if {$f eq ""} { return }
set ch [open $f w]
puts -nonewline $ch [.log.body.t get 1.0 end-1c]
close $ch
}
}
# ------------------------------------------------------------------
# Live <Configure> metrics
#
# Configure fires after geometry changes; the redraw runs as an
# idle callback. We stamp time on Configure, then resample again
# from `after idle` — the difference covers ttk image-element
# redraw work for that resize step. Bursts of Configures are
# coalesced by cancelling any still-pending idle sample.
# ------------------------------------------------------------------
namespace eval perf {
variable count 0
variable totalUs 0
variable minUs 0
variable maxUs 0
variable lastW 0
variable lastH 0
variable pendingT 0
variable pendingId ""
proc reset {} {
variable count 0
variable totalUs 0
variable minUs 0
variable maxUs 0
report "(stats reset)"
}
proc onConfigure {w h} {
variable lastW $w
variable lastH $h
variable pendingT [clock microseconds]
variable pendingId
if {$pendingId ne ""} { after cancel $pendingId }
set pendingId [after idle [namespace code finishSample]]
}
proc finishSample {} {
variable pendingId ""
variable pendingT
variable count
variable totalUs
variable minUs
variable maxUs
variable lastW
variable lastH
set dtUs [expr {[clock microseconds] - $pendingT}]
incr count
incr totalUs $dtUs
if {$count == 1 || $dtUs < $minUs} { set minUs $dtUs }
if {$dtUs > $maxUs} { set maxUs $dtUs }
set avg [expr {$totalUs / double($count)}]
report [format "resize n=%d last=%.2fms avg=%.2fms min=%.2fms max=%.2fms (%dx%d)" $count [expr {$dtUs/1000.0}] [expr {$avg/1000.0}] [expr {$minUs/1000.0}] [expr {$maxUs/1000.0}] $lastW $lastH]
}
proc report {msg} {
.status configure -text $msg
log::append_line $msg
puts $msg
}
}
# ------------------------------------------------------------------
# Background state-flip (key: a) -- correctness check, not perf.
#
# Every couple of seconds, flip the scrollbars' "selected" state. The
# .background element maps that state to a different colour, so the flip
# both changes the lower element AND auto-schedules a redraw (state
# changes go through ttk's normal redisplay path -- no forced Expose).
# On that redraw the background node misses its cache and marks its rect
# dirty; the checkerboard trough above must recomposite against the new
# colour. If the z-order invalidation regresses, the checkerboard holes
# freeze on the old colour while the rest of the widget repaints.
# ------------------------------------------------------------------
namespace eval bgflip {
variable on 1
variable phase 0
variable id ""
proc tick {} {
variable on ; variable phase ; variable id
if {!$on} return
set phase [expr {!$phase}]
foreach w {.f.vs .f.hs .log.body.vs .log.body.hs} {
if {[winfo exists $w]} {
$w state [expr {$phase ? "selected" : "!selected"}]
}
}
set id [after 2000 [namespace code tick]]
}
proc toggle {} {
variable on ; variable id
set on [expr {!$on}]
if {$on} {
tick
} elseif {$id ne ""} {
after cancel $id ; set id ""
}
perf::report "animation: [expr {$on ? {ON} : {off}}]"
}
}
# ------------------------------------------------------------------
# Opacity toggle (key: o)
#
# Flips the scrollbars' "alternate" state, which BOTH the trough and thumb
# elements map to their translucent images; the default shows opaque ones.
# The two scenarios to compare: fully opaque (default) -> every element is
# background-independent and the per-node cache hits (fast); translucent ->
# the elements re-seed and miss (slow). Opaque by default.
# ------------------------------------------------------------------
namespace eval opacity {
variable translucent 0
proc toggle {} {
variable translucent
set translucent [expr {!$translucent}]
foreach w {.f.vs .f.hs .log.body.vs .log.body.hs} {
if {[winfo exists $w]} {
$w state [expr {$translucent ? "alternate" : "!alternate"}]
}
}
perf::report "transparency: [expr {$translucent ? {on} : {off}}]"
}
}
bind . <KeyPress-a> {bgflip::toggle}
bind . <KeyPress-o> {opacity::toggle}
bind .f.vs <Configure> {perf::onConfigure %w %h}
# ------------------------------------------------------------------
# Automated benchmarks (key triggered)
# ------------------------------------------------------------------
# Resize bench: programmatically resize the toplevel through a
# range along the requested axis (or both for diagonal), forcing
# a full redraw at each step. `update` (not `update idletasks`)
# is required — update.n notes that resize-triggered work only
# runs via real events, not idle alone.
#
# The <Configure> binding records per-step timings automatically.
# This proc adds an overall summary line at the end.
#
# direction: h | v | d
proc resizeBench {direction} {
set wMin 400 ; set wMax 900
set hMin 300 ; set hMax 700
set step 20
# Anchor at min before measuring so the first Configure of
# the run reflects an actual size change.
wm geometry . "${wMin}x${hMin}"
update
perf::reset
set t0 [clock microseconds]
set steps 0
switch -- $direction {
h {
set name horizontal
for {set w $wMin} {$w <= $wMax} {incr w $step} {
wm geometry . "${w}x${hMin}" ; update ; incr steps
}
for {set w $wMax} {$w >= $wMin} {incr w -$step} {
wm geometry . "${w}x${hMin}" ; update ; incr steps
}
}
v {
set name vertical
for {set h $hMin} {$h <= $hMax} {incr h $step} {
wm geometry . "${wMin}x${h}" ; update ; incr steps
}
for {set h $hMax} {$h >= $hMin} {incr h -$step} {
wm geometry . "${wMin}x${h}" ; update ; incr steps
}
}
d {
set name diagonal
set n [expr {($wMax - $wMin) / $step}]
for {set i 0} {$i <= $n} {incr i} {
set w [expr {$wMin + $i * $step}]
set h [expr {$hMin + int(($hMax - $hMin) * $i / double($n))}]
wm geometry . "${w}x${h}" ; update ; incr steps
}
for {set i $n} {$i >= 0} {incr i -1} {
set w [expr {$wMin + $i * $step}]
set h [expr {$hMin + int(($hMax - $hMin) * $i / double($n))}]
wm geometry . "${w}x${h}" ; update ; incr steps
}
}
default { error "bad direction: $direction" }
}
set elapsed [expr {([clock microseconds] - $t0) / 1000.0}]
set per [expr {$elapsed / $steps}]
perf::report [format "resize-bench (%s): %d steps in %.1fms (%.2fms/step)" $name $steps $elapsed $per]
}
bind . <KeyPress-h> {resizeBench h}
bind . <KeyPress-v> {resizeBench v}
bind . <KeyPress-d> {resizeBench d}
bind . <KeyPress-r> {perf::reset}
# Build the popout, then map the main window last so it comes up
# on top in the stacking order.
log::build
update idletasks
wm deiconify .
raise .
focus -force .
# Background animation on by default ("all the time"): the translucent
# trough edges and thumb corners must stay in sync with it continuously.
after idle bgflip::tick
