From cbb0f2ab4a24eb16440c6b150a739d959799dad3 Mon Sep 17 00:00:00 2001 From: Yogthos Date: Wed, 17 Jun 2026 23:51:06 -0400 Subject: [PATCH] Chez Phase 1 (increment 3o): transducer arities MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The 1-arg map/filter/remove/take/drop/take-while/drop-while/mapcat now return a transducer (fn [rf] rf'), and into gets a 3-arg (into to xform from). This was the 'cdr () is not a pair' / 'incorrect number of arguments' crash bucket: the emitter lowers (map f) and 3-arg into at an arity the native-op gate rejects, so they fall to the value-position path and hit the bare jolt-map/jolt-into procedure at the wrong arity. The fix is RT-side — case-lambda those procedures plus jolt-into. td-* factories ported from the seed (core_coll.janet); a reduced step stops the fold via reduce-seq's existing short-circuit (inc 3n). transduce/comp/completing are overlay and compose over these unchanged. Parity 1467 -> 1493/2497, 0 new divergences. emit-test 278/278. --- host/chez/natives-seq.ss | 133 +++++++++++++++++++++++++++-- test/chez/README.md | 24 ++++-- test/chez/emit-test.janet | 30 +++++++ test/chez/run-corpus-prelude.janet | 4 +- 4 files changed, 175 insertions(+), 16 deletions(-) diff --git a/host/chez/natives-seq.ss b/host/chez/natives-seq.ss index c3b5a01..2c9eefe 100644 --- a/host/chez/natives-seq.ss +++ b/host/chez/natives-seq.ss @@ -11,25 +11,122 @@ ;; and predicate. (deref a-reduced) is handled in atoms.ss. (define (jolt-reduced-new x) (make-jolt-reduced x)) (define (jolt-reduced-pred x) (jolt-reduced? x)) +(define (ensure-reduced x) (if (jolt-reduced? x) x (make-jolt-reduced x))) -;; mapcat: (mapcat f coll & colls) — map f across the colls (stops at shortest), -;; then concat the results. Collection arity only. +;; ============================================================================ +;; transducers (jolt-kxsr) — the 1-arg arity of map/filter/take/... returns a +;; transducer (fn [rf] rf') where rf' is a reducing fn with arities +;; []=init, [acc]=complete, [acc x]=step. Ported from the seed's td-* factories +;; (core_coll.janet). rf and the mapping/predicate fns are jolt values, so every +;; call routes through jolt-invoke. A `reduced` step stops the fold — reduce-seq +;; (seq.ss) already short-circuits on a jolt-reduced. +;; ============================================================================ +(define (td-map f) + (lambda (rf) + (lambda a + (case (length a) + ((0) (jolt-invoke rf)) + ((1) (jolt-invoke rf (car a))) + (else (jolt-invoke rf (car a) (jolt-invoke f (cadr a)))))))) +(define (td-filter pred) + (lambda (rf) + (lambda a + (case (length a) + ((0) (jolt-invoke rf)) + ((1) (jolt-invoke rf (car a))) + (else (if (jolt-truthy? (jolt-invoke pred (cadr a))) + (jolt-invoke rf (car a) (cadr a)) + (car a))))))) +(define (td-remove pred) (td-filter (lambda (x) (jolt-not (jolt-invoke pred x))))) +(define (td-take n) + (lambda (rf) + (let ((left n)) + (lambda a + (case (length a) + ((0) (jolt-invoke rf)) + ((1) (jolt-invoke rf (car a))) + (else (if (<= left 0) + (make-jolt-reduced (car a)) + (let ((r (jolt-invoke rf (car a) (cadr a)))) + (set! left (- left 1)) + (if (<= left 0) (ensure-reduced r) r))))))))) +(define (td-drop n) + (lambda (rf) + (let ((left n)) + (lambda a + (case (length a) + ((0) (jolt-invoke rf)) + ((1) (jolt-invoke rf (car a))) + (else (if (> left 0) (begin (set! left (- left 1)) (car a)) + (jolt-invoke rf (car a) (cadr a))))))))) +(define (td-take-while pred) + (lambda (rf) + (lambda a + (case (length a) + ((0) (jolt-invoke rf)) + ((1) (jolt-invoke rf (car a))) + (else (if (jolt-truthy? (jolt-invoke pred (cadr a))) + (jolt-invoke rf (car a) (cadr a)) + (make-jolt-reduced (car a)))))))) +(define (td-drop-while pred) + (lambda (rf) + (let ((dropping #t)) + (lambda a + (case (length a) + ((0) (jolt-invoke rf)) + ((1) (jolt-invoke rf (car a))) + (else (begin + (when (and dropping (not (jolt-truthy? (jolt-invoke pred (cadr a))))) + (set! dropping #f)) + (if dropping (car a) (jolt-invoke rf (car a) (cadr a)))))))))) +;; (mapcat f) transducer: map f, then splice (cat) f's result into rf, honoring a +;; mid-splice `reduced`. +(define (td-mapcat f) + (lambda (rf) + (lambda a + (case (length a) + ((0) (jolt-invoke rf)) + ((1) (jolt-invoke rf (car a))) + (else (let loop ((acc (car a)) + (xs (seq->list (jolt-seq (jolt-invoke f (cadr a)))))) + (if (or (null? xs) (jolt-reduced? acc)) acc + (loop (jolt-invoke rf acc (car xs)) (cdr xs))))))))) + +;; (into to xform from): transduce `from` through `xform` with conj as the rf. +(define (into-xform to xform from) + (let* ((conj-rf (lambda a (if (fx=? (length a) 1) (car a) ; completion = identity + (jolt-conj1 (car a) (cadr a))))) + (xrf (jolt-invoke xform conj-rf)) + (res (reduce-seq xrf to (jolt-seq from)))) + (jolt-invoke xrf res))) + +;; mapcat: (mapcat f) -> transducer; (mapcat f coll & colls) -> map f across the +;; colls (stops at shortest), then concat the results. (define (jolt-mapcat f . colls) - (apply jolt-concat (seq->list (apply jolt-map f colls)))) + (if (null? colls) + (td-mapcat f) + (apply jolt-concat (seq->list (apply jolt-map f colls))))) -;; take-while / drop-while over the seq layer. +;; take-while / drop-while: 1-arg -> transducer; 2-arg -> a seq over the coll. (define (take-while-seq pred s) (if (jolt-nil? s) jolt-empty-list (let ((x (seq-first s))) (if (jolt-truthy? (jolt-invoke pred x)) (cseq-lazy x (lambda () (take-while-seq pred (jolt-seq (seq-more s))))) jolt-empty-list)))) -(define (jolt-take-while pred coll) (take-while-seq pred (jolt-seq coll))) -(define (jolt-drop-while pred coll) +(define jolt-take-while + (case-lambda + ((pred) (td-take-while pred)) + ((pred coll) (take-while-seq pred (jolt-seq coll))))) +(define (drop-while-seq pred coll) (let loop ((s (jolt-seq coll))) (if (and (not (jolt-nil? s)) (jolt-truthy? (jolt-invoke pred (seq-first s)))) (loop (jolt-seq (seq-more s))) (if (jolt-nil? s) jolt-empty-list s)))) +(define jolt-drop-while + (case-lambda + ((pred) (td-drop-while pred)) + ((pred coll) (drop-while-seq pred coll)))) ;; partition: (partition n coll), (partition n step coll), or ;; (partition n step pad coll). Only complete partitions of size n are kept; @@ -89,6 +186,30 @@ ;; values compare equal — so jolt= is the faithful port. (define (jolt-identical? a b) (jolt= a b)) +;; Give the seq.ss native procedures their transducer (1-arg) arity — the emitter +;; lowers (map f)/(filter p)/(take n) at the wrong arity to the bare procedure +;; (value-position path), so widening the procedures is what makes the 1-arg form +;; work. Capture the originals (collection arities) first, then redefine. +(define %prev-jolt-map jolt-map) +(set! jolt-map (lambda (f . colls) + (if (null? colls) (td-map f) (apply %prev-jolt-map f colls)))) +(define %prev-jolt-filter jolt-filter) +(set! jolt-filter (case-lambda ((pred) (td-filter pred)) + ((pred coll) (%prev-jolt-filter pred coll)))) +(define %prev-jolt-remove jolt-remove) +(set! jolt-remove (case-lambda ((pred) (td-remove pred)) + ((pred coll) (%prev-jolt-remove pred coll)))) +(define %prev-jolt-take jolt-take) +(set! jolt-take (case-lambda ((n) (td-take n)) + ((n coll) (%prev-jolt-take n coll)))) +(define %prev-jolt-drop jolt-drop) +(set! jolt-drop (case-lambda ((n) (td-drop n)) + ((n coll) (%prev-jolt-drop n coll)))) +;; into: add the 3-arg (into to xform from). The 2-arg stays the seq.ss fold. +(define %prev-jolt-into jolt-into) +(set! jolt-into (case-lambda ((to from) (%prev-jolt-into to from)) + ((to xform from) (into-xform to xform from)))) + (def-var! "clojure.core" "reduced" jolt-reduced-new) (def-var! "clojure.core" "reduced?" jolt-reduced-pred) (def-var! "clojure.core" "mapcat" jolt-mapcat) diff --git a/test/chez/README.md b/test/chez/README.md index 6273b8c..1090e92 100644 --- a/test/chez/README.md +++ b/test/chez/README.md @@ -136,15 +136,23 @@ class names, eval-order, with-open — all deferred Phase-2 / dynamic-var gaps). works). `identical?` = `jolt=` (the seed's definition). `list?` was deferred: a Chez lazy seq and a list are both `cseq`, so it can't be told apart without a distinct list type (a real divergence risk). +- inc 3o transducer arities (jolt-kxsr): the 1-arg `map`/`filter`/`remove`/`take`/ + `drop`/`take-while`/`drop-while`/`mapcat` return a transducer `(fn [rf] rf')`, and + `into` gets a 3-arg `(into to xform from)`. These were the `cdr () is not a pair` / + `incorrect number of arguments` crash bucket: the emitter lowers `(map f)` / + `(into to xf from)` at the wrong arity to the bare native procedure (the + value-position path), so the fix is RT-side — `case-lambda` the seq procedures and + `jolt-into`. The `td-*` factories are ported from the seed (core_coll.janet); a + `reduced` step stops the fold via reduce-seq's short-circuit. `transduce`/`comp`/ + `completing` are overlay and compose over these for free. -The remaining buckets are the punch-list the next increments chase (at 1467/2497): -~361 emit-fail (genuine host interop — qualified Java/Janet refs, runtime -`defmacro`/`eval`, out of the analyzer's subset) and ~655 runtime crashes — still -~590 `apply jolt-nil` (more host-coupled natives without a shim: `meta`/`with-meta`, -`format`, the `clojure.string` natives, bit ops, `var`/`volatile`/`future`/ -thread-binding ops), the transducer arities (jolt-kxsr — 1-arg `filter`/`map`/`take`/ -`take-while` + 3-arg `into`), `cdr`-on-`()` and `\p{}` regex classes (jolt-y1zq), and -multimethod dispatch (Phase 2 jolt-9ls5). +The remaining buckets are the punch-list the next increments chase: ~361 emit-fail +(genuine host interop — qualified Java/Janet refs, runtime `defmacro`/`eval`, out of +the analyzer's subset) and the runtime crashes still dominated by `apply jolt-nil` +(more host-coupled natives without a shim: `meta`/`with-meta`, `format`, the +`clojure.string` natives, bit ops, `var`/`volatile`/`future`/thread-binding ops), +plus the small jolt-y1zq tail (0-arg `conj`, `\p{}` regex classes, a few one-offs) +and multimethod dispatch (Phase 2 jolt-9ls5). Two host shims landed with the prelude. `host/chez/atoms.ss`: atom/deref/swap!/ reset! (+ compare-and-set!/swap-vals!/reset-vals!) — host-coupled mutable cells the diff --git a/test/chez/emit-test.janet b/test/chez/emit-test.janet index 71413c2..89e9dbf 100644 --- a/test/chez/emit-test.janet +++ b/test/chez/emit-test.janet @@ -526,6 +526,36 @@ (ok (string "seq-native -e: " src) (and (= code 0) (= out want)) (string "chez=" out " janet=" want " | " err))))) +# 3t) transducer arities (jolt-kxsr): the 1-arg map/filter/take/drop/remove/ +# take-while/drop-while/mapcat return a transducer (fn [rf] rf'), and into gets a +# 3-arg (into to xform from). These lowered to the bare native procedure at the +# wrong arity (the 'cdr () not a pair' / 'incorrect number of arguments' bucket), +# so the fix is RT-side: case-lambda the seq fns + jolt-into. (map inc)/into are +# native, so into+single-xform runs in run-prelude; transduce/comp are overlay, +# so those go through the -e binary. +(each src ["(= [2 3 4] (into [] (map inc) [1 2 3]))" + "(= #{2 3 4} (into #{} (map inc) [1 2 3]))" + "(= [2 4] (into [] (filter even?) [1 2 3 4 5]))" + "(= [1 3 5] (into [] (remove even?) [1 2 3 4 5]))" + "(= [1 2] (into [] (take 2) [1 2 3 4]))" + "(= [3 4] (into [] (drop 2) [1 2 3 4]))" + "(= [1 2] (into [] (take-while (fn [x] (< x 3))) [1 2 3 1]))" + "(= [3 1] (into [] (drop-while (fn [x] (< x 3))) [1 2 3 1]))" + "(= [1 1 2 2] (into [] (mapcat (fn [x] [x x])) [1 2]))"] + (let [[code out err] (run-prelude src) want (cli-oracle src)] + (ok (string "transducer: " src) (and (= code 0) (= out want)) + (string "chez=" out " janet=" want " | " err)))) +(when (os/stat "bin/jolt-chez") + (each src ["(= 6 (transduce (map inc) + [0 1 2]))" + "(= 5 (transduce (map inc) + [1 2]))" + "(= 6 (transduce (map inc) (completing +) 0 [0 1 2]))" + "(= [4 6] (into [] (comp (map inc) (filter even?)) [2 3 4 5]))" + "(= 3 (reduce (fn [a x] (if (> a 2) (reduced a) (+ a x))) 0 (range 100)))" + "(into #{} (map inc) [1 2 3])"] + (let [[code out err] (run-jolt-chez src) want (cli-oracle src)] + (ok (string "transducer -e: " src) (and (= code 0) (= out want)) + (string "chez=" out " janet=" want " | " err))))) + # 4) perf signal: emitted fib(30) in-Scheme timing (excludes Chez startup), to # track against the spike ceiling (hand-Scheme fib ~5ms). Informational — the # jolt-truthy? wrapper (~3x) and flonum modeling are known Phase-4 levers. diff --git a/test/chez/run-corpus-prelude.janet b/test/chez/run-corpus-prelude.janet index 114aad5..d1fa780 100644 --- a/test/chez/run-corpus-prelude.janet +++ b/test/chez/run-corpus-prelude.janet @@ -136,8 +136,8 @@ # on any NEW (un-allowlisted) divergence — a real Chez correctness regression. # Full-corpus baseline: inc 3j 1220/2497; 3k (converters) 1326; 3l (transients) # 1382; 3m (numeric-edge emit + variadic assoc!) 1407; 3n (seq-native shims + -# reduced) 1467. Strided runs scale down. -(def base-floor (scan-number (or (os/getenv "JOLT_CHEZ_PRELUDE_FLOOR") "1467"))) +# reduced) 1467; 3o (transducer arities) 1493. Strided runs scale down. +(def base-floor (scan-number (or (os/getenv "JOLT_CHEZ_PRELUDE_FLOOR") "1493"))) (def floor (if (os/getenv "JOLT_CORPUS_LIMIT") 0 base-floor)) (when (or (> (length diverged) 0) (< pass floor)) (printf "REGRESSION: pass %d < floor %d or %d new divergence(s)" pass floor (length diverged)))