Chez Phase 1 (increment 3o): transducer arities
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.
This commit is contained in:
Yogthos
parent
739b219d0e
commit
cbb0f2ab4a
4 changed files with 175 additions and 16 deletions
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue