jn
/
punkshell
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
1498 Commits
1 Branch
1 Tag
223 MiB
 
 
 
 
 
 
Tree: 8f446690c1
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from '8f446690c1'
${ noResults }
punkshell/scriptlib/developer/cpufloor_audit.tcl

276 lines
10 KiB
Raw Blame History

#cpufloor_audit.tcl - G-172 audit instrument: disassemble a distributed binary
#(or a pre-disassembled .text excerpt) and report instructions above a declared
#CPU instruction-set floor. The acceptance criterion of G-172 ("a flagless build
#of each distributed-artifact recipe emits zero instructions above the declared
#floor") is measurable by THIS tool rather than by a promise about build habits.
#
#The defect class (see goals/G-172-distributed-binary-cpu-floor.md Context): zig
#auto-vectorises ReleaseFast codegen to whatever the build host's CPU happens
#to expose when a recipe resolves cpu_model .determined_by_arch_os by NATIVE
#detection. On a Zen 5 host that is AVX-512 - real EVEX-encoded zmm-operand
#instructions at the front of .text. Tcl has no runtime CPU dispatch, so on a
#non-AVX-512 CPU the first one raises #UD and the process dies with
#STATUS_ILLEGAL_INSTRUCTION (0xC000001D) before writing a byte. The 2026-08-06
#regression shipped the entire published tclsh9.0.5 family (2756 zmm sites each)
#and the build-path tools (punkzip 1724, punkres 1423) - the bundled fixtures
#are real excerpts of that codegen class.
#
#Detection is by AVX REGISTER WIDTH, the same signal the Context measurements
#used: a `zmm[0-9]+` operand is AVX-512 (x86-64 v4), a `ymm[0-9]+` operand is
#AVX2 (x86-64 v3). Size specifiers (zmmword/ymmword/xmmword) never match - they
#lack the trailing digit. SSE4.2/POPCNT (the v2-only delta over baseline) is
#not detectable by width; baseline and v2 therefore share the same register
#ceiling (no AVX) and audit identically. The regression is AVX-width, so this
#is the honest instrument for it; a future finer-grained floor (per-instruction
#mnemonic classification) is a follow-on, not required by the acceptance.
#
#Plain tclsh, no dependencies. Exit 0 = no instructions above floor (PASS);
#exit 1 = out-of-floor instructions found (FAIL) or a selftest failure.
#
#Usage:
# tclsh cpufloor_audit.tcl ?-floor baseline|v2|v3|v4? <binary>
# Disassemble <binary>'s .text with a located objdump and audit it.
# llvm-objdump is preferred (Intel syntax), GNU objdump (-M intel) is the
# fallback. No disassembler on PATH is a hard error (install llvm-objdump,
# or pipe a pre-disassembled excerpt in with -from-dis).
# tclsh cpufloor_audit.tcl -from-dis ?-floor <f>? <dis-text-file>
# Audit a pre-disassembled .text excerpt (objdump -d output) directly -
# no disassembler needed. The bundled fixtures are this shape.
# tclsh cpufloor_audit.tcl -selftest
# Run the bundled fixtures (scriptlib/developer/cpufloor_fixtures/) through
# every floor and check the verdicts - the regression-as-fixture contract.
#
#Floor defaults to baseline (the project's chosen floor for the x86_64 family -
#see G-172 Approach 2: a Tcl interpreter's codegen delta against v2/v3 is
#negligible against the cost of the default runtime failing to start).
package require Tcl 8.6
proc scriptdir {} {
global argv0
return [file dirname [file normalize $argv0]]
}
proc floor_forbidden {floor} {
switch -- $floor {
baseline { return [dict create zmm 1 ymm 1] }
v2 { return [dict create zmm 1 ymm 1] }
v3 { return [dict create zmm 1 ymm 0] }
v4 { return [dict create zmm 0 ymm 0] }
default { error "unknown floor '$floor' (expected baseline, v2, v3 or v4)" }
}
}
#is <line> an instruction line (addr: hexbytes... mnemonic...)?
proc is_insn_line {line} {
return [regexp {^\s*[0-9a-fA-F]+:\s+([0-9a-fA-F]{2}\s)+} $line]
}
#extract the mnemonic of an instruction line (first token after the hex-byte run)
proc insn_mnemonic {line} {
if {![regexp {^\s*[0-9a-fA-F]+:\s+(.+)$} $line -> rest]} { return "" }
set rest [regsub {^([0-9a-fA-F]{2}\s+)+} $rest ""]
set rest [regsub {^\s+} $rest ""]
set mnem [lindex [split $rest \t] 0]
return [lindex [split $mnem " "] 0]
}
#audit a list of disassembly lines against a floor.
#returns dict: total zmm_sites ymm_sites out_of_floor first_rva sample_mnemonics
proc audit_lines {lines floor} {
set forbidden [floor_forbidden $floor]
set fz [dict get $forbidden zmm]
set fy [dict get $forbidden ymm]
set total 0
set zmm 0
set ymm 0
set out 0
set first_rva ""
set mnemonics {}
foreach line $lines {
if {![is_insn_line $line]} continue
incr total
set line_zmm [expr {[regexp {zmm[0-9]+} $line] ? 1 : 0}]
set line_ymm [expr {[regexp {ymm[0-9]+} $line] ? 1 : 0}]
if {$line_zmm} { incr zmm }
if {$line_ymm} { incr ymm }
set line_out 0
if {$line_zmm && $fz} { set line_out 1 }
if {$line_ymm && $fy} { set line_out 1 }
if {!$line_out} continue
incr out
if {$first_rva eq ""} {
regexp {^\s*([0-9a-fA-F]+):} $line -> first_rva
}
set mnem [insn_mnemonic $line]
if {$mnem ne "" && $mnem ni $mnemonics && [llength $mnemonics] < 12} {
lappend mnemonics $mnem
}
}
return [dict create total $total zmm_sites $zmm ymm_sites $ymm \
out_of_floor $out first_rva $first_rva sample_mnemonics $mnemonics]
}
#locate a disassembler and return a command prefix that disassembles .text in
#Intel syntax. Empty string = none found.
proc find_disassembler {} {
foreach {cmd} {
{llvm-objdump -d --section=.text --x86-asm-syntax=intel}
{objdump -d --section=.text -M intel}
} {
set exe [auto_execok [lindex $cmd 0]]
if {$exe ne ""} {
return [concat [list $exe] [lrange $cmd 1 end]]
}
}
return ""
}
proc read_lines {path} {
set f [open $path r]
fconfigure $f -translation binary
set data [read $f]
close $f
#normalise CRLF -> LF so the parser sees one line model
return [split [string map [list \r\n \n \r \n] $data] \n]
}
proc report {path floor res} {
set out [dict get $res out_of_floor]
set zmm [dict get $res zmm_sites]
set ymm [dict get $res ymm_sites]
set total [dict get $res total]
puts "cpufloor_audit: $path"
puts " floor: $floor"
puts " .text insns: $total"
puts " zmm sites (v4): $zmm"
puts " ymm sites (v3): $ymm"
puts " out-of-floor: $out"
if {$out > 0} {
puts " first out-of-floor RVA: [dict get $res first_rva]"
set ms [dict get $res sample_mnemonics]
if {[llength $ms]} {
puts " sample out-of-floor mnemonics: [join $ms {, }]"
}
puts " VERDICT: FAIL - instructions above the declared floor are present"
} else {
puts " VERDICT: PASS - no instructions above the declared floor"
}
}
proc usage {} {
puts stderr "usage: tclsh cpufloor_audit.tcl ?-floor baseline|v2|v3|v4? <binary>"
puts stderr " tclsh cpufloor_audit.tcl -from-dis ?-floor <f>? <dis-text-file>"
puts stderr " tclsh cpufloor_audit.tcl -selftest"
}
proc selftest {} {
set d [file join [scriptdir] cpufloor_fixtures]
set cases {
{avx512.dis.txt baseline 1}
{avx512.dis.txt v2 1}
{avx512.dis.txt v3 1}
{avx512.dis.txt v4 0}
{avx2.dis.txt baseline 1}
{avx2.dis.txt v2 1}
{avx2.dis.txt v3 0}
{avx2.dis.txt v4 0}
{clean.dis.txt baseline 0}
{clean.dis.txt v2 0}
{clean.dis.txt v3 0}
{clean.dis.txt v4 0}
}
set fail 0
foreach case $cases {
lassign $case fixture floor expect_fail
set p [file join $d $fixture]
if {![file exists $p]} {
puts "SELFTEST FAIL: fixture missing: $p"
incr fail
continue
}
set res [audit_lines [read_lines $p] $floor]
set got [dict get $res out_of_floor]
set got_fail [expr {$got > 0 ? 1 : 0}]
set zmm [dict get $res zmm_sites]
set ymm [dict get $res ymm_sites]
set status OK
if {$got_fail != $expect_fail} {
set status "MISMATCH (expected [expr {$expect_fail ? {FAIL} : {PASS}}])"
incr fail
}
puts [format "SELFTEST %-16s floor=%-9s zmm=%-4d ymm=%-4d out=%-4d %s" \
$fixture $floor $zmm $ymm $got $status]
}
if {$fail} {
puts "SELFTEST: $fail case(s) failed"
return 1
}
puts "SELFTEST: all cases pass"
return 0
}
#--- argv parsing ---
set floor baseline
set from_dis 0
set selftest_mode 0
set positional {}
foreach a $argv {
switch -- $a {
-floor { set expecting_floor 1 }
-from-dis { set from_dis 1 }
-selftest { set selftest_mode 1 }
-help - --help - -h {
usage; exit 0
}
default {
if {[info exists expecting_floor]} {
set floor $a
unset expecting_floor
} else {
lappend positional $a
}
}
}
}
if {[info exists expecting_floor]} {
usage; exit 1
}
if {$selftest_mode} {
exit [selftest]
}
if {[llength $positional] == 0} {
usage; exit 1
}
set target [lindex $positional 0]
if {![file exists $target]} {
puts stderr "cpufloor_audit: no such file: $target"
exit 1
}
if {$from_dis} {
set lines [read_lines $target]
} else {
set dis [find_disassembler]
if {$dis eq ""} {
puts stderr "cpufloor_audit: no disassembler found on PATH (tried llvm-objdump, objdump)."
puts stderr " install llvm-objdump, or pass a pre-disassembled excerpt with -from-dis."
exit 1
}
set cmd [concat $dis [list $target]]
if {[catch {exec {*}$cmd 2>@1} disout]} {
#objdump returns nonzero on some warnings but still emits disassembly;
#only treat as fatal if there is no instruction output at all
if {![regexp -inline {[0-9a-fA-F]+:} $disout]} {
puts stderr "cpufloor_audit: disassembler failed: $disout"
exit 1
}
}
set lines [split [string map [list \r\n \n \r \n] $disout] \n]
}
set res [audit_lines $lines $floor]
report $target $floor $res
exit [expr {[dict get $res out_of_floor] > 0 ? 1 : 0}]