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