Preserve task context during compaction
ober
911bcb97343925840e73a00259b52e3576d3714e
--- a/docs/FORGE.md +++ b/docs/FORGE.md @@ -103,7 +103,9 @@ All of these wrap every provider call automatically. to its recommended temperature / top_p / etc. Policy is `off | on | strict`. - **Compaction** (`core/compaction-strategy.ss`) — pluggable context compaction (`TieredCompact`, `SlidingWindow`, `NoCompact`, plus jcode's original), always - preserving the system prompt, first user message, and recent steps. + preserving the system prompt, first user message, and recent steps. Tiered + compaction also preserves the first assistant/tool iteration, because an + initial user request may delegate its actual task context to a tool result. --- --- a/docs/architecture.md +++ b/docs/architecture.md @@ -36,7 +36,8 @@ guardrails wrap the response ┐ When the running history approaches the model's [context window](providers.md#models), a pluggable **compaction strategy** trims it while preserving the system prompt, -the first user message, and recent steps. +the first user message, and recent steps. Tiered compaction additionally keeps +the first assistant/tool iteration so delegated initial context is not lost. ## Module map --- a/src/jcode/core/agent.ss +++ b/src/jcode/core/agent.ss @@ -36,6 +36,7 @@ forge-seed-from-memory! forge-normalize-bash-command *session-loop-memory* + truncate-tool-output try-parse-text-tool-calls try-parse-xml-tool-calls) @@ -768,11 +769,15 @@ Be concise. Prefer edit over write for modifying existing files. (string-append preview (format "\n\n...~a truncated...\n\nFull output saved to: ~a\nUse grep to search or read with specific line ranges." removed file))) - (let ((line (car remaining))) + (let* ((line (car remaining)) + (room (max 0 (- byte-limit bytes))) + (kept (if (> (string-length line) room) + (substring line 0 room) + line))) (loop (cdr remaining) (+ count 1) - (+ bytes (string-length line) 1) - (cons line acc)))))))) + (+ bytes (string-length kept) 1) + (cons kept acc)))))))) ;;; Text-format tool call detection ;;; ;;; Some models (e.g. Llama via OpenRouter) output tool calls as plain text --- a/src/jcode/core/compaction-strategy.ss +++ b/src/jcode/core/compaction-strategy.ss @@ -25,6 +25,7 @@ derive-step-indices strategy-estimate-tokens find-eligible-end + find-protected-prefix-end make-no-compact make-sliding-window make-tiered @@ -115,6 +116,15 @@ ((null? xs) total) ((and (>= i 2) (car xs) (>= (car xs) cutoff)) i) (else (loop (cdr xs) (+ i 1)))))))))) +(def (find-protected-prefix-end messages) + "Boundary after the first assistant/tool iteration. The first user message + can delegate its actual task context to a tool result, so tiered compaction + must retain that result along with the initial prompt." + (let loop ((steps (derive-step-indices messages)) (i 0)) + (cond + ((null? steps) i) + ((and (>= i 2) (car steps) (> (car steps) 1)) i) + (else (loop (cdr steps) (+ i 1)))))) (def (nudge-type? ty) (or (equal? ty message-type-step-nudge) @@ -162,14 +172,15 @@ (cond ((< tokens t1) (cons messages 0)) (else - (let ((ee (find-eligible-end messages keep-recent))) - (let ((r1 (tiered-phase1 messages ee))) + (let* ((es (find-protected-prefix-end messages)) + (ee (find-eligible-end messages keep-recent))) + (let ((r1 (tiered-phase1 messages es ee))) (if (< (strategy-estimate-tokens r1) t2) (cons r1 1) - (let ((r2 (tiered-phase2 messages ee))) + (let ((r2 (tiered-phase2 messages es ee))) (if (< (strategy-estimate-tokens r2) t3) (cons r2 2) - (cons (tiered-phase3 messages ee) 3)))))))))))) + (cons (tiered-phase3 messages es ee) 3)))))))))))) (def (truncate-tool-result m) (let* ((c (message-content m)) @@ -178,11 +189,11 @@ (make-tool-result (message-tool-call-id m) (string-append kept "\n[Truncated — " (number->string removed) " chars removed]")))) -(def (tiered-phase1 messages ee) +(def (tiered-phase1 messages es ee) (let loop ((ms messages) (i 0) (acc '())) (cond ((null? ms) (reverse acc)) - ((and (>= i 2) (< i ee)) + ((and (>= i es) (< i ee)) (let* ((m (car ms)) (ty (message-derived-type m))) (cond ((nudge-type? ty) (loop (cdr ms) (+ i 1) acc)) @@ -192,22 +203,22 @@ (else (loop (cdr ms) (+ i 1) (cons m acc)))))) (else (loop (cdr ms) (+ i 1) (cons (car ms) acc)))))) -(def (tiered-phase2 messages ee) +(def (tiered-phase2 messages es ee) (let loop ((ms messages) (i 0) (acc '())) (cond ((null? ms) (reverse acc)) - ((and (>= i 2) (< i ee)) + ((and (>= i es) (< 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) +(def (tiered-phase3 messages es ee) (let loop ((ms messages) (i 0) (acc '())) (cond ((null? ms) (reverse acc)) - ((and (>= i 2) (< i ee)) + ((and (>= i es) (< i ee)) (let ((ty (message-derived-type (car ms)))) (if (or (nudge-type? ty) (equal? ty message-type-tool-result) --- a/src/jcode/ui/cli.ss +++ b/src/jcode/ui/cli.ss @@ -461,7 +461,7 @@ 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 (initial prompt + first user + recent steps preserved)~n" + (printf " compaction ~a (initial prompt + delegated context + recent steps preserved)~n" (configured-compaction-strategy-name)) (let ((hw (detect-hardware))) (if hw --- a/test/run.ss +++ b/test/run.ss @@ -1147,6 +1147,23 @@ (check! "deepseek local working budget compacts medium history" (should-compact-for-budget? history "deepseek-v4-pro" 32768) #t)) +(let* ([raw (make-string 60000 #\x)] + [result + (parameterize ([current-model-override "deepseek-v4-pro"]) + (truncate-tool-output raw))] + [trailer-pos (string-contains result "\n\n...")] + [path-marker "Full output saved to: "] + [path-pos (string-contains result path-marker)] + [path-tail + (substring result + (+ path-pos (string-length path-marker)) + (string-length result))] + [saved-path (car (string-split path-tail #\newline))]) + (check! "single-line tool output respects preview byte cap" + trailer-pos 51200) + (check-pred! "truncated single-line tool output is preserved on disk" + saved-path file-exists?) + (safe-delete-test-file! saved-path)) (define (asst-tc content) (make-assistant-message content (list (make-tool-call "read" "{}")))) @@ -1194,6 +1211,8 @@ (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) +(check! "tier protects initial delegated tool context" + (find-protected-prefix-end hist-tier) 4) ;; original estimate includes three tool-call overheads: (5005 + 90)//4 = 1273 (check! "tier original estimate" (strategy-estimate-tokens hist-tier) 1273) @@ -1208,7 +1227,8 @@ (check! "configured small budget uses sliding" (length r) 5)) ;; Tiered phase transitions (keep=1, uniform 0.75 threshold). -;; budgets: 4000→t3000 (p0), 1200→t900 (p1), 800→t600 (p2), 600→t450 (p3) +;; The initial delegated tool iteration stays protected in every phase. +;; budgets: 4000→t3000 (p0), 1200→t900 (p1), 1040→t780 (p2), 800→t600 (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)) @@ -1217,15 +1237,19 @@ (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)]) +(let* ([s (make-tiered 1 0.75 #f)] [r (s hist-tier 1040)]) (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 2 drops 2 unprotected tool results" + (length (car r)) 9)) +(let* ([s (make-tiered 1 0.75 #f)] [r (s hist-tier 800)]) (check! "tiered phase 3" (cdr r) 3) - (check! "tiered phase 3 keeps only skeleton" (length (car r)) 6) + (check! "tiered phase 3 keeps delegated context and skeleton" + (length (car r)) 7) (check! "tiered phase 3 preserves system" (message-role (car (car r))) "system") + (check! "tiered phase 3 preserves initial tool result" + (message-content (list-ref (car r) 3)) (make-string 1000 #\T)) (check! "tiered phase 3 preserves protected tail" - (message-content (list-ref (car r) 5)) "final")) + (message-content (list-ref (car r) 6)) "final")) ;; JcodeLegacy: still a valid strategy (wraps compact-messages) (let* ([s (make-jcode-legacy)] [r (s hist1 1000)])