forge phase 4: compaction strategies + GPU hardware tiers
ober
1aae20c1dc57983d150b74edb591cfbfb59dc112
--- a/build-binary.ss +++ b/build-binary.ss @@ -111,6 +111,7 @@ "lib/jcode/core/config" "lib/jcode/core/log" "lib/jcode/core/errors" + "lib/jcode/core/hardware" "lib/jcode/core/session" "lib/jcode/core/message" "lib/jcode/core/secrets" @@ -121,6 +122,7 @@ "lib/jcode/core/agents-md" "lib/jcode/core/hooks" "lib/jcode/core/compaction" + "lib/jcode/core/compaction-strategy" "lib/jcode/core/sandbox" "lib/jcode/core/repomap" "lib/jcode/core/checkpoints" @@ -338,6 +340,7 @@ "std/misc/thread" "std/misc/channel" "std/misc/ports" + "std/misc/process" "std/misc/retry" "std/misc/uuid" "std/misc/atom" --- a/src/jcode/core/agent.ss +++ b/src/jcode/core/agent.ss @@ -25,6 +25,8 @@ ./mentions ./agents-md ./compaction + ./compaction-strategy + ./models :jcode/provider/provider :jcode/tool/registry :jcode/guardrails/guardrails @@ -130,7 +132,10 @@ Be concise. Prefer edit over write for modifying existing files. (else (cons fresh messages)))) (mdl (or (current-model-override) (config-ref "model") ""))) (cond - ((should-compact? rebuilt mdl) (compact-messages rebuilt)) + ((should-compact? rebuilt mdl) + ;; Dispatch to the configured strategy (default Tiered). Budget is the + ;; model's context window; should-compact? already guaranteed it is set. + (run-configured-compaction rebuilt (model-context-window mdl))) (else rebuilt)))) (def (truncated-dir) new file mode 100644 --- /dev/null +++ b/src/jcode/core/compaction-strategy.ss @@ -0,0 +1,259 @@ +;;; jcode compaction strategies +;;; +;;; Faithful port of forge's context/strategies.py: NoCompact, +;;; SlidingWindowCompact, TieredCompact — plus JcodeLegacy, which wraps the +;;; pre-forge compaction.ss (a sliding-window + in-place-truncate hybrid) so +;;; the old behaviour stays one config flag away. The default is Tiered. +;;; +;;; A strategy is a procedure (strategy messages budget-tokens) that returns +;;; a pair (compacted-messages . phase-reached). phase 0 = untouched; 1+ is +;;; how aggressively it compacted (Tiered defines 1/2/3, see below). +;;; +;;; forge tags every Message with a MessageType and a step_index in metadata. +;;; jcode's message struct carries neither, so we DERIVE both: +;;; * message-derived-type — from role + tool-calls/tool-call-id/thinking +;;; * derive-step-indices — one "iteration" (step) opens at each assistant +;;; or user message; trailing tool results inherit it (matches forge's +;;; "iteration = one assistant message + N tool results"). +;;; The nudge MessageTypes (step/prerequisite/retry) are NOT shape-derivable — +;;; jcode injects nudges as plain user messages — so Phase-1 nudge-dropping is +;;; effectively a no-op until the message struct grows an explicit type tag. +;;; Tool-result truncation/dropping and reasoning/text dropping (the bulk of +;;; the win) work fully. + +(export message-derived-type + derive-step-indices + strategy-estimate-tokens + find-eligible-end + make-no-compact + make-sliding-window + make-tiered + make-jcode-legacy + compaction-strategy-by-name + configured-compaction-strategy-name + run-configured-compaction) + +(import :jcode/core/message + :jcode/guardrails/message-type + :jcode/core/config + :jcode/core/log + :jcode/core/compaction) + +(def logger (make-logger "compaction-strategy")) + +(def TRUNCATE-CHARS 200) + +;; ── Derivation: MessageType and step_index from jcode message shape ── + +(def (message-derived-type msg) + "Classify a jcode message into a forge MessageType tag by its shape." + (let ((role (message-role msg))) + (cond + ((equal? role "system") message-type-system-prompt) + ((equal? role "tool") message-type-tool-result) + ((equal? role "user") message-type-user-input) + ((equal? role "assistant") + (let ((tcs (message-tool-calls msg))) + (cond + ;; A message carrying tool calls is a tool_call message — its + ;; incidental text rides along (forge splits these; jcode bundles). + ((and tcs (pair? tcs)) message-type-tool-call) + ((and (message-thinking msg) + (let ((c (message-content msg))) + (or (not c) (= 0 (string-length c))))) + message-type-reasoning) + (else message-type-text-response)))) + (else message-type-text-response)))) + +(def (derive-step-indices messages) + "Parallel list of step-index (or #f) for MESSAGES. messages[0]/[1] are the + protected header → #f. From index 2, each assistant/user message opens a + new iteration; tool results inherit the current open step." + (let loop ((ms messages) (i 0) (step 0) (acc '())) + (cond + ((null? ms) (reverse acc)) + ((< i 2) (loop (cdr ms) (+ i 1) step (cons #f acc))) + (else + (let ((role (message-role (car ms)))) + (cond + ((or (equal? role "assistant") (equal? role "user")) + (let ((s (+ step 1))) (loop (cdr ms) (+ i 1) s (cons s acc)))) + (else + (let ((s (if (= step 0) 1 step))) + (loop (cdr ms) (+ i 1) step (cons s acc)))))))))) + +;; ── Shared helpers ────────────────────────────────────────────────── + +(def (strategy-estimate-tokens messages) + ;; forge _estimate_tokens: sum of content lengths // 4 (content only). + (quotient + (apply + (map (lambda (m) (string-length (or (message-content m) ""))) messages)) + 4)) + +(def (distinct-consecutive xs) + ;; Append a value whenever it differs from the previously appended one; + ;; skip #f. Mirrors forge's seen_steps accumulation exactly. + (let loop ((xs xs) (last #f) (acc '())) + (cond + ((null? xs) (reverse acc)) + ((not (car xs)) (loop (cdr xs) last acc)) + ((eqv? (car xs) last) (loop (cdr xs) last acc)) + (else (loop (cdr xs) (car xs) (cons (car xs) acc)))))) + +(def (find-eligible-end messages keep-recent) + "Boundary index: messages before it are eligible for compaction. Protects + the last KEEP-RECENT iterations (and always messages[0]/[1])." + (let* ((steps (derive-step-indices messages)) + (seen (distinct-consecutive steps)) + (total (length messages))) + (cond + ((<= (length seen) keep-recent) 2) + (else + (let ((cutoff (list-ref seen (- (length seen) keep-recent)))) + (let loop ((xs steps) (i 0)) + (cond + ((null? xs) total) + ((and (>= i 2) (car xs) (>= (car xs) cutoff)) i) + (else (loop (cdr xs) (+ i 1)))))))))) + +(def (nudge-type? ty) + (or (equal? ty message-type-step-nudge) + (equal? ty message-type-prerequisite-nudge) + (equal? ty message-type-retry-nudge))) + +;; ── NoCompact ─────────────────────────────────────────────────────── + +(def (make-no-compact) + "Passthrough. Returns messages unchanged (phase 0)." + (lambda (messages budget) (cons messages 0))) + +;; ── SlidingWindowCompact ──────────────────────────────────────────── + +(def (make-sliding-window keep-recent threshold) + "Keep system + first user + the last KEEP-RECENT iterations; drop the + middle. Fires only above THRESHOLD fraction of budget." + (lambda (messages budget) + (let ((trigger (exact (floor (* budget threshold))))) + (if (< (strategy-estimate-tokens messages) trigger) + (cons messages 0) + (let ((ee (find-eligible-end messages keep-recent))) + (if (<= ee 2) + (cons messages 1) + (cons (append (list (car messages) (cadr messages)) + (list-tail messages ee)) + 1))))))) + +;; ── TieredCompact (three-phase, default) ──────────────────────────── + +(def (make-tiered keep-recent threshold phase-thresholds) + "Three-phase compaction. PHASE-THRESHOLDS is #f (use THRESHOLD for all + three) or a list (p1 p2 p3) of budget fractions. Phases: + 1. drop nudges; truncate tool_results to first 200 chars + 2. + drop tool_results entirely (reasoning + text preserved) + 3. + drop reasoning + text_response (tool_call skeleton only) + A phase fires only if the previous one didn't get tokens below the next + threshold." + (let ((triggers (or phase-thresholds (list threshold threshold threshold)))) + (lambda (messages budget) + (let ((tokens (strategy-estimate-tokens messages)) + (t1 (exact (floor (* budget (list-ref triggers 0))))) + (t2 (exact (floor (* budget (list-ref triggers 1))))) + (t3 (exact (floor (* budget (list-ref triggers 2)))))) + (cond + ((< tokens t1) (cons messages 0)) + (else + (let ((ee (find-eligible-end messages keep-recent))) + (let ((r1 (tiered-phase1 messages ee))) + (if (< (strategy-estimate-tokens r1) t2) + (cons r1 1) + (let ((r2 (tiered-phase2 messages ee))) + (if (< (strategy-estimate-tokens r2) t3) + (cons r2 2) + (cons (tiered-phase3 messages ee) 3)))))))))))) + +(def (truncate-tool-result m) + (let* ((c (message-content m)) + (kept (substring c 0 TRUNCATE-CHARS)) + (removed (- (string-length c) TRUNCATE-CHARS))) + (make-tool-result (message-tool-call-id m) + (string-append kept "\n[Truncated — " (number->string removed) " chars removed]")))) + +(def (tiered-phase1 messages ee) + (let loop ((ms messages) (i 0) (acc '())) + (cond + ((null? ms) (reverse acc)) + ((and (>= i 2) (< i ee)) + (let* ((m (car ms)) (ty (message-derived-type m))) + (cond + ((nudge-type? ty) (loop (cdr ms) (+ i 1) acc)) + ((and (equal? ty message-type-tool-result) + (> (string-length (or (message-content m) "")) TRUNCATE-CHARS)) + (loop (cdr ms) (+ i 1) (cons (truncate-tool-result m) acc))) + (else (loop (cdr ms) (+ i 1) (cons m acc)))))) + (else (loop (cdr ms) (+ i 1) (cons (car ms) acc)))))) + +(def (tiered-phase2 messages ee) + (let loop ((ms messages) (i 0) (acc '())) + (cond + ((null? ms) (reverse acc)) + ((and (>= i 2) (< i ee)) + (let ((ty (message-derived-type (car ms)))) + (if (or (nudge-type? ty) (equal? ty message-type-tool-result)) + (loop (cdr ms) (+ i 1) acc) + (loop (cdr ms) (+ i 1) (cons (car ms) acc))))) + (else (loop (cdr ms) (+ i 1) (cons (car ms) acc)))))) + +(def (tiered-phase3 messages ee) + (let loop ((ms messages) (i 0) (acc '())) + (cond + ((null? ms) (reverse acc)) + ((and (>= i 2) (< i ee)) + (let ((ty (message-derived-type (car ms)))) + (if (or (nudge-type? ty) + (equal? ty message-type-tool-result) + (equal? ty message-type-reasoning) + (equal? ty message-type-text-response)) + (loop (cdr ms) (+ i 1) acc) + (loop (cdr ms) (+ i 1) (cons (car ms) acc))))) + (else (loop (cdr ms) (+ i 1) (cons (car ms) acc)))))) + +;; ── JcodeLegacy (the pre-forge behaviour, opt-in) ─────────────────── + +(def (make-jcode-legacy) + "Wraps compaction.ss's compact-messages (sliding-window + in-place stub). + Ignores budget — its trigger is the agent's should-compact? gate." + (lambda (messages budget) + (cons (compact-messages messages) 1))) + +;; ── Dispatch / config ─────────────────────────────────────────────── + +(def (compaction-strategy-by-name name keep-recent threshold) + (cond + ((equal? name "none") (make-no-compact)) + ((equal? name "sliding") (make-sliding-window keep-recent threshold)) + ((equal? name "legacy") (make-jcode-legacy)) + (else (make-tiered keep-recent threshold #f)))) + +(def (compaction-block-ref key default) + (let ((block (config-ref "compaction"))) + (if (and block (hash-table? block) (hash-key? block key)) + (hash-get block key) + default))) + +(def (configured-compaction-strategy-name) + (compaction-block-ref "strategy" "tiered")) + +(def (run-configured-compaction messages budget) + "Pick the strategy from jcode.json (compaction.strategy, default tiered), + run it against BUDGET tokens, log the phase reached, return the messages." + (let* ((name (compaction-block-ref "strategy" "tiered")) + (keep (compaction-block-ref "strategy_keep_recent" 2)) + (thr (compaction-block-ref "strategy_threshold" 0.75)) + (strat (compaction-strategy-by-name name keep thr)) + (res (strat messages budget)) + (out (car res)) + (phase (cdr res))) + (log-info logger "compacted" + `((strategy . ,name) (phase . ,phase) + (before . ,(length messages)) (after . ,(length out)))) + out)) --- a/src/jcode/core/errors.ss +++ b/src/jcode/core/errors.ss @@ -18,7 +18,10 @@ (export &forge-error make-forge-error forge-error? &unsupported-model unsupported-model-error? unsupported-model-error-model - raise-unsupported-model) + raise-unsupported-model + &hardware-detection hardware-detection-error? + hardware-detection-error-detail + raise-hardware-detection) ;; Root of the forge family. Derives from R6RS &error so error? holds and it ;; threads through the existing message-condition?/condition-message handling. @@ -44,3 +47,20 @@ model ". Either add an entry to the sampling map (with HF card URL) " "or drop strict sampling."))))) + +;; HardwareDetectionError — raised by the GPU probes (hardware.ss) when a +;; vendor tool produced output that should have parsed but did not (e.g. +;; nvidia-smi returned a malformed CSV row, or sysfs held a non-integer VRAM +;; size). A probe that simply finds nothing (no nvidia-smi, no AMD card) +;; returns #f rather than raising — this fires only on genuine corruption. +(define-condition-type &hardware-detection &forge-error + make-hardware-detection hardware-detection-error? + (detail hardware-detection-error-detail)) + +(def (raise-hardware-detection detail) + (raise + (condition + (make-hardware-detection detail) + (make-who-condition 'detect-hardware) + (make-message-condition + (string-append "Hardware probe produced unparseable output: " detail))))) new file mode 100644 --- /dev/null +++ b/src/jcode/core/hardware.ss @@ -0,0 +1,182 @@ +;;; jcode GPU hardware detection +;;; +;;; Faithful port of forge's context/hardware.py plus the VRAM tier→token +;;; budget table from server.py (_ollama_vram_tier_budget). +;;; +;;; detect-hardware reads total VRAM / unified memory from a probe ladder: +;;; 1. nvidia-smi (NVIDIA discrete) +;;; 2. AMD sysfs (/sys/class/drm/card*/device/{vendor,mem_info_vram_total}) +;;; Returns a hardware-profile or #f. A probe that simply finds nothing +;;; returns #f (and notes what it tried); only genuinely corrupt output +;;; raises &hardware-detection. +;;; +;;; ROCm tooling (rocm-smi) is intentionally not probed — forge's AMD backend +;;; is Vulkan/RADV. See forge issue #61. + +(export make-hardware-profile hardware-profile? + hardware-profile-gpu-name + hardware-profile-vram-total-mb + hardware-profile-gpu-vendor + hardware-profile-memory-kind + hardware-profile-vram-total-gb + quant-bpw-ref + detect-hardware + vram-tier-budget + vram-tier-budget-for-gb) + +(import :std/misc/string + :std/misc/ports + :std/misc/process + :std/os/path + :jcode/core/errors + :jcode/core/log) + +(def logger (make-logger "hardware")) + +;; Bits-per-weight for common GGUF quantisation levels (forge _QUANT_BPW). +;; Exposed for downstream model-size estimation; the detection ladder does +;; not consume it directly. +(def *quant-bpw* + '(("Q4_0" . 4.0) ("Q4_K_M" . 4.83) ("Q4_K_S" . 4.58) + ("Q5_0" . 5.0) ("Q5_K_M" . 5.68) ("Q5_K_S" . 5.52) + ("Q6_K" . 6.56) ("Q8_0" . 8.0) ("F16" . 16.0))) + +(def (quant-bpw-ref quant) + (let ((p (assoc quant *quant-bpw*))) + (and p (cdr p)))) + +;; AMD PCI vendor ID exposed at /sys/class/drm/card*/device/vendor. +(def *pci-vendor-amd* "0x1002") + +;; Detected GPU capabilities (total memory only — a stable value). +;; memory-kind distinguishes discrete VRAM ("discrete") from unified system +;; RAM carved out for the GPU ("unified": Strix Halo / Ryzen AI 300). +(defstruct hardware-profile (gpu-name vram-total-mb gpu-vendor memory-kind)) + +(def (hardware-profile-vram-total-gb p) + (/ (exact->inexact (hardware-profile-vram-total-mb p)) 1024)) + +;; ── Probe ladder ──────────────────────────────────────────────────── + +(def (detect-hardware) + "Auto-detect the GPU. Returns a hardware-profile or #f if no probe + succeeds. On total failure, logs a single WARN listing what was tried." + (let ((attempted '())) + (define (note! s) (set! attempted (cons s attempted))) + (or (detect-nvidia note!) + (detect-amd-sysfs note!) + (begin + (log-warn logger "gpu-detection-failed" + `((attempted . ,(string-join (reverse attempted) "; ")) + (fallback . "ollama tier budget falls back to 4096 tokens"))) + #f)))) + +(def (detect-nvidia note!) + "nvidia-smi probe. Calls (note! status) and returns #f when it finds no + NVIDIA GPU; returns a hardware-profile on success." + (let ((out (guard (e [#t #f]) + (run-process/exec + '("nvidia-smi" + "--query-gpu=name,memory.total" + "--format=csv,noheader,nounits"))))) + (cond + ((or (not out) (= 0 (string-length (string-trim out)))) + (note! "nvidia-smi: no output (not installed or no GPU)") + #f) + (else (parse-nvidia-output out))))) + +(def (parse-nvidia-output out) + ;; First CSV line: "name, memory-in-MiB". Genuine corruption raises. + (let* ((line (car (string-split (string-trim out) #\newline))) + (parts (map string-trim (string-split line #\,)))) + (if (not (= (length parts) 2)) + (raise-hardware-detection + (string-append "expected 2 CSV fields, got " line)) + (let ((mb (string->number (cadr parts)))) + (if (and mb (integer? mb)) + (make-hardware-profile (car parts) (exact (round mb)) "nvidia" "discrete") + (raise-hardware-detection + (string-append "non-integer VRAM in nvidia-smi output: " line))))))) + +(def (detect-amd-sysfs note!) + "AMD sysfs probe — iterates /sys/class/drm/card* (skipping render and + connector nodes), matches device/vendor against the AMD PCI id, reads + device/mem_info_vram_total (bytes). Returns a hardware-profile or #f." + (let ((drm-root "/sys/class/drm")) + (cond + ((not (file-exists? drm-root)) + (note! "amd-sysfs: /sys/class/drm missing") + #f) + (else + (let ((cards (sort string<? + (filter card-index-name? + (guard (e [#t '()]) (directory-list drm-root)))))) + (if (null? cards) + (begin (note! "amd-sysfs: no card* entries") #f) + (or (amd-scan-cards drm-root cards) + (begin + (note! "amd-sysfs: no AMD card with mem_info_vram_total") + #f)))))))) + +(def (amd-scan-cards drm-root cards) + (let loop ((cs cards)) + (cond + ((null? cs) #f) + (else + (let* ((dev (path-join (path-join drm-root (car cs)) "device")) + (vfile (path-join dev "vendor")) + (mfile (path-join dev "mem_info_vram_total"))) + (cond + ((not (and (file-exists? vfile) (file-exists? mfile))) + (loop (cdr cs))) + ((not (equal? (string-trim (read-file-string vfile)) *pci-vendor-amd*)) + (loop (cdr cs))) + (else + (let ((bytes (string->number (string-trim (read-file-string mfile))))) + (if (and bytes (integer? bytes)) + (make-hardware-profile + (or (amd-gpu-name dev) (string-append "AMD GPU (" (car cs) ")")) + (quotient (exact (round bytes)) (* 1024 1024)) + "amd" "unified") + (raise-hardware-detection + (string-append "non-integer VRAM in " mfile))))))))))) + +(def (amd-gpu-name dev) + ;; Best-effort human name from sysfs uevent (PCI_ID line). + (let ((uevent (path-join dev "uevent"))) + (and (file-exists? uevent) + (guard (e [#t #f]) + (let loop ((lines (string-split (read-file-string uevent) #\newline))) + (cond + ((null? lines) #f) + ((string-prefix? "PCI_ID=" (car lines)) + (string-append "AMD GPU [" (substring (car lines) 7 (string-length (car lines))) "]")) + (else (loop (cdr lines))))))))) + +(def (card-index-name? name) + ;; "card0" → yes; "card0-eDP-1", "renderD128" → no (suffix not all digits). + (and (string-prefix? "card" name) + (let ((suffix (substring name 4 (string-length name)))) + (and (> (string-length suffix) 0) (all-digits? suffix))))) + +(def (all-digits? s) + (let loop ((i 0)) + (cond + ((>= i (string-length s)) #t) + ((char-numeric? (string-ref s i)) (loop (+ i 1))) + (else #f)))) + +;; ── VRAM tier → token budget (forge server.py _ollama_vram_tier_budget) ── + +(def (vram-tier-budget-for-gb vram-gb) + "Published Ollama context defaults keyed on total VRAM in GiB. #f (no GPU + detected) → 4096." + (cond + ((not vram-gb) 4096) + ((>= vram-gb 48) 262144) + ((>= vram-gb 24) 32768) + (else 4096))) + +(def (vram-tier-budget) + (let ((hw (detect-hardware))) + (vram-tier-budget-for-gb (and hw (hardware-profile-vram-total-gb hw))))) --- a/src/jcode/ui/cli.ss +++ b/src/jcode/ui/cli.ss @@ -26,6 +26,8 @@ :jcode/tool/batch :jcode/tool/git :jcode/provider/sampling + :jcode/core/hardware + :jcode/core/compaction-strategy :jcode/mcp/client :jcode/tool/lsp :jcode/core/plugin @@ -287,6 +289,16 @@ EXAMPLES: ((eq? p 'off) "off (no per-model sampling)") ((eq? p 'strict) "strict (use card profile; error on unknown model)") (else "on (use card profile if known, else backend defaults)")))) + (printf " compaction ~a (system + first user + recent steps preserved)~n" + (configured-compaction-strategy-name)) + (let ((hw (detect-hardware))) + (if hw + (printf " vram tier ~a tokens (~a, ~a GB ~a)~n" + (vram-tier-budget-for-gb (hardware-profile-vram-total-gb hw)) + (hardware-profile-gpu-name hw) + (exact (round (hardware-profile-vram-total-gb hw))) + (hardware-profile-memory-kind hw)) + (printf " vram tier 4096 tokens (no GPU detected)~n"))) (printf "Toggle with /forge on | /forge off | /forge sampling off|on|strict~n")) (def (handle-command input session-id) --- a/test/run.ss +++ b/test/run.ss @@ -16,7 +16,9 @@ (jcode guardrails respond) (jcode guardrails guardrails) (jcode core errors) - (jcode provider sampling)) + (jcode provider sampling) + (jcode core hardware) + (jcode core compaction-strategy)) ;; ── Helpers ────────────────────────────────────────────────────── @@ -636,6 +638,124 @@ (apply-sampling-to-body! body "jerboa-mlx-lora" "mlx")) (check! "body off+mlx: net still fires" (hashtable-ref body "temperature" #f) 0.3)) +;; ── compaction strategies (Phase 4) ──────────────────────────────── +(section "=== compaction strategies ===") + +(define (asst-tc content) + (make-assistant-message content (list (make-tool-call "read" "{}")))) + +;; Type derivation from message shape +(check! "type: system" (message-derived-type (make-system-message "s")) message-type-system-prompt) +(check! "type: user" (message-derived-type (make-user-message "q")) message-type-user-input) +(check! "type: tool" (message-derived-type (make-tool-result "id" "r")) message-type-tool-result) +(check! "type: tool_call" (message-derived-type (asst-tc "")) message-type-tool-call) +(check! "type: text_response" (message-derived-type (make-assistant-message "hi")) message-type-text-response) +(let ([m (make-assistant-message "")]) + (message-thinking-set! m "pondering") + (check! "type: reasoning (thinking+empty content)" (message-derived-type m) message-type-reasoning)) + +;; estimate = sum(content lengths) // 4 +(check! "estimate-tokens content/4" + (strategy-estimate-tokens (list (make-user-message (make-string 400 #\x)))) 100) + +;; A 7-message history: sys,user,(tc,result)x2,final +(define hist1 + (list (make-system-message "sys") (make-user-message "q") + (asst-tc "a1") (make-tool-result "id1" "r1") + (asst-tc "a2") (make-tool-result "id2" "r2") + (make-assistant-message "final"))) +(check! "step indices" (derive-step-indices hist1) (list #f #f 1 1 2 2 3)) +(check! "eligible-end keep=3 (nothing eligible)" (find-eligible-end hist1 3) 2) +(check! "eligible-end keep=2" (find-eligible-end hist1 2) 4) +(check! "eligible-end keep=1" (find-eligible-end hist1 1) 6) + +;; NoCompact: always passthrough, phase 0 +(let* ([s (make-no-compact)] [r (s hist1 1000)]) + (check! "no-compact phase 0" (cdr r) 0) + (check! "no-compact length unchanged" (length (car r)) 7)) + +;; A big history for sliding/tiered: 11 msgs, 5 token-bearing (1000 chars each) +;; indices: 0 sys 1 user | 2 tc 3 tool(1000) 4 text(1000) 5 tc 6 tool(1000) +;; 7 text(1000) 8 tc 9 tool(1000) 10 final("final") +(define hist-tier + (list (make-system-message "") (make-user-message "") + (asst-tc "") (make-tool-result "t1" (make-string 1000 #\T)) + (make-assistant-message (make-string 1000 #\X)) + (asst-tc "") (make-tool-result "t2" (make-string 1000 #\T)) + (make-assistant-message (make-string 1000 #\X)) + (asst-tc "") (make-tool-result "t3" (make-string 1000 #\T)) + (make-assistant-message "final"))) +(check! "tier step indices" (derive-step-indices hist-tier) (list #f #f 1 1 2 3 3 4 5 5 6)) +(check! "tier eligible-end keep=1" (find-eligible-end hist-tier 1) 10) +;; original estimate 5005//4 = 1251 tokens +(check! "tier original estimate" (strategy-estimate-tokens hist-tier) 1251) + +;; SlidingWindow keep=1: below threshold → phase 0; above → keep head+protected tail +(let* ([s (make-sliding-window 1 0.75)] [r (s hist-tier 10000)]) + (check! "sliding below threshold phase 0" (cdr r) 0)) +(let* ([s (make-sliding-window 1 0.75)] [r (s hist-tier 400)]) + (check! "sliding fires phase 1" (cdr r) 1) + (check! "sliding keeps sys+user+protected" (length (car r)) 3) + (check! "sliding head is system" (message-role (car (car r))) "system")) + +;; Tiered phase transitions (keep=1, uniform 0.75 threshold). +;; budgets: 4000→t3000 (p0), 1200→t900 (p1), 800→t600 (p2), 600→t450 (p3) +(let* ([s (make-tiered 1 0.75 #f)] [r (s hist-tier 4000)]) + (check! "tiered below all thresholds phase 0" (cdr r) 0) + (check! "tiered phase 0 length unchanged" (length (car r)) 11)) +(let* ([s (make-tiered 1 0.75 #f)] [r (s hist-tier 1200)]) + (check! "tiered phase 1" (cdr r) 1) + (check! "tiered phase 1 keeps all msgs (truncate only)" (length (car r)) 11) + (check-pred! "tiered phase 1 truncated a tool result" + (message-content (list-ref (car r) 3)) (lambda (c) (str-contains? c "[Truncated")))) +(let* ([s (make-tiered 1 0.75 #f)] [r (s hist-tier 800)]) + (check! "tiered phase 2" (cdr r) 2) + (check! "tiered phase 2 drops 3 tool results" (length (car r)) 8)) +(let* ([s (make-tiered 1 0.75 #f)] [r (s hist-tier 600)]) + (check! "tiered phase 3" (cdr r) 3) + (check! "tiered phase 3 keeps only skeleton" (length (car r)) 6) + (check! "tiered phase 3 preserves system" (message-role (car (car r))) "system") + (check! "tiered phase 3 preserves protected tail" + (message-content (list-ref (car r) 5)) "final")) + +;; JcodeLegacy: still a valid strategy (wraps compact-messages) +(let* ([s (make-jcode-legacy)] [r (s hist1 1000)]) + (check-pred! "legacy returns a list" (car r) list?) + (check! "legacy phase 1" (cdr r) 1)) + +;; Dispatcher default is tiered +(check! "default strategy name" (configured-compaction-strategy-name) "tiered") +(check-pred! "by-name tiered is callable" (compaction-strategy-by-name "tiered" 2 0.75) procedure?) +(check-pred! "by-name none is callable" (compaction-strategy-by-name "none" 2 0.75) procedure?) + +;; ── hardware / VRAM tiers (Phase 4) ───────────────────────────────── +(section "=== hardware VRAM tiers ===") + +(check! "tier #f → 4096" (vram-tier-budget-for-gb #f) 4096) +(check! "tier 12 → 4096" (vram-tier-budget-for-gb 12.0) 4096) +(check! "tier 23.9 → 4096" (vram-tier-budget-for-gb 23.9) 4096) +(check! "tier 24 → 32768" (vram-tier-budget-for-gb 24.0) 32768) +(check! "tier 30 → 32768" (vram-tier-budget-for-gb 30.0) 32768) +(check! "tier 48 → 262144" (vram-tier-budget-for-gb 48.0) 262144) +(check! "tier 80 → 262144" (vram-tier-budget-for-gb 80.0) 262144) + +(let ([p (make-hardware-profile "Test GPU" 24576 "nvidia" "discrete")]) + (check! "profile vram gb" (hardware-profile-vram-total-gb p) 24.0) + (check! "profile gpu name" (hardware-profile-gpu-name p) "Test GPU") + (check! "profile → 32768 tier" + (vram-tier-budget-for-gb (hardware-profile-vram-total-gb p)) 32768)) + +(check! "quant bpw Q4_K_M" (quant-bpw-ref "Q4_K_M") 4.83) +(check! "quant bpw F16" (quant-bpw-ref "F16") 16.0) +(check! "quant bpw unknown → #f" (quant-bpw-ref "nope") #f) + +;; Live probe: must not crash; returns #f or a profile, budget an int ≥ 4096. +(parameterize ([current-log-level 'error]) + (check-pred! "detect-hardware: #f or profile" + (detect-hardware) (lambda (x) (or (not x) (hardware-profile? x)))) + (check-pred! "vram-tier-budget: int ≥ 4096" + (vram-tier-budget) (lambda (x) (and (integer? x) (>= x 4096))))) + ;; ── Results ─────────────────────────────────────────────────────── (printf "~n~a passed, ~a failed~n" pass-count fail-count)