From aab63ad31df1990dabbf749de904ecde8c6b16c6 Mon Sep 17 00:00:00 2001 From: Alexis King Date: Thu, 16 May 2019 10:02:30 -0500 Subject: [PATCH] Add for[*]/foldr[/derived] and reimplement for[*]/stream using it `for/fold` is a left fold, which is normally what you want in a call-by-value language such as Racket, but it makes efficient lazy iteration difficult. This commit adds a new `for/foldr` iteration form (along with `for*/` and `/derived` variants) that provides a right fold operation that offers complete control over precisely how lazy the iteration ought to be. In simple microbenchmarks, reimplementing `for/stream` to use `for/foldr` instead of `for` plus a generator can be almost 40x faster on large streams. --- .../scribblings/reference/for.scrbl | 164 +++++++++++- pkgs/racket-test-core/tests/racket/for.rktl | 137 ++++++++++ racket/collects/racket/private/for.rkt | 242 ++++++++++++------ racket/collects/racket/private/promise.rkt | 117 +++++---- racket/collects/racket/promise.rkt | 30 +-- racket/collects/racket/stream.rkt | 25 +- 6 files changed, 554 insertions(+), 161 deletions(-) diff --git a/pkgs/racket-doc/scribblings/reference/for.scrbl b/pkgs/racket-doc/scribblings/reference/for.scrbl index 0df7c0a353..e490eb3a92 100644 --- a/pkgs/racket-doc/scribblings/reference/for.scrbl +++ b/pkgs/racket-doc/scribblings/reference/for.scrbl @@ -367,6 +367,146 @@ syntactically, a @racket[for-clause] is closer to to the body). @history[#:changed "6.11.0.1" @elem{Added the @racket[#:result] form.}] } +@(define for/foldr-eval ((make-eval-factory '(racket/promise racket/sequence racket/stream)))) +@defform[(for/foldr ([accum-id init-expr] ... accum-option ...) + (for-clause ...) + body-or-break ... body) + #:grammar ([accum-option (code:line #:result result-expr) + #:delay + (code:line #:delay-as delayed-id) + (code:line #:delay-with delayer-id)])]{ + +Like @racket[for/fold], but analogous to @racket[foldr] rather than +@racket[foldl]: the given sequences are still iterated in the same order, but +the loop body is evaluated in reverse order. Evaluation of a @racket[for/foldr] +expression uses space proportional to the number of iterations it performs, and +all elements produced by the given sequences are retained until backwards +evaluation of the loop body begins (assuming the element is, in fact, +referenced in the body). + +@(examples + #:eval for/foldr-eval + (define (in-printing seq) + (sequence-map (lambda (v) (println v) v) seq)) + (eval:check (for/foldr ([acc '()]) + ([v (in-printing (in-range 1 4))]) + (println v) + (cons v acc)) + '(1 2 3))) + +Furthermore, unlike @racket[for/fold], the @racket[accum-id]s are not bound +within @racket[_guard-expr]s or @racket[_body-or-break] forms that appear before +a @racket[_break-clause]. + +While the aforementioned limitations make @racket[for/foldr] less generally +useful than @racket[for/fold], @racket[for/foldr] provides the additional +capability to iterate lazily via the @racket[#:delay], @racket[#:delay-as], and +@racket[#:delay-with] options, which can mitigate many of @racket[for/foldr]'s +disadvantages. If at least one such option is specified, the loop body is given +explicit control over when iteration continues: by default, each +@racket[accum-id] is bound to a @tech{promise} that, when forced, produces the +@racket[accum-id]'s current value. + +In this mode, iteration does not continue until one such promise is forced, +which triggers any additional iteration necessary to produce a value. If the +loop body is lazy in its @racket[accum-id]s---that is, it returns a value +without forcing any of them---then the loop (or any of its iterations) will +produce a value before iteration has completely finished. If a reference to at +least one such promise is retained, then forcing it will resume iteration from +the point at which it was suspended, even if control has left the dynamic extent +of the loop body. + +@(examples + #:eval for/foldr-eval + (eval:check (for/foldr ([acc '()] #:delay) + ([v (in-range 1 4)]) + (printf "--> ~v\n" v) + (begin0 + (cons v (force acc)) + (printf "<-- ~v\n" v))) + '(1 2 3)) + (define resume + (for/foldr ([acc '()] #:delay) + ([v (in-range 1 5)]) + (printf "--> ~v\n" v) + (begin0 + (cond + [(= v 1) (force acc)] + [(= v 2) acc] + [else (cons v (force acc))]) + (printf "<-- ~v\n" v)))) + (eval:check (force resume) '(3 4))) + +This extra control over iteration order allows @racket[for/foldr] to both +consume and construct infinite sequences, so long as it is at least sometimes +lazy in its accumulators. + +@margin-note/ref{ + See also @racket[for/stream] for a more convenient (albeit less flexible) way + to lazily transform infinite sequences. (Internally, @racket[for/stream] is + defined in terms of @racket[for/foldr].)} + +@(examples + #:eval for/foldr-eval + (define squares (for/foldr ([s empty-stream] #:delay) + ([n (in-naturals)]) + (stream-cons (* n n) (force s)))) + (stream->list (stream-take squares 10))) + +The suspension introduced by the @racket[#:delay] option does not ordinarily +affect the loop's eventual return value, but if @racket[#:delay] and +@racket[#:result] are combined, the @racket[accum-id]s will be delayed in the +scope of the @racket[result-expr] in the same way they are delayed within the +loop body. This can be used to introduce an additional layer of suspension +around the evaluation of the entire loop, if desired. + +@(examples + #:eval for/foldr-eval + (define evaluated-yet? #f) + (for/foldr ([acc (set! evaluated-yet? #t)] #:delay) () + (force acc)) + (eval:check evaluated-yet? #t)) +@(examples + #:eval for/foldr-eval + #:label #f + (define evaluated-yet? #f) + (define start + (for/foldr ([acc (set! evaluated-yet? #t)] #:delay #:result acc) () + (force acc))) + (eval:check evaluated-yet? #f) + (force start) + (eval:check evaluated-yet? #t)) + +If the @racket[#:delay-as] option is provided, then @racket[delayed-id] is +bound to an additional promise that returns the values of all @racket[accum-id]s +at once. When multiple @racket[accum-id]s are provided, forcing this promise can +be slightly more efficient than forcing the promises bound to the +@racket[accum-id]s individually. + +If the @racket[#:delay-with] option is provided, the given @racket[delayer-id] +is used to suspend nested iterations (instead of the default, @racket[delay]). +A form of the shape @racket[(delayer-id _recur-expr)] is constructed and placed +in expression position, where @racket[_recur-expr] is an expression that, when +evaluated, will perform the next iteration and return its result (or results). +Sensible choices for @racket[delayer-id] include @racket[lazy], +@racket[delay/sync], @racket[delay/thread], or any of the other promise +constructors from @racketmodname[racket/promise], as well as @racket[thunk] from +@racketmodname[racket/function]. However, beware that choices such as +@racket[thunk] or @racket[delay/name] may evaluate their subexpression multiple +times, which can lead to nonsensical results for sequences that have state, as +the state will be shared between all evaluations of the @racket[_recur-expr]. + +If multiple @racket[accum-id]s are given, the @racket[#:delay-with] option is +provided, and @racket[delayer-id] is not bound to one of @racket[delay], +@racket[lazy], @racket[delay/strict], @racket[delay/sync], +@racket[delay/thread], or @racket[delay/idle], the @racket[accum-id]s will not +be bound at all, even within the loop body. Instead, the @racket[#:delay-as] +option must be specified to access the accumulator values via +@racket[delayed-id]. + +@history[#:added "7.3.0.3"]} +@(close-eval for/foldr-eval) + @defform[(for* (for-clause ...) body-or-break ... body)]{ Like @racket[for], but with an implicit @racket[#:when #t] between each pair of @racket[for-clauses], so that all sequence iterations are @@ -394,6 +534,9 @@ nested. @defform[(for*/last (for-clause ...) body-or-break ... body)] @defform[(for*/fold ([accum-id init-expr] ... maybe-result) (for-clause ...) body-or-break ... body)] +@defform[(for*/foldr ([accum-id init-expr] ... accum-option ...) + (for-clause ...) + body-or-break ... body)] )]{ Like @racket[for/list], etc., but with the implicit nesting of @@ -403,7 +546,9 @@ Like @racket[for/list], etc., but with the implicit nesting of (for*/list ([i '(1 2)] [j "ab"]) (list i j)) -]} +] + +@history[#:changed "7.3.0.3" @elem{Added the @racket[for*/foldr] form.}]} @;------------------------------------------------------------------------ @section{Deriving New Iteration Forms} @@ -462,7 +607,6 @@ source for all syntax errors. ] @history[#:changed "6.11.0.1" @elem{Added the @racket[#:result] form.}]} -} @defform[(for*/fold/derived orig-datum ([accum-id init-expr] ... maybe-result) (for-clause ...) @@ -495,7 +639,21 @@ Like @racket[for*/fold], but the extra @racket[orig-datum] is used as the source ] @history[#:changed "6.11.0.1" @elem{Added the @racket[#:result] form.}]} -} + +@deftogether[( +@defform[(for/foldr/derived orig-datum + ([accum-id init-expr] ... accum-option ...) (for-clause ...) + body-or-break ... body)] +@defform[(for*/foldr/derived orig-datum + ([accum-id init-expr] ... accum-option ...) (for-clause ...) + body-or-break ... body)] +)]{ + +Like @racket[for/foldr] and @racket[for*/foldr], but the extra +@racket[orig-datum] is used as the source for all syntax errors as in +@racket[for/fold/derived] and @racket[for*/fold/derived]. + +@history[#:added "7.3.0.3"]} @defform[(define-sequence-syntax id expr-transform-expr diff --git a/pkgs/racket-test-core/tests/racket/for.rktl b/pkgs/racket-test-core/tests/racket/for.rktl index a83947ab2b..d32578359c 100644 --- a/pkgs/racket-test-core/tests/racket/for.rktl +++ b/pkgs/racket-test-core/tests/racket/for.rktl @@ -944,6 +944,143 @@ (check for/list values ormap) (check for/list values andmap)) +;; ---------------------------------------- +;; `for/foldr` + +(test '(0 1 2 3 4) + 'for/foldr-one-seq + (for/foldr ([lst '()]) + ([x (in-range 5)]) + (cons x lst))) +(test '((0 5) (1 6) (2 7) (3 8) (4 9)) + 'for/foldr-two-seqs + (for/foldr ([lst '()]) + ([x (in-range 5)] + [y (in-range 5 10)]) + (cons (list x y) lst))) +(test '((0 5 10) (1 6 11) (2 7 12) (3 8 13) (4 9 14)) + 'for/foldr-three-seqs + (for/foldr ([lst '()]) + ([x (in-range 5)] + [y (in-range 5 10)] + [z (in-range 10 15)]) + (cons (list x y z) lst))) + +(test '(0 1 2) + 'for*/foldr-one-seq + (for*/foldr ([lst '()]) + ([x (in-range 3)]) + (cons x lst))) +(test '((0 0) (0 1) (0 2) (1 1) (1 2) (1 3) (2 2) (2 3) (2 4)) + 'for*/foldr-two-seqs + (for*/foldr ([lst '()]) + ([x (in-range 3)] + [y (in-range x (+ x 3))]) + (cons (list x y) lst))) + +(test '((0 0) (0 1) (0 2) (2 2) (2 3) (2 4)) + 'for/foldr-guard + (for/foldr ([lst '()]) + ([x (in-range 3)] + #:unless (= x 1) + [y (in-range x (+ x 3))]) + (cons (list x y) lst))) +(test '((0 0) (0 1) (0 2) (1 1) (1 2) (1 3) (2 2)) + 'for*/foldr-break + (for*/foldr ([lst '()]) + ([x (in-range 3)] + [y (in-range x (+ x 3))] + #:break (and (= x 2) (= y 3))) + (cons (list x y) lst))) +(test '((0 0) (0 1) (0 2) (1 1) (1 2) (1 3) (2 2) (2 3)) + 'for*/foldr-final + (for*/foldr ([lst '()]) + ([x (in-range 3)] + [y (in-range x (+ x 3))] + #:final (and (= x 2) (= y 3))) + (cons (list x y) lst))) + +(test '(408 . 20400) + 'for/foldr-two-accs + (for/foldr ([a 1] [b 1] #:result (cons a b)) + ([n (in-range 5)]) + (values b (* a (+ b n))))) + +(test #t 'for/foldr-delay-init + (for/foldr ([acc (error "never gets here")] #:delay) + ([v (in-value #t)]) + v)) + +(test '(0 1 4 9 16) + 'for/foldr-stream-finite + (stream->list + (for/foldr ([s empty-stream] #:delay) + ([v (in-range 5)]) + (stream-cons (sqr v) (force s))))) +(test '(0 1 4 9 16) + 'for/foldr-stream-infinite + (stream->list + (stream-take + (for/foldr ([s (error "never gets here")] #:delay) + ([v (in-naturals)]) + (stream-cons (sqr v) (force s))) + 5))) + +(test '(0 1 4 9 16) + 'for/foldr-stream-finite/thunk + (stream->list + (for/foldr ([s empty-stream] #:delay-with thunk) + ([v (in-range 5)]) + (stream-cons (sqr v) (s))))) +(test '(0 1 4 9 16) + 'for/foldr-stream-infinite/thunk + (stream->list + (stream-take + (for/foldr ([s (error "never gets here")] #:delay-with thunk) + ([v (in-naturals)]) + (stream-cons (sqr v) (s))) + 5))) + +(test '(4 9 16 4 9 16 4 9 16 4) + 'for/foldr-stream-circular + (letrec ([s (for/foldr ([s s] #:delay) + ([v (in-range 2 5)]) + (stream-cons (sqr v) (force s)))]) + (stream->list (stream-take s 10)))) +(test '(0 1 1 2 3 5 8 13 21 34) + 'for/foldr-stream-self-iter + (letrec ([fibs (stream* 0 1 (for/foldr ([more (error "never gets here")] #:delay) + ([a (in-stream fibs)] + [b (in-stream (stream-rest fibs))]) + (stream-cons (+ a b) (force more))))]) + (stream->list (stream-take fibs 10)))) + +(test '(0 -1 2 -3 0 1 -2 3 0 -1) + 'for/foldr-stream-twist + (letrec-values ([(s1 s2) (for/foldr ([s1 s2] [s2 s1] #:delay) + ([n (in-range 4)]) + (values (stream-cons n (force s2)) + (stream-cons (- n) (force s1))))]) + (stream->list (stream-take s1 10)))) +(test '(0 -1 2 -3 0 1 -2 3 0 -1) + 'for/foldr-stream-twist/thunk + (letrec-values ([(s1 s2) + (for/foldr ([s1 s2] [s2 s1] #:delay-with thunk #:delay-as get-next) + ([n (in-range 4)]) + (define next (delay (get-next))) + (values (stream-cons n (let-values ([(s1 s2) (force next)]) s2)) + (stream-cons (- n) (let-values ([(s1 s2) (force next)]) s1))))]) + (stream->list (stream-take s1 10)))) + +;; `#:delay` applies inside `#:result` +(let () + (define evaluated? #f) + (define result (for/foldr ([acc (set! evaluated? #t)] #:result acc #:delay) () + (force acc))) + (test #f 'for/foldr-result-delay-1 evaluated?) + (test (void) 'for/foldr-result-delay-2 (force result)) + (test #t 'for/foldr-result-delay-3 evaluated?)) + ;; ---------------------------------------- (report-errs) diff --git a/racket/collects/racket/private/for.rkt b/racket/collects/racket/private/for.rkt index 7e952c22ce..4f673f9d86 100644 --- a/racket/collects/racket/private/for.rkt +++ b/racket/collects/racket/private/for.rkt @@ -8,6 +8,7 @@ "reverse.rkt" "sort.rkt" "performance-hint.rkt" + "promise.rkt" '#%unsafe '#%flfxnum (for-syntax '#%kernel @@ -19,6 +20,7 @@ "stxcase-scheme.rkt")) (#%provide for/fold for*/fold + for/foldr for*/foldr for for* for/list for*/list for/vector for*/vector @@ -34,6 +36,7 @@ for/hasheqv for*/hasheqv for/fold/derived for*/fold/derived + for/foldr/derived for*/foldr/derived (for-syntax split-for-body) (for-syntax (rename expand-clause expand-for-clause)) @@ -1431,9 +1434,33 @@ [(_ x) x] [(_ x ...) (values x ...)])) - (define-syntax-rule (inner-recur/fold (fold-var ...) (let () expr ...) next-k) - (let-values ([(fold-var ...) (let () expr ...)]) + (define-syntax-rule (inner-recur/fold (fold-var ...) [expr ...] next-k) + (let-values ([(fold-var ...) (let-values () expr ...)]) next-k)) + + (define-for-syntax ((make-inner-recur/foldr/strict fold-vars) stx) + (syntax-case stx () + [(_ () [expr ...] next-k) + #`(let-values ([#,(map syntax-local-introduce fold-vars) next-k]) + expr ...)])) + + (define-for-syntax ((make-inner-recur/foldr/lazy fold-vars delayed-id delayer-id) stx) + (syntax-case stx () + [(_ () [expr ...] next-k) + (with-syntax ([(fold-var ...) (map syntax-local-introduce fold-vars)] + [delayed-id (syntax-local-introduce delayed-id)] + [delayer-id delayer-id]) + #`(let*-values + ([(delayed-id) (delayer-id #,(syntax-protect #'next-k))] + #,@(cond + [(= (length fold-vars) 1) + #`([(fold-var ...) delayed-id])] + [(delayer? (syntax-local-value #'delayer-id (lambda () #f))) + #`([(fold-var) (delayer-id (let-values ([(fold-var ...) (force delayed-id)]) + fold-var))] + ...)] + [else #'()])) + expr ...))])) (define-syntax (push-under-break stx) (syntax-case stx () @@ -1443,7 +1470,7 @@ [(null? l) ;; No #:break form (syntax-protect - #'(inner-recur fold-vars (let-values () expr ...) (if final?-id break-k next-k)))] + #'(inner-recur fold-vars [expr ...] (if final?-id break-k next-k)))] [(eq? '#:break (syntax-e (car l))) ;; Found a #:break form (syntax-protect @@ -1489,34 +1516,36 @@ [inner-binding ...] pre-guard post-guard - [loop-arg ...]) ...) (reverse (syntax->list #'binds))]) + [loop-arg ...]) ...) + (reverse (syntax->list #'binds))]) (syntax-protect (quasisyntax/loc #'orig-stx (let-values (outer-binding ... ...) outer-check ... #,(quasisyntax/loc #'orig-stx (let for-loop ([fold-var fold-init] ... - loop-binding ... ...) + loop-binding ... ...) (if (and pos-guard ...) (let-values (inner-binding ... ...) (if (and pre-guard ...) #,(if (syntax-e #'inner-recur) ;; The general non-nested-loop approach: - #'(let ([post-guard-var (lambda (fold-var ...) (and post-guard ...))]) + #'(let () + (define (next-k-proc fold-var ...) + (if (and post-guard ...) + (for-loop fold-var ... loop-arg ... ...) + next-k)) (for/foldX/derived [orig-stx inner-recur nested? #f ()] - ([fold-var fold-var] ...) - (if (post-guard-var fold-var ...) - (for-loop fold-var ... loop-arg ... ...) - next-k) - break-k final?-id - rest expr1 . body)) + ([fold-var fold-var] ...) + (next-k-proc fold-var ...) break-k final?-id + rest expr1 . body)) ;; The specialized nested-loop approach, which is ;; slightly faster when it works: #'(let-values ([(fold-var ...) (for/foldX/derived [orig-stx inner-recur nested? #f ()] - ([fold-var fold-var] ...) - next-k break-k final?-id - rest expr1 . body)]) + ([fold-var fold-var] ...) + next-k break-k final?-id + rest expr1 . body)]) (if (and post-guard ... (not final?-id)) (for-loop fold-var ... loop-arg ... ...) next-k))) @@ -1572,12 +1601,9 @@ [(_ [orig-stx inner-recur nested? #f binds] fold-bind next-k break-k final?-id ([id rhs] . rest) . body) (identifier? #'id) (syntax-protect - #'(for/foldX/derived [orig-stx inner-recur nested? #f binds] fold-bind next-k break-k final?-id + #'(for/foldX/derived [orig-stx inner-recur nested? #f binds] + fold-bind next-k break-k final?-id ([(id) rhs] . rest) . body))] - ;; If we get here in single-value mode, then it's a bad clause: - [(_ [orig-stx inner-recur #f #f nested? #f binds] fold-bind next-k break-k final?-id (clause . rest) . body) - (raise-syntax-error - #f "bad sequence binding clause" #'orig-stx #'clause)] ;; Expand one multi-value clause, and push it into the results to emit: [(frm [orig-stx inner-recur nested? #f binds] ([fold-var fold-init] ...) next-k break-k final?-id (clause . rest) . body) (with-syntax ([bind (expand-clause #'orig-stx #'clause)]) @@ -1593,7 +1619,7 @@ [(_ [orig-stx . _] . _) (raise-syntax-error #f "bad syntax" #'orig-stx)])) - (define-syntax (for/foldX/derived/final stx) + (define-syntax (for/fold/derived/final stx) (syntax-case stx () [(_ [orig-stx nested?] fold-bind done-k (clause ...) expr ...) ;; If there's a `#:break` or `#:final`, then we need to use the @@ -1607,53 +1633,116 @@ (syntax-protect #'(for/foldX/derived [orig-stx #f nested? #f ()] fold-bind done-k done-k #f . rest))])) - (define-syntax (for/fold/derived stx) - (syntax-case stx () - [(_ orig-stx ([fold-var finid-init] ... #:result result-expr) . rest) - (check-identifier-bindings #'orig-stx #'(fold-var ...) "accumulator" #t) - (syntax-protect - (syntax/loc #'orig-stx - (let-values ([(fold-var ...) (for/foldX/derived/final [orig-stx #f] - ([fold-var finid-init] ...) - (values* fold-var ...) - . rest)]) - result-expr)))] - [(_ orig-stx ([fold-var finid-init] ...) . rest) - (check-identifier-bindings #'orig-stx #'(fold-var ...) "accumulator" #t) - (syntax-protect - (syntax/loc #'orig-stx - (for/foldX/derived/final [orig-stx #f] - ([fold-var finid-init] ...) - (values* fold-var ...) - . rest)))] - [(_ orig-stx (bindings ...) . rst) - (raise-syntax-error #f "invalid accumulator binding clause(s)" #'orig-stx #'(bindings ...))] - [(_ orig-stx . rst) - (raise-syntax-error #f "bad syntax" #'orig-stx)])) + (define-syntaxes (for/fold/derived for*/fold/derived for/foldr/derived for*/foldr/derived) + (let () + (define (parse-bindings+options stx orig-stx right?) + (let loop ([stx stx] + [parsed-any-opts? #f] + [bindings '()] + [result-expr #f] + [delay? #f] + [delayed-id #f] + [delayer-id #f]) + (syntax-case stx () + [() + (let ([delay? (or delay? delayed-id delayer-id)]) + (values (reverse bindings) + result-expr + delay? + (or delayed-id #'delayed) + (or delayer-id #'delay)))] + [([fold-var fold-init] . rest) + (not parsed-any-opts?) + (loop #'rest #f (cons #'[fold-var fold-init] bindings) + result-expr delay? delayed-id delayer-id)] + [(#:result expr . rest) + (not (keyword? (syntax-e #'expr))) + (if result-expr + (raise-syntax-error #f "duplicate #:result option" orig-stx #'kw) + (loop #'rest #t bindings #'expr delay? delayed-id delayer-id))] + [(#:result . rest) + (raise-syntax-error #f "expected expression for #:result option" orig-stx #'rest)] + [(kw . rest) + (and right? (eq? (syntax-e #'kw) '#:delay)) + (if delay? + (raise-syntax-error #f "duplicate #:delay option" orig-stx #'kw) + (loop #'rest #t bindings result-expr #t delayed-id delayer-id))] + [(#:delay-as id . rest) + (and right? (identifier? #'id)) + (if delayed-id + (raise-syntax-error #f "duplicate #:delay-as option" orig-stx #'id) + (loop #'rest #t bindings result-expr delay? #'id delayer-id))] + [(#:delay-as . rest) + right? + (raise-syntax-error #f "expected identifier for #:delay-as option" orig-stx #'rest)] + [(#:delay-with id . rest) + (and right? (identifier? #'id)) + (if delayer-id + (raise-syntax-error #f "duplicate #:delay-with option" orig-stx #'id) + (loop #'rest #t bindings result-expr delay? delayed-id #'id))] + [(#:delay-with . rest) + right? + (raise-syntax-error #f "expected identifier for #:delay-with option" orig-stx #'rest)] + [_ + (raise-syntax-error #f + (if parsed-any-opts? + "invalid accumulator option(s)" + "invalid accumulator binding clause(s)") + orig-stx + stx)]))) - (define-syntax (for*/fold/derived stx) - (syntax-case stx () - [(_ orig-stx ([fold-var finid-init] ... #:result result-expr) . rest) - (check-identifier-bindings #'orig-stx #'(fold-var ...) "accumulator" #t) - (syntax-protect - (syntax/loc #'orig-stx - (let-values ([(fold-var ...) (for/foldX/derived/final [orig-stx #t] - ([fold-var finid-init] ...) - (values* fold-var ...) - . rest)]) - result-expr)))] - [(_ orig-stx ([fold-var finid-init] ...) . rest) - (check-identifier-bindings #'orig-stx #'(fold-var ...) "accumulator" #t) - (syntax-protect - (syntax/loc #'orig-stx - (for/foldX/derived/final [orig-stx #t] - ([fold-var finid-init] ...) - (values* fold-var ...) - . rest)))] - [(_ orig-stx (bindings ...) . rst) - (raise-syntax-error #f "invalid accumulator binding clause(s)" #'orig-stx #'(bindings ...))] - [(_ orig-stx . rst) - (raise-syntax-error #f "bad syntax" #'orig-stx)])) + (define ((make for*? right?) stx) + (syntax-case stx () + [(_ orig-stx bindings+options . rest) + (let () + (define-values (bindings result-expr delay? delayed-id delayer-id) + (parse-bindings+options #'bindings+options #'orig-stx right?)) + (with-syntax ([([fold-var fold-init] ...) bindings] + [delayed-id delayed-id] + [delayer-id delayer-id]) + (check-identifier-bindings #'orig-stx #`(fold-var ... delayed-id) "accumulator" (void)) + (syntax-protect + (cond + [right? + (define loop-stx + (quasisyntax/loc #'orig-stx + (for/foldX/derived [orig-stx inner-recur/foldr #,for*? #f ()] + () + (done-k-proc) + (done-k-proc) + #f + . rest))) + (quasisyntax/loc #'orig-stx + (let () + (define (done-k-proc) (#%expression (values* fold-init ...))) + (define-syntax inner-recur/foldr + #,(if delay? + #'(make-inner-recur/foldr/lazy + (list (quote-syntax fold-var) ...) + (quote-syntax delayed-id) + (quote-syntax delayer-id)) + #'(make-inner-recur/foldr/strict + (list (quote-syntax fold-var) ...)))) + #,(if result-expr + ;; Make sure `fold-var`s in `result-expr` are also delayed, if relevant + #`(inner-recur/foldr () [#,result-expr] #,loop-stx) + loop-stx)))] + [else + (define loop-stx + (quasisyntax/loc #'orig-stx + (for/fold/derived/final [orig-stx #,for*?] + ([fold-var fold-init] ...) + (values* fold-var ...) + . rest))) + (if result-expr + (quasisyntax/loc #'orig-stx + (let-values ([(fold-var ...) #,loop-stx]) + #,result-expr)) + loop-stx)]))))] + [(_ orig-stx . rst) + (raise-syntax-error #f "bad syntax" #'orig-stx)])) + + (values (make #f #f) (make #t #f) (make #f #t) (make #t #t)))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; derived `for' syntax @@ -1738,14 +1827,17 @@ (define-syntax-via-derived for for/fold/derived fold-bind wrap rhs-wrap combine) (define-syntax-via-derived for* for*/fold/derived fold-bind wrap rhs-wrap combine))])) - (define-syntax (for/fold stx) - (syntax-case stx () - [(_ . rest) (syntax-protect - (quasisyntax/loc stx (for/fold/derived #,stx . rest)))])) - (define-syntax (for*/fold stx) - (syntax-case stx () - [(_ . rest) (syntax-protect - (quasisyntax/loc stx (for*/fold/derived #,stx . rest)))])) + (define-syntaxes (for/fold for*/fold for/foldr for*/foldr) + (let () + (define ((make f/f/d-id) stx) + (syntax-case stx () + [(_ . rest) + (syntax-protect (quasisyntax/loc stx + (#,f/f/d-id #,stx . rest)))])) + (values (make #'for/fold/derived) + (make #'for*/fold/derived) + (make #'for/foldr/derived) + (make #'for*/foldr/derived)))) (define-for-variants (for for*) () diff --git a/racket/collects/racket/private/promise.rkt b/racket/collects/racket/private/promise.rkt index de71ab53f3..20c572c783 100644 --- a/racket/collects/racket/private/promise.rkt +++ b/racket/collects/racket/private/promise.rkt @@ -3,15 +3,22 @@ "more-scheme.rkt" "define.rkt" (rename "define-struct.rkt" define-struct define-struct*) - (for-syntax '#%kernel "stxcase-scheme.rkt" "name.rkt") + (for-syntax '#%kernel + "small-scheme.rkt" + "define.rkt" + "struct.rkt" + "stxcase-scheme.rkt" + "name.rkt") '#%unsafe) (#%provide force promise? promise-forced? promise-running? + (rename lazy* lazy) + (rename delay* delay) ;; provided to create extensions (struct promise ()) (protect pref pset!) prop:force reify-result promise-forcer promise-printer (struct running ()) (struct reraise ()) - (for-syntax make-delayer)) + (for-syntax delayer delayer?)) ;; This module implements "lazy" (composable) promises and a `force' ;; that is iterated through them. @@ -197,59 +204,64 @@ ;; template for all delay-like constructs ;; (with simple keyword matching: keywords is an alist with default exprs) -(define-for-syntax (make-delayer stx maker keywords) - ;; no `cond', `and', `or', `let', `define', etc here - (letrec-values - ([(exprs+kwds) - (lambda (stxs exprs kwds) - (if (null? stxs) - (values (reverse exprs) (reverse kwds)) - (if (not (keyword? (syntax-e (car stxs)))) - (exprs+kwds (cdr stxs) (cons (car stxs) exprs) kwds) - (if (if (pair? (cdr stxs)) - (if (assq (syntax-e (car stxs)) keywords) - (not (assq (syntax-e (car stxs)) kwds)) - #f) - #f) - (exprs+kwds (cddr stxs) exprs - (cons (cons (syntax-e (car stxs)) (cadr stxs)) - kwds)) - (values #f #f)))))] - [(stxs) (syntax->list stx)] - [(exprs kwds) (exprs+kwds (if stxs (cdr stxs) '()) '() '())] - [(kwd-args) (if kwds - (map (lambda (k) - (let-values ([(x) (assq (car k) kwds)]) - (if x (cdr x) (cdr k)))) - keywords) - #f)] - ;; some strange bug with `syntax-local-expand-expression' makes this not - ;; work well with identifiers, so turn the name into a symbol to work - ;; around this for now - [(name0) (syntax-local-infer-name stx)] - [(name) (if (syntax? name0) (syntax-e name0) name0)] - [(unwind-promise) - (lambda (stx unwind-recur) - (syntax-case stx () - [(#%plain-lambda () body) (unwind-recur #'body)]))]) - (syntax-case stx () - [_ (pair? exprs) ; throw a syntax error if anything is wrong - (with-syntax ([(expr ...) exprs] - [(kwd-arg ...) kwd-args]) - (with-syntax ([proc - (stepper-syntax-property - (syntax-property - (syntax/loc stx (lambda () expr ...)) - 'inferred-name name) - 'stepper-hint unwind-promise)] - [make maker]) - (syntax/loc stx (make proc kwd-arg ...))))]))) +(begin-for-syntax + (struct delayer (maker keywords) + #:property prop:procedure + (lambda (self stx) + (define keywords (delayer-keywords self)) + + (define (parse-exprs+kwds stxs) + (let loop ([stxs stxs] + [exprs '()] + [kwds '()]) + (syntax-case stxs () + [() + (values (reverse exprs) (reverse kwds))] + [(expr . rest) + (not (keyword? (syntax-e #'expr))) + (loop #'rest (cons #'expr exprs) kwds)] + [(kw-stx expr . rest) + (not (keyword? (syntax-e #'expr))) + (let ([kw (syntax-e #'kw-stx)]) + (cond + [(not (assq kw keywords)) + (raise-syntax-error #f "unrecognized option" stx #'kw-stx)] + [(assq kw kwds) + (raise-syntax-error #f "duplicate option" stx #'kw-stx)] + [else + (loop #'rest exprs (cons (cons kw #'expr) kwds))]))] + [(kw-stx . rest) + (raise-syntax-error #f "missing argument for option" stx #'kw-stx)] + [_ + (raise-syntax-error #f "bad syntax" stx stxs)]))) + + (define (unwind-promise stx unwind-recur) + (syntax-case stx () + [(#%plain-lambda () body) (unwind-recur #'body)])) + + (syntax-case stx () + [(_ . exprs+kwds) + (let () + (define-values (exprs kwds) (parse-exprs+kwds #'exprs+kwds)) + (with-syntax ([(expr ...) exprs] + [(kwd-arg ...) (map (lambda (k) + (cond + [(assq (car k) kwds) => cdr] + [else (cdr k)])) + keywords)]) + (with-syntax ([proc + (stepper-syntax-property + (syntax-property + (syntax/loc stx (lambda () expr ...)) + 'inferred-name (syntax-local-infer-name stx)) + 'stepper-hint unwind-promise)] + [make (delayer-maker self)]) + (syntax-protect (syntax/loc stx (make proc kwd-arg ...))))))])))) ;; Creates a composable promise ;; X = (force (lazy X)) = (force (lazy (lazy X))) = (force (lazy^n X)) -(#%provide (rename lazy* lazy)) (define lazy make-composable-promise) -(define-syntax (lazy* stx) (syntax-protect (make-delayer stx #'lazy '()))) +(define-syntax lazy* (delayer #'lazy '())) ;; Creates a (generic) promise that does not compose ;; X = (force (delay X)) = (force (lazy (delay X))) @@ -259,9 +271,8 @@ ;; sequence of `(lazy^n o delay)^m o lazy^k' requires m+1 `force's (for k>0) ;; (This is not needed with a lazy language (see the above URL for details), ;; but provided for regular delay/force uses.) -(#%provide (rename delay* delay)) (define delay make-promise) -(define-syntax (delay* stx) (syntax-protect (make-delayer stx #'delay '()))) +(define-syntax delay* (delayer #'delay '())) ;; For simplicity and efficiency this code uses thunks in promise values for ;; exceptions: this way, we don't need to tag exception values in some special diff --git a/racket/collects/racket/promise.rkt b/racket/collects/racket/promise.rkt index 2452b853e4..922d38467d 100644 --- a/racket/collects/racket/promise.rkt +++ b/racket/collects/racket/promise.rkt @@ -1,26 +1,29 @@ #lang racket/base (require "private/promise.rkt" (for-syntax racket/base)) -(provide delay lazy force promise? promise-forced? promise-running?) +(provide delay lazy force promise? promise-forced? promise-running? promise/name? + (rename-out [delay/name* delay/name] + [delay/strict* delay/strict] + [delay/sync* delay/sync] + [delay/thread* delay/thread] + [delay/idle* delay/idle])) ;; ---------------------------------------------------------------------------- ;; More delay-like values, with different ways of deferring computations (define-struct (promise/name promise) () #:property prop:force (λ(p) ((pref p)))) -(provide (rename-out [delay/name* delay/name]) promise/name?) (define delay/name make-promise/name) -(define-syntax (delay/name* stx) (make-delayer stx #'delay/name '())) +(define-syntax delay/name* (delayer #'delay/name '())) ;; mostly to implement srfi-45's `eager' (define-struct (promise/strict promise) () #:property prop:force (λ(p) (reify-result (pref p)))) ; never a thunk -(provide (rename-out [delay/strict* delay/strict])) (define (delay/strict thunk) ;; could use `reify-result' here to capture exceptions too, or just create a ;; promise and immediately force it, but no point since if there's an ;; exception then the promise value is never used. (make-promise/strict (call-with-values thunk list))) -(define-syntax (delay/strict* stx) (make-delayer stx #'delay/strict '())) +(define-syntax delay/strict* (delayer #'delay/strict '())) ;; utility struct (define-struct (running-thread running) (thread)) @@ -82,13 +85,12 @@ (λ(p) (define v (pref p)) (wrap-evt (if (syncinfo? v) (syncinfo-done-evt v) always-evt) void))) -(provide (rename-out [delay/sync* delay/sync])) (define (delay/sync thunk) (define done-sema (make-semaphore 0)) (make-promise/sync (make-syncinfo thunk (semaphore-peek-evt done-sema) done-sema (make-semaphore 1)))) -(define-syntax (delay/sync* stx) (make-delayer stx #'delay/sync '())) +(define-syntax delay/sync* (delayer #'delay/sync '())) ;; threaded promises @@ -110,7 +112,6 @@ (wrap-evt (if (running? v) (running-thread-thread v) always-evt) void))) -(provide (rename-out [delay/thread* delay/thread])) (define (delay/thread thunk group) (unless (or (not group) (thread-group? group)) @@ -135,8 +136,7 @@ (semaphore-post initialized-sema) p) (define-syntax delay/thread* - (let ([kwds (list (cons '#:group #'(make-thread-group)))]) - (λ(stx) (make-delayer stx #'delay/thread kwds)))) + (delayer #'delay/thread (list (cons '#:group #'(make-thread-group))))) (define-struct (promise/idle promise/thread) () #:property prop:force @@ -152,7 +152,6 @@ (pref p)) v)))) -(provide (rename-out [delay/idle* delay/idle])) (define (delay/idle thunk wait-for work-while tick use*) (unless (evt? wait-for) (raise-argument-error 'delay/idle "evt?" wait-for)) @@ -211,8 +210,7 @@ (or (object-name thunk) 'idle-thread)))) p) (define-syntax delay/idle* - (let ([kwds (list (cons '#:wait-for #'(system-idle-evt)) - (cons '#:work-while #'(system-idle-evt)) - (cons '#:tick #'0.2) - (cons '#:use #'0.12))]) - (λ(stx) (make-delayer stx #'delay/idle kwds)))) + (delayer #'delay/idle (list (cons '#:wait-for #'(system-idle-evt)) + (cons '#:work-while #'(system-idle-evt)) + (cons '#:tick #'0.2) + (cons '#:use #'0.12)))) diff --git a/racket/collects/racket/stream.rkt b/racket/collects/racket/stream.rkt index f89cdabbcc..4e79220a6a 100644 --- a/racket/collects/racket/stream.rkt +++ b/racket/collects/racket/stream.rkt @@ -4,6 +4,7 @@ racket/generic racket/contract/base racket/contract/combinator + racket/function racket/generator (rename-in "private/for.rkt" [stream-ref stream-get-generics]) @@ -335,17 +336,13 @@ (define ((make-for/stream derived-stx) stx) (syntax-case stx () [(_ clauses . body) - (begin - (when (null? (syntax->list #'body)) - (raise-syntax-error (syntax-e #'derived-stx) - "missing body expression after sequence bindings" - stx #'body)) - (with-syntax ([((pre-body ...) body*) (split-for-body stx #'body)]) - #`(sequence->stream - (in-generator - (#,derived-stx #,stx () clauses - pre-body ... - (yield (let () . body*)) - (values))))))])) - (values (make-for/stream #'for/fold/derived) - (make-for/stream #'for*/fold/derived)))) + (with-syntax ([((pre-body ...) (post-body ...)) (split-for-body stx #'body)]) + (quasisyntax/loc stx + (#,derived-stx #,stx + ([get-rest empty-stream] + #:delay-with thunk) + clauses + pre-body ... + (stream-cons (let () post-body ...) (get-rest)))))])) + (values (make-for/stream #'for/foldr/derived) + (make-for/stream #'for*/foldr/derived))))