From d7b18e7a9c7c421a9799c4cd9653b094edafccbc Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 12 Dec 2016 19:23:54 -0700 Subject: [PATCH] adjust `map` and `for ... in-list` to not retain their lists Adjust list and stream handling as sequences so that during the body (for ([i (in-list l)]) ....) then `i` and its cons cell in `l` are not implicitly retained while the body is evaluated. A `for .... in-stream` similarly avoids retaining the stream whose head is being used in the loop body. The `map`, `for-each`, `andmap`, and `ormap` functions are similarly updated. The `make-do-sequence` protocol allows an optional extra result so that new sequence types could have the same properties. It's not clear that using `make-do-sequence` is any more useful than creating the new sequence as a stream, but it was easier to expose the new functionality than to hide it. Making this work required a repair to the optimizer, which would incorrectly move an `if` expression in a way that could affect space complexity, as well as a few repairs to the run-time system (especially in the vicinity of the built-in `map`, which we should just get rid of eventually, anyway). --- pkgs/base/info.rkt | 2 +- .../scribblings/reference/for.scrbl | 13 +- .../scribblings/reference/sequences.scrbl | 72 ++++++--- pkgs/racket-test-core/tests/racket/for.rktl | 62 +++++++ .../tests/racket/optimize.rktl | 16 +- racket/collects/racket/private/for.rkt | 151 +++++++++++------- racket/collects/racket/private/map.rkt | 53 ++++-- racket/src/racket/src/eval.c | 28 +++- racket/src/racket/src/optimize.c | 5 +- racket/src/racket/src/schmap.inc | 55 +++++-- racket/src/racket/src/schvers.h | 4 +- 11 files changed, 346 insertions(+), 115 deletions(-) diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index 3beced4387..2f3c3380f6 100644 --- a/pkgs/base/info.rkt +++ b/pkgs/base/info.rkt @@ -12,7 +12,7 @@ (define collection 'multi) -(define version "6.7.0.3") +(define version "6.7.0.4") (define deps `("racket-lib" ["racket" #:version ,version])) diff --git a/pkgs/racket-doc/scribblings/reference/for.scrbl b/pkgs/racket-doc/scribblings/reference/for.scrbl index 4fb50454c9..f2067cff0f 100644 --- a/pkgs/racket-doc/scribblings/reference/for.scrbl +++ b/pkgs/racket-doc/scribblings/reference/for.scrbl @@ -81,6 +81,15 @@ iteration and preventing later @racket[body] evaluations, a @racket[#:break guard-expr] or @racket[#:final guard-expr] clause starts a new internal-definition context. +In the case of @tech{list} and @tech{stream} sequences, the +@racket[for] form itself does not keep each element reachable. If a +list or stream produced by a @racket[seq-expr] is otherwise +unreachable, and if the @racket[for] body can no longer reference an +@racket[id] for a list element, then the element is subject to +@tech{garbage collection}. The @racket[make-do-sequence] sequence +constructor supports additional sequences that behave like lists and +streams in this way. + @examples[ (for ([i '(1 2 3)] [j "abc"] @@ -108,7 +117,9 @@ clause starts a new internal-definition context. (display "here")) (for ([i '()]) (error "doesn't get here")) -]} +] + +@history[#:changed "6.7.0.4" @elem{Added support for the optional second result.}]} @defform[(for/list (for-clause ...) body-or-break ... body)]{ Iterates like @racket[for], but that the last expression in the @racket[body]s must diff --git a/pkgs/racket-doc/scribblings/reference/sequences.scrbl b/pkgs/racket-doc/scribblings/reference/sequences.scrbl index 13d889bdf7..17d56551f0 100644 --- a/pkgs/racket-doc/scribblings/reference/sequences.scrbl +++ b/pkgs/racket-doc/scribblings/reference/sequences.scrbl @@ -9,6 +9,10 @@ @margin-note{See @secref[where] for information on using @|what| as sequences.}) +@(define (for-element-reachability what) + @elem{See @racket[for] for information on the reachability of @|what| elements + during an iteration.}) + @title[#:style 'toc #:tag "sequences+streams"]{Sequences and Streams} @tech{Sequences} and @tech{streams} abstract over iteration of elements in a @@ -196,11 +200,14 @@ each element in the sequence. to using @racket[lst] directly as a sequence. @info-on-seq["pairs" "lists"] @speed[in-list "list"] + @for-element-reachability["list"] @examples[#:eval sequence-evaluator (for/list ([x (in-list '(3 1 4))]) `(,x ,(* x x)))] -} + +@history[#:changed "6.7.0.4" @elem{Improved element-reachability guarantee for lists in @racket[for].}]} + @defproc[(in-mlist [mlst mlist?]) sequence?]{ Returns a sequence equivalent to @racket[mlst]. @@ -591,12 +598,19 @@ each element in the sequence. } @defproc[(make-do-sequence - [thunk (-> (values (any/c . -> . any) - (any/c . -> . any/c) - any/c - (or/c (any/c . -> . any/c) #f) - (or/c (() () #:rest list? . ->* . any/c) #f) - (or/c ((any/c) () #:rest list? . ->* . any/c) #f)))]) + [thunk (or/c (-> (values (any/c . -> . any) + (any/c . -> . any/c) + any/c + (or/c (any/c . -> . any/c) #f) + (or/c (() () #:rest list? . ->* . any/c) #f) + (or/c ((any/c) () #:rest list? . ->* . any/c) #f))) + (-> (values (any/c . -> . any) + (or/c (any/c . -> . any/c) #f) + (any/c . -> . any/c) + any/c + (or/c (any/c . -> . any/c) #f) + (or/c (() () #:rest list? . ->* . any/c) #f) + (or/c ((any/c) () #:rest list? . ->* . any/c) #f))))]) sequence?]{ Returns a sequence whose elements are generated by the procedures and initial value returned by the thunk, which is called to @@ -609,37 +623,55 @@ each element in the sequence. @itemize[ @item{The first result is a @racket[_pos->element] procedure that takes the current position and returns the value(s) for the - current element.} - @item{The second result is a @racket[_next-pos] procedure that + current element.} + @item{The optional second result is an @racket[_early-next-pos] + procedure that is described further below. Alternatively, the + optional second result can be @racket[#f], which is equivalent + to the identity function.} + @item{The third (or second) result is a @racket[_next-pos] procedure that takes the current position and returns the next position.} - @item{The third result is the initial position.} - @item{The fourth result is a @racket[_continue-with-pos?] function + @item{The fourth (or third) result is the initial position.} + @item{The fifth (or fourth) result is a @racket[_continue-with-pos?] function that takes the current position and returns a true result if the sequence includes the value(s) for the current position, and false if the sequence should end instead of including the - value(s). Alternatively, the fourth result can be @racket[#f] to + value(s). Alternatively, the fifth (or fourth) result can be @racket[#f] to indicate that the sequence should always include the current - value(s).} - @item{The fifth result is a @racket[_continue-with-val?] function + value(s). This function is checked on each position before + @racket[_pos->element] is used.} + @item{The sixth (or fifth) result is a @racket[_continue-with-val?] function that is like the fourth result, but it takes the current element value(s) instead of the current position. Alternatively, the - fifth result can be @racket[#f] to indicate that the sequence + sixth (or fifth) result can be @racket[#f] to indicate that the sequence should always include the value(s) at the current position.} - @item{The sixth result is a @racket[_continue-after-pos+val?] + @item{The seventh (or sixth) result is a @racket[_continue-after-pos+val?] procedure that takes both the current position and the current element value(s) and determines whether the sequence ends after the current element is already included in the sequence. - Alternatively, the sixth result can be @racket[#f] to indicate + Alternatively, the seventh (or sixth) result can be @racket[#f] to indicate that the sequence can always continue after the current value(s).}] + The @racket[_early-next-pos] procedure, which is the optional second + result, takes the current position and returns an updated position. + This updated position is used for @racket[_next-pos] and + @racket[_continue-after-pos+val?], but not with + @racket[_continue-with-pos?] (which uses the original current + position). The intent of @racket[_early-next-pos] is to support a + sequence where the position must be incremented to avoid keeping a + value reachable while a loop processes the sequence value, so + @racket[_early-next-pos] is applied just after + @racket[_pos->element].} + Each of the procedures listed above is called only once per position. Among the last three procedures, as soon as one of the procedures returns @racket[#f], the sequence ends, and none are called again. Typically, one of the functions determines the end condition, and @racket[#f] is used in place of the other two functions. -} + +@history[#:changed "6.7.0.4" @elem{Added support for the optional second result.}]} + @defthing[prop:sequence struct-type-property?]{ @@ -973,7 +1005,9 @@ stream, but plain lists can be used as streams, and functions such as @defproc[(in-stream [s stream?]) sequence?]{ Returns a sequence that is equivalent to @racket[s]. @speed[in-stream "streams"] -} + @for-element-reachability["stream"] + +@history[#:changed "6.7.0.4" @elem{Improved element-reachability guarantee for streams in @racket[for].}]} @defthing[empty-stream stream?]{ A stream with no elements. diff --git a/pkgs/racket-test-core/tests/racket/for.rktl b/pkgs/racket-test-core/tests/racket/for.rktl index 5ad2e5b8f7..b966574aac 100644 --- a/pkgs/racket-test-core/tests/racket/for.rktl +++ b/pkgs/racket-test-core/tests/racket/for.rktl @@ -142,6 +142,27 @@ #f (lambda (pos val) (val . < . 5)))) +(let ([five-odd-seq + (lambda (pos pre post) + (test-sequence [(1 3 5)] + (make-do-sequence (lambda () + (values add1 + add1 ; "pre" next + add1 + 0 + pos + pre + post)))))]) + (five-odd-seq (lambda (pos) (pos . < . 5)) + #f + #f) + (five-odd-seq #f + (lambda (val) (val . < . 6)) + #f) + (five-odd-seq #f + #f + (lambda (pos val) (val . < . 5)))) + (let ([fives-seq (lambda (pos pre post) (test-sequence [(1 2 3 4 5) ("0" "1" "2" "3" "4")] @@ -689,4 +710,45 @@ exn:fail:contract? #rx"expected:.*and/c hash\\? hash-weak\\?") +;; ---------------------------------------- +;; Check that iteration over a list or stream doesn't implicitly +;; retain the head while the body is running + +(when (custodian-memory-accounting-available?) + (define-syntax-rule (check for/... in-... proc extra ...) + (let* ([N 10] + [vals (for/... ([i N]) (gensym))] + [bs (for/list ([val vals]) (make-weak-box val))] + [retained 0]) + (if proc + (proc (lambda (i b extra ...) + (collect-garbage) + (when (weak-box-value b) + (set! retained (add1 retained)))) + vals bs (for/list ([val vals]) 'extra) ...) + (for ([i (in-... vals)] + [b (in-list bs)]) + (collect-garbage) + (when (weak-box-value b) + (set! retained (add1 retained))))) + (test #t `(in-... ,retained) (< retained (/ N 2))))) + (check for/list in-list #f) + (check for/list values #f) + (check for/stream in-stream #f) + (check for/stream values #f) + (define-syntax-rule (stop-before-in-list e) + (values (stop-before (in-list e) (lambda (v) #f)))) + (check for/list stop-before-in-list #f) + (define-syntax-rule (values-stop-before e) + (values (values (stop-before e (lambda (v) #f))))) + (check for/list values-stop-before #f) + + ;; Check `map`, etc., too + (check for/list values map) + (check for/list values map extra) ; 1 and 2 arguments are special-cased + (check for/list values for-each) + (check for/list values andmap)) + +;; ---------------------------------------- + (report-errs) diff --git a/pkgs/racket-test-core/tests/racket/optimize.rktl b/pkgs/racket-test-core/tests/racket/optimize.rktl index a9e5a62c3a..b4fcf6a3b0 100644 --- a/pkgs/racket-test-core/tests/racket/optimize.rktl +++ b/pkgs/racket-test-core/tests/racket/optimize.rktl @@ -27,9 +27,8 @@ [t2 (get-output-bytes s2)]) (define same? (bytes=? t1 t2)) (when (and (not same?) want-same?) - (printf "~s\n~s\n" - (zo-parse (open-input-bytes t1)) - (zo-parse (open-input-bytes t2)))) + (pretty-write (zo-parse (open-input-bytes t1))) + (pretty-write (zo-parse (open-input-bytes t2)))) (unless (equal? same? want-same?) ;; Unquote to cause a failure to stop 'stop) @@ -1731,6 +1730,17 @@ #f (add1 c)))))) +;; Don't move a branch that selects a variable past an +;; expression that can inspect space consumption: +(test-comp '(lambda (a b c f) + (let ((d (if a b c))) + (f) + d)) + '(lambda (a b c f) + (f) + (if a b c)) + #f) + (test-comp '(lambda (x y q) (let ([z (+ x y)]) (list (if q x y) z))) diff --git a/racket/collects/racket/private/for.rkt b/racket/collects/racket/private/for.rkt index 4115adc3d0..60a68b9030 100644 --- a/racket/collects/racket/private/for.rkt +++ b/racket/collects/racket/private/for.rkt @@ -339,31 +339,43 @@ (syntax-column #'rhs)) #'rhs)) (with-syntax ([[(id ...) rhs] (introducer (syntax-local-introduce clause))]) - (arm-for-clause - (syntax-local-introduce - (introducer - #`(([(pos->vals pos-next init pos-cont? val-cont? all-cont?) + (with-syntax ([(post-id ...) (generate-temporaries #'(id ...))]) + (arm-for-clause + (syntax-local-introduce + (introducer + #`(([(pos->vals pos-pre-inc pos-next init pos-cont? val-cont? all-cont?) + #,(syntax-property + (syntax/loc #'rhs (make-sequence '(id ...) rhs)) + 'feature-profile:generic-sequence #t)]) + (void) + ([pos init]) #,(syntax-property - (syntax/loc #'rhs (make-sequence '(id ...) rhs)) - 'feature-profile:generic-sequence #t)]) - (void) - ([pos init]) - #,(syntax-property - (syntax/loc #'rhs (if pos-cont? (pos-cont? pos) #t)) - 'feature-profile:generic-sequence #t) - ([(id ...) #,(syntax-property - (syntax/loc #'rhs (pos->vals pos)) - 'feature-profile:generic-sequence #t)]) - #,(syntax-property - (syntax/loc #'rhs (if val-cont? (val-cont? id ...) #t)) - 'feature-profile:generic-sequence #t) - #,(syntax-property - (syntax/loc #'rhs (if all-cont? (all-cont? pos id ...) #t)) - 'feature-profile:generic-sequence #t) - #,(syntax-property - (syntax/loc #'rhs ((pos-next pos))) - 'feature-profile:generic-sequence #t)))) - (make-rearm))))] + (syntax/loc #'rhs (if pos-cont? (pos-cont? pos) #t)) + 'feature-profile:generic-sequence #t) + ([(id ... all-cont?/pos) + (let-values ([(id ...) #,(syntax-property + (syntax/loc #'rhs (pos->vals pos)) + 'feature-profile:generic-sequence #t)]) + (values id ... + ;; If we need to call `all-cont?`, close over + ;; `id`s here, so `id`s are not implicitly + ;; retained while the body runs: + (and all-cont? + (lambda (pos) + (all-cont? pos id ...)))))] + [(pos) #,(syntax-property + (syntax/loc #'rhs (if pos-pre-inc (pos-pre-inc pos) pos)) + 'feature-profile:generic-sequence #t)]) + #,(syntax-property + (syntax/loc #'rhs (if val-cont? (val-cont? id ...) #t)) + 'feature-profile:generic-sequence #t) + #,(syntax-property + (syntax/loc #'rhs (if all-cont?/pos (all-cont?/pos pos) #t)) + 'feature-profile:generic-sequence #t) + #,(syntax-property + (syntax/loc #'rhs ((pos-next pos))) + 'feature-profile:generic-sequence #t)))) + (make-rearm)))))] [_ (raise-syntax-error #f "bad sequence binding clause" orig-stx clause)])))) @@ -509,7 +521,13 @@ (define (make-sequence who v) (cond [(exact-nonnegative-integer? v) (:integer-gen v)] - [(do-sequence? v) ((do-sequence-ref v 0))] + [(do-sequence? v) + (call-with-values (lambda () ((do-sequence-ref v 0))) + (case-lambda + [(pos->vals pos-next init pos-cont? val-cont? all-cont?) + (values pos->vals #f pos-next init pos-cont? val-cont? all-cont?)] + [(pos->vals pre-pos-next pos-next init pos-cont? val-cont? all-cont?) + (values pos->vals pre-pos-next pos-next init pos-cont? val-cont? all-cont?)]))] [(mpair? v) (:mlist-gen v)] [(list? v) (:list-gen v)] [(vector? v) (:vector-gen v 0 (vector-length v) 1)] @@ -554,6 +572,7 @@ (lambda (v) (values values + #f (range-ref v 1) (range-ref v 0) (range-ref v 2) @@ -575,7 +594,7 @@ (make-range a inc cont?))])) (define (:integer-gen v) - (values values add1 0 (lambda (i) (i . < . v)) #f #f)) + (values values #f add1 0 (lambda (i) (i . < . v)) #f #f)) (define in-naturals (case-lambda @@ -605,6 +624,7 @@ (values car cdr + values (list-stream-ref v 0) pair? #f @@ -615,14 +635,14 @@ (make-list-stream l)) (define (:list-gen l) - (values car cdr l pair? #f #f)) + (values car cdr values l pair? #f #f)) (define (in-mlist l) (unless (mpair? l) (raise-argument-error 'in-mlist "mpair?" l)) (make-do-sequence (lambda () (:mlist-gen l)))) (define (:mlist-gen l) - (values mcar mcdr l mpair? #f #f)) + (values mcar #f mcdr l mpair? #f #f)) (define (in-input-port-bytes p) (unless (input-port? p) @@ -630,7 +650,7 @@ (make-do-sequence (lambda () (:input-port-gen p)))) (define (:input-port-gen p) - (values read-byte values p #f + (values read-byte #f values p #f (lambda (x) (not (eof-object? x))) #f)) @@ -690,7 +710,7 @@ (define (:stream-gen l) (values - unsafe-stream-first unsafe-stream-rest l unsafe-stream-not-empty? #f #f)) + unsafe-stream-first unsafe-stream-rest values l unsafe-stream-not-empty? #f #f)) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -700,6 +720,7 @@ ;; assembles hash iterator functions to give to make-do-sequence (define (:hash-gen ht -get -first -next) (values (lambda (pos) (-get ht pos)) + #f (lambda (pos) (-next ht pos)) (-first ht) (lambda (pos) pos) ; #f position means stop @@ -857,6 +878,8 @@ (values ;; pos->element (lambda (i) (unsafe-vector-ref-id v i)) + ;; pre-pos-inc + #f ;; next-pos ;; Minor optimisation. I assume add1 is faster than \x.x+1 (if (= step 1) add1 (lambda (i) (+ i step))) @@ -1008,9 +1031,10 @@ (procedure-arity-includes? pred 1)) (raise-argument-error 'stop-before "(procedure-arity-includes/c 1)" pred)) (make-do-sequence (lambda () - (let-values ([(pos->val pos-next init pos-cont? pre-cont? post-cont?) + (let-values ([(pos->val pre-pos-next pos-next init pos-cont? pre-cont? post-cont?) (make-sequence #f g)]) (values pos->val + pre-pos-next pos-next init pos-cont? @@ -1027,9 +1051,10 @@ (procedure-arity-includes? pred 1)) (raise-argument-error 'stop-after "(procedure-arity-includes/c 1)" pred)) (make-do-sequence (lambda () - (let-values ([(pos->val pos-next init pos-cont? pre-cont? post-cont?) + (let-values ([(pos->val pre-pos-next pos-next init pos-cont? pre-cont? post-cont?) (make-sequence #f g)]) (values pos->val + pre-pos-next pos-next init pos-cont? @@ -1043,9 +1068,11 @@ (define (in-indexed g) (unless (sequence? g) (raise-argument-error 'in-indexed "sequence?" g)) (make-do-sequence (lambda () - (let-values ([(pos->val pos-next init pos-cont? pre-cont? post-cont?) + (let-values ([(pos->val pre-pos-next pos-next init pos-cont? pre-cont? post-cont?) (make-sequence #f g)]) (values (lambda (pos) (values (pos->val (car pos)) (cdr pos))) + (and pre-pos-next + (lambda (pos) (cons (pre-pos-next (car pos)) (cdr pos)))) (lambda (pos) (cons (pos-next (car pos)) (add1 (cdr pos)))) (cons init 0) (and pos-cont? @@ -1061,16 +1088,17 @@ (lambda (pos) #f) #t (lambda (pos) pos) - void - void)))) + #f + #f)))) (define (in-values-sequence g) (unless (sequence? g) (raise-argument-error 'in-values-sequence "sequence?" g)) (make-do-sequence (lambda () - (let-values ([(pos->val pos-next init pos-cont? pre-cont? post-cont?) + (let-values ([(pos->val pre-pos-next pos-next init pos-cont? pre-cont? post-cont?) (make-sequence #f g)]) (values (lambda (pos) (call-with-values (lambda () (pos->val pos)) list)) + pre-pos-next pos-next init pos-cont? @@ -1082,12 +1110,13 @@ (define (in-values*-sequence g) (unless (sequence? g) (raise-argument-error 'in-values-sequence "sequence?" g)) (make-do-sequence (lambda () - (let-values ([(pos->val pos-next init pos-cont? pre-cont? post-cont?) + (let-values ([(pos->val pre-pos-next pos-next init pos-cont? pre-cont? post-cont?) (make-sequence #f g)]) (values (lambda (pos) (call-with-values (lambda () (pos->val pos)) (case-lambda [(v) (if (list? v) (list v) v)] [vs vs]))) + pre-pos-next pos-next init pos-cont? @@ -1121,8 +1150,8 @@ m+g+r)) (seqs->m+g+r sequences) values - void - void)))) + #f + #f)))) (define (check-sequences who sequences) (for-each (lambda (g) @@ -1144,16 +1173,20 @@ (car sequences) (make-do-sequence (lambda () - (let-values ([(pos->vals pos-nexts inits pos-cont?s pre-cont?s post-cont?s) - (for/lists (p->v p-s i ps? pr? po?) ([g sequences]) + (let-values ([(pos->vals pre-pos-nexts pos-nexts inits pos-cont?s pre-cont?s post-cont?s) + (for/lists (p->v p-p-n p-n i ps? pr? po?) ([g sequences]) (make-sequence #f g))]) (values (lambda (poses) (apply values (map (lambda (pos->val pos) (pos->val pos)) - pos->vals - poses))) + pos->vals + poses))) + (and (ormap values pre-pos-nexts) + (lambda (poses) (map (lambda (pre-pos-next pos) (if pre-pos-next (pre-pos-next pos) pos)) + pre-pos-nexts + poses))) (lambda (poses) (map (lambda (pos-next pos) (pos-next pos)) - pos-nexts - poses)) + pos-nexts + poses)) inits (and (ormap values pos-cont?s) (lambda (poses) (andmap (lambda (pos-cont? pos) @@ -1216,7 +1249,7 @@ (cond [(stream? s) s] [else - (let-values ([(pos->val pos-next init pos-cont? pre-cont? post-cont?) + (let-values ([(pos->val pre-pos-next pos-next init pos-cont? pre-cont? post-cont?) (make-sequence #f s)]) (define (gen-stream pos) (let ([done? #f] @@ -1228,6 +1261,7 @@ (if (if pos-cont? (pos-cont? pos) #t) (begin (set! vals (call-with-values (lambda () (pos->val pos)) list)) + (when pre-pos-next (set! pos (pre-pos-next pos))) (unless (if pre-cont? (apply pre-cont? vals) #t) (set! vals #f) (set! empty? #t))) @@ -1253,7 +1287,7 @@ (define (sequence-generate g) (unless (sequence? g) (raise-argument-error 'sequence-generate "sequence?" g)) - (let-values ([(pos->val pos-next init pos-cont? pre-cont? post-cont?) + (let-values ([(pos->val pre-pos-next pos-next init pos-cont? pre-cont? post-cont?) (make-sequence #f g)]) (let ([pos init]) (letrec ([more? #f] @@ -1267,7 +1301,11 @@ (lambda () (if (if pos-cont? (pos-cont? pos) #t) (call-with-values - (lambda () (pos->val pos)) + (lambda () + (begin0 + (pos->val pos) + (when pre-pos-next + (set! pos (pre-pos-next pos))))) (lambda vals (if (if pre-cont? (apply pre-cont? vals) #t) (begin @@ -1309,13 +1347,16 @@ (define (sequence-generate* g) (unless (sequence? g) (raise-argument-error 'sequence-generate* "sequence?" g)) - (let-values ([(pos->val pos-next init pos-cont? pre-cont? post-cont?) + (let-values ([(pos->val pre-pos-next pos-next init pos-cont? pre-cont? post-cont?) (make-sequence #f g)]) (letrec ([next! (lambda (pos) (if (if pos-cont? (pos-cont? pos) #t) (call-with-values - (lambda () (pos->val pos)) + (lambda () (begin0 + (pos->val pos) + (when pre-pos-next + (set! pos (pre-pos-next pos))))) (lambda vals (if (if pre-cont? (apply pre-cont? vals) #t) (values vals @@ -1891,13 +1932,14 @@ ;; pos check (pair? lst) ;; inner bindings - ([(id) (unsafe-car lst)]) + ([(id) (unsafe-car lst)] + [(rest) (unsafe-cdr lst)]) ; so `lst` is not necessarily retained during body ;; pre guard #t ;; post guard #t ;; loop args - ((unsafe-cdr lst)))])] + (rest))])] [_ #f]))) (define-sequence-syntax *in-mlist @@ -1944,13 +1986,14 @@ ;; pos check (unsafe-stream-not-empty? lst) ;; inner bindings - ([(id) (unsafe-stream-first lst)]) + ([(id) (unsafe-stream-first lst)] + [(rest) (unsafe-stream-rest lst)]) ; so `lst` is not necessarily retained during body ;; pre guard #t ;; post guard #t ;; loop args - ((unsafe-stream-rest lst)))])] + (rest))])] [_ #f]))) (define-sequence-syntax *in-indexed diff --git a/racket/collects/racket/private/map.rkt b/racket/collects/racket/private/map.rkt index 01bc6a79bf..459711167d 100644 --- a/racket/collects/racket/private/map.rkt +++ b/racket/collects/racket/private/map.rkt @@ -25,7 +25,9 @@ (let loop ([l l]) (cond [(null? l) null] - [else (cons (f (car l)) (loop (cdr l)))])) + [else + (let ([r (cdr l)]) ; so `l` is not necessarily retained during `f` + (cons (f (car l)) (loop r)))])) (map f l))] [(f l1 l2) (if (and (procedure? f) @@ -33,11 +35,14 @@ (list? l1) (list? l2) (= (length l1) (length l2))) - (let loop ([l1 l1][l2 l2]) + (let loop ([l1 l1] [l2 l2]) (cond [(null? l1) null] - [else (cons (f (car l1) (car l2)) - (loop (cdr l1) (cdr l2)))])) + [else + (let ([r1 (cdr l1)] + [r2 (cdr l2)]) + (cons (f (car l1) (car l2)) + (loop r1 r2)))])) (map f l1 l2))] [(f l . args) (apply map f l args)])]) map)) @@ -52,7 +57,9 @@ (let loop ([l l]) (cond [(null? l) (void)] - [else (begin (f (car l)) (loop (cdr l)))])) + [else + (let ([r (cdr l)]) + (begin (f (car l)) (loop r)))])) (for-each f l))] [(f l1 l2) (if (and (procedure? f) @@ -60,11 +67,14 @@ (list? l1) (list? l2) (= (length l1) (length l2))) - (let loop ([l1 l1][l2 l2]) + (let loop ([l1 l1] [l2 l2]) (cond [(null? l1) (void)] - [else (begin (f (car l1) (car l2)) - (loop (cdr l1) (cdr l2)))])) + [else + (let ([r1 (cdr l1)] + [r2 (cdr l2)]) + (begin (f (car l1) (car l2)) + (loop r1 r2)))])) (for-each f l1 l2))] [(f l . args) (apply for-each f l args)])]) for-each)) @@ -81,7 +91,10 @@ (let loop ([l l]) (cond [(null? (cdr l)) (f (car l))] - [else (and (f (car l)) (loop (cdr l)))]))) + [else + (let ([r (cdr l)]) + (and (f (car l)) + (loop r)))]))) (andmap f l))] [(f l1 l2) (if (and (procedure? f) @@ -91,11 +104,14 @@ (= (length l1) (length l2))) (if (null? l1) #t - (let loop ([l1 l1][l2 l2]) + (let loop ([l1 l1] [l2 l2]) (cond [(null? (cdr l1)) (f (car l1) (car l2))] - [else (and (f (car l1) (car l2)) - (loop (cdr l1) (cdr l2)))]))) + [else + (let ([r1 (cdr l1)] + [r2 (cdr l2)]) + (and (f (car l1) (car l2)) + (loop r1 r2)))]))) (andmap f l1 l2))] [(f l . args) (apply andmap f l args)])]) andmap)) @@ -112,7 +128,9 @@ (let loop ([l l]) (cond [(null? (cdr l)) (f (car l))] - [else (or (f (car l)) (loop (cdr l)))]))) + [else + (let ([r (cdr l)]) + (or (f (car l)) (loop r)))]))) (ormap f l))] [(f l1 l2) (if (and (procedure? f) @@ -122,11 +140,14 @@ (= (length l1) (length l2))) (if (null? l1) #f - (let loop ([l1 l1][l2 l2]) + (let loop ([l1 l1] [l2 l2]) (cond [(null? (cdr l1)) (f (car l1) (car l2))] - [else (or (f (car l1) (car l2)) - (loop (cdr l1) (cdr l2)))]))) + [else + (let ([r1 (cdr l1)] + [r2 (cdr l2)]) + (or (f (car l1) (car l2)) + (loop r1 r2)))]))) (ormap f l1 l2))] [(f l . args) (apply ormap f l args)])]) ormap)))) diff --git a/racket/src/racket/src/eval.c b/racket/src/racket/src/eval.c index c9c8345dff..bf906bc752 100644 --- a/racket/src/racket/src/eval.c +++ b/racket/src/racket/src/eval.c @@ -2654,6 +2654,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands, Scheme_Type type; Scheme_Object *v; GC_CAN_IGNORE Scheme_Object *tmpv; /* safe-for-space relies on GC_CAN_IGNORE */ + GC_CAN_IGNORE Scheme_Object **tmprands; /* safe-for-space relies on GC_CAN_IGNORE */ GC_MAYBE_IGNORE_INTERIOR Scheme_Object **old_runstack; GC_MAYBE_IGNORE_INTERIOR MZ_MARK_STACK_TYPE old_cont_mark_stack; #if USE_LOCAL_RUNSTACK @@ -2788,8 +2789,9 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands, } f = prim->prim_val; - - v = f(num_rands, rands, (Scheme_Object *)prim); + tmprands = rands; + rands = NULL; /* safe for space, since tmprands is ignored by the GC */ + v = f(num_rands, tmprands, (Scheme_Object *)prim); DEBUG_CHECK_TYPE(v); } else if (type == scheme_closure_type) { @@ -3043,8 +3045,11 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands, } tmpv = obj; - obj = NULL; /* save for space, since tmpv is ignored by the GC */ - v = data->start_code(tmpv, num_rands, rands EXTRA_NATIVE_ARGUMENT); + obj = NULL; /* safe for space, since tmpv is ignored by the GC */ + tmprands = rands; + if (rands != old_runstack) + rands = NULL; /* safe for space, since tmprands is ignored by the GC */ + v = data->start_code(tmpv, num_rands, tmprands EXTRA_NATIVE_ARGUMENT); if (v == SCHEME_TAIL_CALL_WAITING) { /* [TC-SFS]; see schnapp.inc */ @@ -3150,7 +3155,9 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands, /* Chaperone is for function arguments */ VACATE_TAIL_BUFFER_USE_RUNSTACK(); UPDATE_THREAD_RSPTR(); - v = scheme_apply_chaperone(scheme_make_raw_pair(obj, orig_obj), num_rands, rands, NULL, 0); + tmprands = rands; + rands = NULL; /* safe for space, since tmprands is ignored by the GC */ + v = scheme_apply_chaperone(scheme_make_raw_pair(obj, orig_obj), num_rands, tmprands, NULL, 0); if (SAME_OBJ(v, SCHEME_TAIL_CALL_WAITING)) { /* Need to stay in this loop, because a tail-call result must @@ -3179,7 +3186,9 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands, /* Chaperone is for function arguments */ VACATE_TAIL_BUFFER_USE_RUNSTACK(); UPDATE_THREAD_RSPTR(); - v = scheme_apply_chaperone(obj, num_rands, rands, NULL, 0); + tmprands = rands; + rands = NULL; /* safe for space, since tmprands is ignored by the GC */ + v = scheme_apply_chaperone(obj, num_rands, tmprands, NULL, 0); } } else if (type == scheme_closed_prim_type) { GC_CAN_IGNORE Scheme_Closed_Primitive_Proc *prim; @@ -3199,8 +3208,11 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands, 0); return NULL; /* Shouldn't get here */ } - - v = prim->prim_val(prim->data, num_rands, rands); + + tmprands = rands; + if (rands != old_runstack) + rands = NULL; /* safe for space, since tmprands is ignored by the GC */ + v = prim->prim_val(prim->data, num_rands, tmprands); if (v == SCHEME_TAIL_CALL_WAITING) { /* [TC-SFS]; see schnapp.inc */ diff --git a/racket/src/racket/src/optimize.c b/racket/src/racket/src/optimize.c index a115767e8b..8a9bb686fa 100644 --- a/racket/src/racket/src/optimize.c +++ b/racket/src/racket/src/optimize.c @@ -2097,8 +2097,9 @@ static int movable_expression(Scheme_Object *expr, Optimize_Info *info, { Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)expr; if (movable_expression(b->test, info, cross_lambda, cross_k, cross_s, check_space, fuel-1) - && movable_expression(b->tbranch, info, cross_lambda, cross_k, cross_s, check_space, fuel-1) - && movable_expression(b->fbranch, info, cross_lambda, cross_k, cross_s, check_space, fuel-1)) + /* Check space for branches if cross_s, because evaluating `if` eliminates one of them */ + && movable_expression(b->tbranch, info, cross_lambda, cross_k, cross_s, check_space || cross_s, fuel-1) + && movable_expression(b->fbranch, info, cross_lambda, cross_k, cross_s, check_space || cross_s, fuel-1)) return 1; } break; diff --git a/racket/src/racket/src/schmap.inc b/racket/src/racket/src/schmap.inc index cd4d182bb2..1172f0c1a1 100644 --- a/racket/src/racket/src/schmap.inc +++ b/racket/src/racket/src/schmap.inc @@ -15,7 +15,7 @@ DO_MAP(int argc, Scheme_Object *argv[]) { # define NUM_QUICK_ARGS 3 # define NUM_QUICK_RES 5 - int i, size = 0, l, pos; + int i, size = 0, l, pos, pop_runstack = 0; Scheme_Object *quick1[NUM_QUICK_ARGS], *quick2[NUM_QUICK_ARGS]; Scheme_Object **working, **args; # ifdef MAP_MODE @@ -24,6 +24,7 @@ DO_MAP(int argc, Scheme_Object *argv[]) # ifndef FOR_EACH_MODE Scheme_Object *v; # endif + Scheme_Object *proc; int cc; if (!SCHEME_PROCP(argv[0])) @@ -62,11 +63,25 @@ DO_MAP(int argc, Scheme_Object *argv[]) return NULL; } - if (argc <= (NUM_QUICK_ARGS + 1)) { + if (argv == MZ_RUNSTACK) { + /* Reusing the runstack has good safe-for-space + properties, where a called function will clear + arguments after they become unused when the arguments + are on the runstack */ + args = MZ_RUNSTACK; + } else if (MZ_RUNSTACK - (argc - 1) >= (MZ_RUNSTACK_START + SCHEME_TAIL_COPY_THRESHOLD)) { + MZ_RUNSTACK -= (argc - 1); + pop_runstack = 1; + args = MZ_RUNSTACK; + } else if (argc <= (NUM_QUICK_ARGS + 1)) { args = quick1; - working = quick2; } else { args = MALLOC_N(Scheme_Object *, argc - 1); + } + + if (argc <= (NUM_QUICK_ARGS + 1)) { + working = quick2; + } else { working = MALLOC_N(Scheme_Object *, argc - 1); } @@ -80,9 +95,17 @@ DO_MAP(int argc, Scheme_Object *argv[]) /* Copy argc into working array */ for (i = 1; i < argc; i++) { working[i-1] = argv[i]; + if (argv == MZ_RUNSTACK) { + /* space safety */ + argv[i] = NULL; + } } --argc; + proc = argv[0]; + if (argv == MZ_RUNSTACK) + argv[0] = NULL; + argv = NULL; pos = 0; while (pos < size) { @@ -99,21 +122,26 @@ DO_MAP(int argc, Scheme_Object *argv[]) } #endif args[i] = SCHEME_CAR(working[i]); + /* space safety: we'll take the `cdr` of each list + in `working` before calling `proc` */ working[i] = SCHEME_CDR(working[i]); } cc = scheme_cont_capture_count; #ifdef MAP_MODE - v = _scheme_apply(argv[0], argc, args); + v = _scheme_apply(proc, argc, args); #else # ifdef FOR_EACH_MODE - _scheme_apply_multi(argv[0], argc, args); + _scheme_apply_multi(proc, argc, args); # else if (pos + 1 == size) { - return _scheme_tail_apply(argv[0], argc, args); + v = _scheme_tail_apply(proc, argc, args); + if (pop_runstack) + MZ_RUNSTACK += argc; + return v; } else { - v = _scheme_apply(argv[0], argc, args); + v = _scheme_apply(proc, argc, args); } # endif #endif @@ -141,16 +169,25 @@ DO_MAP(int argc, Scheme_Object *argv[]) resarray[pos] = v; #endif #ifdef AND_MODE - if (SCHEME_FALSEP(v)) + if (SCHEME_FALSEP(v)) { + if (pop_runstack) + MZ_RUNSTACK += argc; return scheme_false; + } #endif #ifdef OR_MODE - if (SCHEME_TRUEP(v)) + if (SCHEME_TRUEP(v)) { + if (pop_runstack) + MZ_RUNSTACK += argc; return v; + } #endif pos++; } + if (pop_runstack) + MZ_RUNSTACK += argc; + #ifdef MAP_MODE return scheme_build_list(size, resarray); #endif diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index 6ba0ccdd72..fff5aa31f5 100644 --- a/racket/src/racket/src/schvers.h +++ b/racket/src/racket/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "6.7.0.3" +#define MZSCHEME_VERSION "6.7.0.4" #define MZSCHEME_VERSION_X 6 #define MZSCHEME_VERSION_Y 7 #define MZSCHEME_VERSION_Z 0 -#define MZSCHEME_VERSION_W 3 +#define MZSCHEME_VERSION_W 4 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)