suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

adjust map and for ... in-list to not retain their lists

Browse Source 
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).
This commit is contained in:
Matthew Flatt 2016-12-12 19:23:54 -07:00
parent 5e94a906cd
commit d7b18e7a9c
11 changed files with 346 additions and 115 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -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]))

13
pkgs/racket-doc/scribblings/reference/for.scrbl
View File

@ -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

72
pkgs/racket-doc/scribblings/reference/sequences.scrbl
View File

@ -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.

62
pkgs/racket-test-core/tests/racket/for.rktl
View File

@ -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)

16
pkgs/racket-test-core/tests/racket/optimize.rktl
View File

@ -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)))

151
racket/collects/racket/private/for.rkt
View File

@ -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

53
racket/collects/racket/private/map.rkt
View File

@ -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))))

28
racket/src/racket/src/eval.c
View File

@ -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 */

5
racket/src/racket/src/optimize.c
View File

@ -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;

55
racket/src/racket/src/schmap.inc
View File

@ -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

4
racket/src/racket/src/schvers.h
View File

@ -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)