iter: fuse for/or and for/and over known iterator heads
ober
a38bf183b77ceb747e56855791569e33b38413c2
new file mode 100644 --- /dev/null +++ b/benchmarks/bench-for-or-and.ss @@ -0,0 +1,79 @@ +#!/usr/bin/env -S scheme --libdirs lib --script +;;; bench-for-or-and.ss — exercise fused for/or and for/and forms +;;; introduced in Phase 19. The fused path avoids the intermediate +;;; list produced by the generic multi-clause machinery. + +(import (except (chezscheme) + make-hash-table hash-table? sort sort! format printf fprintf + iota 1+ 1- path-extension path-absolute? + with-input-from-string with-output-to-string) + (jerboa prelude)) + +(define (bench name n thunk) + (collect) + (let* ([t0 (real-time)]) + (thunk) + (let* ([elapsed (- (real-time) t0)] + [per-op-ns (if (fx> n 0) + (inexact (/ (* elapsed 1000000) n)) + 0.0)]) + (printf "~46a ~10d iters ~6d ms ~8,2f ns/iter\n" + name n elapsed per-op-ns)))) + +(define N 2000000) +(define V (list->vector (iota N))) +(define L (iota N)) +(define S (make-string N #\a)) + +(printf "=== for/or & for/and fusion bench (n=~d) ===\n\n" N) + +;; ---- for/or over various iterators (target never hit → full sweep) ---- + +(bench "for/or in-range (no hit)" N + (lambda () + (for/or ((i (in-range N))) + (and (fx= i -1) i)))) + +(bench "for/or in-vector (no hit)" N + (lambda () + (for/or ((x (in-vector V))) + (and (fx= x -1) x)))) + +(bench "for/or in-string (no hit)" N + (lambda () + (for/or ((c (in-string S))) + (and (char=? c #\Z) c)))) + +(bench "for/or in-list (no hit)" N + (lambda () + (for/or ((x (in-list L))) + (and (fx= x -1) x)))) + +;; ---- for/or early exit at mid-point ---- + +(bench "for/or in-range (hit at N/2)" N + (lambda () + (for/or ((i (in-range N))) + (and (fx= i (fxquotient N 2)) i)))) + +;; ---- for/and over various iterators (always truthy → full sweep) ---- + +(bench "for/and in-range (always)" N + (lambda () + (for/and ((i (in-range N))) + (fx>= i 0)))) + +(bench "for/and in-vector (always)" N + (lambda () + (for/and ((x (in-vector V))) + (fx>= x 0)))) + +(bench "for/and in-list (always)" N + (lambda () + (for/and ((x (in-list L))) + (fx>= x 0)))) + +(bench "for/and in-range (fail at N/2)" N + (lambda () + (for/and ((i (in-range N))) + (fx< i (fxquotient N 2))))) --- a/lib/std/iter.sls +++ b/lib/std/iter.sls @@ -407,7 +407,9 @@ (%clause-expand (clause ...) (set! acc (begin body ...))) acc)])))) - ;; for/or — return first truthy result + ;; for/or — return first truthy result. Fuses in-range/in-vector/ + ;; in-string/in-list parallel to for/fold so the iterator list + ;; never gets materialised. (define-syntax for/or (let () (define (binding-id? s) @@ -418,7 +420,52 @@ (or (= (string-length str) 0) (not (char=? (string-ref str (- (string-length str) 1)) #\:)))))))) (lambda (stx) - (syntax-case stx () + (syntax-case stx (in-range in-vector in-string in-list) + ;; --- Fused iterators --- + [(_ ((var (in-range end))) body ...) + (binding-id? #'var) + #'(let ([n end]) + (let loop ([i 0]) + (if (>= i n) #f + (let ([var i]) + (or (begin body ...) (loop (+ i 1)))))))] + [(_ ((var (in-range start end))) body ...) + (binding-id? #'var) + #'(let ([s start] [e end]) + (let loop ([i s]) + (if (>= i e) #f + (let ([var i]) + (or (begin body ...) (loop (+ i 1)))))))] + [(_ ((var (in-range start end step))) body ...) + (binding-id? #'var) + #'(let ([s start] [e end] [stp step]) + (let loop ([i s]) + (if (if (positive? stp) (>= i e) (<= i e)) #f + (let ([var i]) + (or (begin body ...) (loop (+ i stp)))))))] + [(_ ((var (in-vector vec-expr))) body ...) + (binding-id? #'var) + #'(let ([v vec-expr]) + (let ([n (vector-length v)]) + (let loop ([i 0]) + (if (fx>= i n) #f + (let ([var (vector-ref v i)]) + (or (begin body ...) (loop (fx+ i 1))))))))] + [(_ ((var (in-string str-expr))) body ...) + (binding-id? #'var) + #'(let ([s str-expr]) + (let ([n (string-length s)]) + (let loop ([i 0]) + (if (fx>= i n) #f + (let ([var (string-ref s i)]) + (or (begin body ...) (loop (fx+ i 1))))))))] + [(_ ((var (in-list lst-expr))) body ...) + (binding-id? #'var) + #'(let loop ([rest lst-expr]) + (if (null? rest) #f + (let ([var (car rest)]) + (or (begin body ...) (loop (cdr rest))))))] + ;; --- Unfused fallback (single clause, list) --- [(_ ((var iter-expr)) body ...) (binding-id? #'var) #'(let loop ([rest iter-expr]) @@ -432,7 +479,8 @@ (when %result (return %result)))) #f))])))) - ;; for/and — return #f if any result is #f + ;; for/and — return #f if any result is #f. Fuses same iterators + ;; as for/or. (define-syntax for/and (let () (define (binding-id? s) @@ -443,7 +491,58 @@ (or (= (string-length str) 0) (not (char=? (string-ref str (- (string-length str) 1)) #\:)))))))) (lambda (stx) - (syntax-case stx () + (syntax-case stx (in-range in-vector in-string in-list) + ;; --- Fused iterators --- + [(_ ((var (in-range end))) body ...) + (binding-id? #'var) + #'(let ([n end]) + (let loop ([i 0] [last #t]) + (if (>= i n) last + (let ([var i]) + (let ([%r (begin body ...)]) + (if %r (loop (+ i 1) %r) #f))))))] + [(_ ((var (in-range start end))) body ...) + (binding-id? #'var) + #'(let ([s start] [e end]) + (let loop ([i s] [last #t]) + (if (>= i e) last + (let ([var i]) + (let ([%r (begin body ...)]) + (if %r (loop (+ i 1) %r) #f))))))] + [(_ ((var (in-range start end step))) body ...) + (binding-id? #'var) + #'(let ([s start] [e end] [stp step]) + (let loop ([i s] [last #t]) + (if (if (positive? stp) (>= i e) (<= i e)) last + (let ([var i]) + (let ([%r (begin body ...)]) + (if %r (loop (+ i stp) %r) #f))))))] + [(_ ((var (in-vector vec-expr))) body ...) + (binding-id? #'var) + #'(let ([v vec-expr]) + (let ([n (vector-length v)]) + (let loop ([i 0] [last #t]) + (if (fx>= i n) last + (let ([var (vector-ref v i)]) + (let ([%r (begin body ...)]) + (if %r (loop (fx+ i 1) %r) #f)))))))] + [(_ ((var (in-string str-expr))) body ...) + (binding-id? #'var) + #'(let ([s str-expr]) + (let ([n (string-length s)]) + (let loop ([i 0] [last #t]) + (if (fx>= i n) last + (let ([var (string-ref s i)]) + (let ([%r (begin body ...)]) + (if %r (loop (fx+ i 1) %r) #f)))))))] + [(_ ((var (in-list lst-expr))) body ...) + (binding-id? #'var) + #'(let loop ([rest lst-expr] [last #t]) + (if (null? rest) last + (let ([var (car rest)]) + (let ([%r (begin body ...)]) + (if %r (loop (cdr rest) %r) #f)))))] + ;; --- Unfused fallback (single clause, list) --- [(_ ((var iter-expr)) body ...) (binding-id? #'var) #'(let loop ([rest iter-expr])