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

Merge branch 'noncm' of github.com:mflatt/ChezScheme

Browse Source 
original commit: b99995a8d38565cbedfbe46ab8a6006ee936b331
This commit is contained in:
Matthew Flatt 2018-12-30 08:18:13 -07:00
commit f6b40d39ba
6 changed files with 155 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
LOG
View File

@ -1047,3 +1047,6 @@
Mf-base, misc.ms, system.stex, release_notes.stex Mf-base, misc.ms, system.stex, release_notes.stex
- avoid fasl overflow of C stack - avoid fasl overflow of C stack
fasl.ss, compile.ss, cmacros.ss, fasl.c, 6.ms fasl.ss, compile.ss, cmacros.ss, fasl.c, 6.ms
- adjust cp0 to avoid turning errors like `(let ([x (values 1 2)]) x)`
into programs that return multiple values
cp0.ss, primdata.ss, cmacros.ss, syntax.ss, cp0.ms

102
mats/cp0.ms
View File

@ -1984,13 +1984,13 @@
((begin (#%write 'b) #%car) ((begin (#%write 'b) #%car)
(begin (#%write 'c) (begin (#%write 'c)
((begin (#%write 'd) #%cons) ((begin (#%write 'd) #%cons)
(begin (#%write 'e) ($xxx)) (begin (#%write 'e) (add1 ($xxx)))
(begin (#%write 'f) ($yyy)))))))) (begin (#%write 'f) ($yyy))))))))
; other possibilities exist but are too many to list and too difficult to construct with $permutations. ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
; if you see a problem, convert to use $check-writes (defined above) ; if you see a problem, convert to use $check-writes (defined above)
(if (= (optimize-level) 3) (if (= (optimize-level) 3)
'(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'f) ($yyy) (#3%write 'e) ($xxx)) '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'f) ($yyy) (#3%write 'e) (#3%add1 ($xxx)))
'(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'f) ($yyy) (#2%write 'e) ($xxx)))) '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'f) ($yyy) (#2%write 'e) (#2%add1 ($xxx)))))
(equivalent-expansion? (equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f]) (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize (expand/optimize
@ -1998,14 +1998,14 @@
((begin (#%write 'b) #%car) ((begin (#%write 'b) #%car)
(begin (#%write 'c) (begin (#%write 'c)
((begin (#%write 'd) #%list) ((begin (#%write 'd) #%list)
(begin (#%write 'e) ($xxx)) (begin (#%write 'e) (add1 ($xxx)))
(begin (#%write 'f) ($yyy)) (begin (#%write 'f) ($yyy))
(begin (#%write 'g) ($zzz)))))))) (begin (#%write 'g) ($zzz))))))))
; other possibilities exist but are too many to list and too difficult to construct with $permutations. ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
; if you see a problem, convert to use $check-writes (defined above) ; if you see a problem, convert to use $check-writes (defined above)
(if (= (optimize-level) 3) (if (= (optimize-level) 3)
'(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'f) ($yyy) (#3%write 'g) ($zzz) (#3%write 'e) ($xxx)) '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'f) ($yyy) (#3%write 'g) ($zzz) (#3%write 'e) (#3%add1 ($xxx)))
'(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'f) ($yyy) (#2%write 'g) ($zzz) (#2%write 'e) ($xxx)))) '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'f) ($yyy) (#2%write 'g) ($zzz) (#2%write 'e) (#2%add1 ($xxx)))))
(equivalent-expansion? (equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f]) (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize (expand/optimize
@ -2013,14 +2013,14 @@
((begin (#%write 'b) #%car) ((begin (#%write 'b) #%car)
(begin (#%write 'c) (begin (#%write 'c)
((begin (#%write 'd) #%list*) ((begin (#%write 'd) #%list*)
(begin (#%write 'e) ($xxx)) (begin (#%write 'e) (add1 ($xxx)))
(begin (#%write 'f) ($yyy)) (begin (#%write 'f) ($yyy))
(begin (#%write 'g) ($zzz)))))))) (begin (#%write 'g) ($zzz))))))))
; other possibilities exist but are too many to list and too difficult to construct with $permutations. ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
; if you see a problem, convert to use $check-writes (defined above) ; if you see a problem, convert to use $check-writes (defined above)
(if (= (optimize-level) 3) (if (= (optimize-level) 3)
'(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'f) ($yyy) (#3%write 'g) ($zzz) (#3%write 'e) ($xxx)) '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'f) ($yyy) (#3%write 'g) ($zzz) (#3%write 'e) (#3%add1 ($xxx)))
'(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'f) ($yyy) (#2%write 'g) ($zzz) (#2%write 'e) ($xxx)))) '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'f) ($yyy) (#2%write 'g) ($zzz) (#2%write 'e) (#2%add1 ($xxx)))))
(equivalent-expansion? (equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f]) (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize (expand/optimize
@ -2028,14 +2028,14 @@
((begin (#%write 'b) #%car) ((begin (#%write 'b) #%car)
(begin (#%write 'c) (begin (#%write 'c)
((begin (#%write 'd) #%cons*) ((begin (#%write 'd) #%cons*)
(begin (#%write 'e) ($xxx)) (begin (#%write 'e) (add1 ($xxx)))
(begin (#%write 'f) ($yyy)) (begin (#%write 'f) ($yyy))
(begin (#%write 'g) ($zzz)))))))) (begin (#%write 'g) ($zzz))))))))
; other possibilities exist but are too many to list and too difficult to construct with $permutations. ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
; if you see a problem, convert to use $check-writes (defined above) ; if you see a problem, convert to use $check-writes (defined above)
(if (= (optimize-level) 3) (if (= (optimize-level) 3)
'(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'f) ($yyy) (#3%write 'g) ($zzz) (#3%write 'e) ($xxx)) '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'f) ($yyy) (#3%write 'g) ($zzz) (#3%write 'e) (#3%add1 ($xxx)))
'(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'f) ($yyy) (#2%write 'g) ($zzz) (#2%write 'e) ($xxx)))) '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'f) ($yyy) (#2%write 'g) ($zzz) (#2%write 'e) (#2%add1 ($xxx)))))
(equivalent-expansion? (equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f]) (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize (expand/optimize
@ -2044,12 +2044,12 @@
(begin (#%write 'c) (begin (#%write 'c)
((begin (#%write 'd) #%cons) ((begin (#%write 'd) #%cons)
(begin (#%write 'e) ($xxx)) (begin (#%write 'e) ($xxx))
(begin (#%write 'f) ($yyy)))))))) (begin (#%write 'f) (add1 ($yyy)))))))))
; other possibilities exist but are too many to list and too difficult to construct with $permutations. ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
; if you see a problem, convert to use $check-writes (defined above) ; if you see a problem, convert to use $check-writes (defined above)
(if (= (optimize-level) 3) (if (= (optimize-level) 3)
'(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'f) ($yyy)) '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'f) (#3%add1 ($yyy)))
'(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'f) ($yyy)))) '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'f) (#2%add1 ($yyy)))))
(equivalent-expansion? (equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f]) (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize (expand/optimize
@ -2103,12 +2103,12 @@
(begin (#%write 'c) (begin (#%write 'c)
((begin (#%write 'd) #%list*) ((begin (#%write 'd) #%list*)
(begin (#%write 'e) ($xxx)) (begin (#%write 'e) ($xxx))
(begin (#%write 'f) ($yyy)))))))) (begin (#%write 'f) (add1 ($yyy)))))))))
; other possibilities exist but are too many to list and too difficult to construct with $permutations. ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
; if you see a problem, convert to use $check-writes (defined above) ; if you see a problem, convert to use $check-writes (defined above)
(if (= (optimize-level) 3) (if (= (optimize-level) 3)
'(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'f) ($yyy)) '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'f) (#3%add1 ($yyy)))
'(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'f) ($yyy)))) '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'f) (#2%add1 ($yyy)))))
(equivalent-expansion? (equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f]) (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize (expand/optimize
@ -2117,12 +2117,12 @@
(begin (#%write 'c) (begin (#%write 'c)
((begin (#%write 'd) #%cons*) ((begin (#%write 'd) #%cons*)
(begin (#%write 'e) ($xxx)) (begin (#%write 'e) ($xxx))
(begin (#%write 'f) ($yyy)))))))) (begin (#%write 'f) (add1 ($yyy)))))))))
; other possibilities exist but are too many to list and too difficult to construct with $permutations. ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
; if you see a problem, convert to use $check-writes (defined above) ; if you see a problem, convert to use $check-writes (defined above)
(if (= (optimize-level) 3) (if (= (optimize-level) 3)
'(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'f) ($yyy)) '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'f) (#3%add1 ($yyy)))
'(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'f) ($yyy)))) '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'f) (#2%add1 ($yyy)))))
(equivalent-expansion? (equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f]) (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize (expand/optimize
@ -2190,14 +2190,14 @@
(begin (write 'c) (begin (write 'c)
((begin (write 'd) vector) ((begin (write 'd) vector)
(begin (write 'e) ($xxx)) (begin (write 'e) ($xxx))
(begin (write 'f) ($yyy)) (begin (write 'f) (add1 ($yyy)))
(begin (write 'g) ($zzz)))) (begin (write 'g) ($zzz))))
(begin (write 'h) 1))))) (begin (write 'h) 1)))))
; other possibilities exist but are too many to list and too difficult to construct with $permutations. ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
; if you see a problem, convert to use $check-writes (defined above) ; if you see a problem, convert to use $check-writes (defined above)
(if (= (optimize-level) 3) (if (= (optimize-level) 3)
'(begin (#3%write 'a) (#3%write 'b) (#3%write 'h) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'g) ($zzz) (#3%write 'f) ($yyy)) '(begin (#3%write 'a) (#3%write 'b) (#3%write 'h) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'g) ($zzz) (#3%write 'f) (#3%add1 ($yyy)))
'(begin (#2%write 'a) (#2%write 'b) (#2%write 'h) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'g) ($zzz) (#2%write 'f) ($yyy)))) '(begin (#2%write 'a) (#2%write 'b) (#2%write 'h) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'g) ($zzz) (#2%write 'f) (#2%add1 ($yyy)))))
(equivalent-expansion? (equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)]) (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)])
(expand/optimize (expand/optimize
@ -2244,14 +2244,14 @@
(begin (write 'c) (begin (write 'c)
((begin (write 'd) list) ((begin (write 'd) list)
(begin (write 'e) ($xxx)) (begin (write 'e) ($xxx))
(begin (write 'f) ($yyy)) (begin (write 'f) (add1 ($yyy)))
(begin (write 'g) ($zzz)))) (begin (write 'g) ($zzz))))
(begin (write 'h) 1))))) (begin (write 'h) 1)))))
; other possibilities exist but are too many to list and too difficult to construct with $permutations. ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
; if you see a problem, convert to use $check-writes (defined above) ; if you see a problem, convert to use $check-writes (defined above)
(if (= (optimize-level) 3) (if (= (optimize-level) 3)
'(begin (#3%write 'a) (#3%write 'b) (#3%write 'h) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'g) ($zzz) (#3%write 'f) ($yyy)) '(begin (#3%write 'a) (#3%write 'b) (#3%write 'h) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'g) ($zzz) (#3%write 'f) (#3%add1 ($yyy)))
'(begin (#2%write 'a) (#2%write 'b) (#2%write 'h) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'g) ($zzz) (#2%write 'f) ($yyy)))) '(begin (#2%write 'a) (#2%write 'b) (#2%write 'h) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'g) ($zzz) (#2%write 'f) (#2%add1 ($yyy)))))
(equivalent-expansion? (equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)]) (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)])
(expand/optimize (expand/optimize
@ -2260,14 +2260,14 @@
(begin (write 'c) (begin (write 'c)
((begin (write 'd) list*) ((begin (write 'd) list*)
(begin (write 'e) ($xxx)) (begin (write 'e) ($xxx))
(begin (write 'f) ($yyy)) (begin (write 'f) (add1 ($yyy)))
(begin (write 'g) ($zzz)))) (begin (write 'g) ($zzz))))
(begin (write 'h) 1))))) (begin (write 'h) 1)))))
; other possibilities exist but are too many to list and too difficult to construct with $permutations. ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
; if you see a problem, convert to use $check-writes (defined above) ; if you see a problem, convert to use $check-writes (defined above)
(if (= (optimize-level) 3) (if (= (optimize-level) 3)
'(begin (#3%write 'a) (#3%write 'b) (#3%write 'h) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'g) ($zzz) (#3%write 'f) ($yyy)) '(begin (#3%write 'a) (#3%write 'b) (#3%write 'h) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'g) ($zzz) (#3%write 'f) (#3%add1 ($yyy)))
'(begin (#2%write 'a) (#2%write 'b) (#2%write 'h) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'g) ($zzz) (#2%write 'f) ($yyy)))) '(begin (#2%write 'a) (#2%write 'b) (#2%write 'h) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'g) ($zzz) (#2%write 'f) (#2%add1 ($yyy)))))
(equivalent-expansion? (equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)]) (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)])
(expand/optimize (expand/optimize
@ -2276,14 +2276,14 @@
(begin (write 'c) (begin (write 'c)
((begin (write 'd) cons*) ((begin (write 'd) cons*)
(begin (write 'e) ($xxx)) (begin (write 'e) ($xxx))
(begin (write 'f) ($yyy)) (begin (write 'f) (add1 ($yyy)))
(begin (write 'g) ($zzz)))) (begin (write 'g) ($zzz))))
(begin (write 'h) 1))))) (begin (write 'h) 1)))))
; other possibilities exist but are too many to list and too difficult to construct with $permutations. ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
; if you see a problem, convert to use $check-writes (defined above) ; if you see a problem, convert to use $check-writes (defined above)
(if (= (optimize-level) 3) (if (= (optimize-level) 3)
'(begin (#3%write 'a) (#3%write 'b) (#3%write 'h) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'g) ($zzz) (#3%write 'f) ($yyy)) '(begin (#3%write 'a) (#3%write 'b) (#3%write 'h) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'g) ($zzz) (#3%write 'f) (#3%add1 ($yyy)))
'(begin (#2%write 'a) (#2%write 'b) (#2%write 'h) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'g) ($zzz) (#2%write 'f) ($yyy)))) '(begin (#2%write 'a) (#2%write 'b) (#2%write 'h) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'g) ($zzz) (#2%write 'f) (#2%add1 ($yyy)))))
(equivalent-expansion? (equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)]) (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)])
(expand/optimize (expand/optimize
@ -2828,3 +2828,39 @@
`(lambda (x) (= x x))) ; x could be +nan.0 `(lambda (x) (= x x))) ; x could be +nan.0
`(lambda (x) (($primitive ,(if (fx= (optimize-level) 3) 3 2) =) x x)))) `(lambda (x) (($primitive ,(if (fx= (optimize-level) 3) 3 2) =) x x))))
) )
(mat cp0-non-tail
;; Make sure that an expression that might return multiple values is
;; not moved out of a position that expects a single result.
(begin
(define (simplify-only-nontail? mk)
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(and
(equivalent-expansion?
(expand/optimize `(lambda (g) ,(mk `g)))
'(lambda (g) g))
(not (equivalent-expansion?
(expand/optimize `(lambda (g) ,(mk `(g))))
'(lambda (g) (g))))
(not (equivalent-expansion?
(expand/optimize `(lambda () (lambda (g) ,(mk `(g)))))
'(lambda () (lambda (g) (g)))))
(equivalent-expansion?
(expand/optimize `(lambda (g) (list ,(mk `(g)))))
(if (eqv? (optimize-level) 3)
'(lambda (g) (#3%list (g)))
'(lambda (g) (#2%list (g)))))
(equivalent-expansion?
(expand/optimize `(lambda (g) (if ,(mk `(g)) 1 2)))
'(lambda (g) (if (g) 1 2))))))
#t)
(simplify-only-nontail? (lambda (e) `(let ([x ,e]) x)))
(simplify-only-nontail? (lambda (e) `(letrec ([x ,e]) x)))
(simplify-only-nontail? (lambda (e) `(values ,e)))
(simplify-only-nontail? (lambda (e) `(list* ,e)))
(simplify-only-nontail? (lambda (e) `(append ,e)))
(simplify-only-nontail? (lambda (e) `(append! ,e)))
(simplify-only-nontail? (lambda (e) `(car (list ,e))))
(simplify-only-nontail? (lambda (e) `(car (cons ,e 2))))
(simplify-only-nontail? (lambda (e) `(cdr (cons 2 ,e))))
)

13
s/cmacros.ss
View File

@ -1586,18 +1586,19 @@
(ieee #b00000000000000000010000) (ieee #b00000000000000000010000)
(proc #b00000000000000000100000) (proc #b00000000000000000100000)
(discard #b00000000000000001000000) (discard #b00000000000000001000000)
(unrestricted #b00000000000000010000000) (single-valued #b00000000000000010000000)
(true #b00000000000000100000000) (true (or #b00000000000000100000000 single-valued))
(mifoldable #b00000000000001000000000) (mifoldable (or #b00000000000001000000000 single-valued))
(cp02 #b00000000000010000000000) (cp02 #b00000000000010000000000)
(cp03 #b00000000000100000000000) (cp03 #b00000000000100000000000)
(system-keyword #b00000000001000000000000) (system-keyword #b00000000001000000000000)
(r6rs #b00000000010000000000000) (r6rs #b00000000010000000000000)
(pure (or #b00000000100000000000000 discard)) (pure (or #b00000000100000000000000 discard single-valued))
(library-uid #b00000001000000000000000) (library-uid #b00000001000000000000000)
(boolean-valued #b00000010000000000000000) (boolean-valued (or #b00000010000000000000000 single-valued))
(abort-op #b00000100000000000000000) (abort-op #b00000100000000000000000)
(unsafe #b00001000000000000000000) (unsafe #b00001000000000000000000)
(unrestricted #b00010000000000000000000)
(arith-op (or proc pure true)) (arith-op (or proc pure true))
(alloc (or proc discard true)) (alloc (or proc discard true))
; would be nice to check that these and only these actually have cp0 partial folders ; would be nice to check that these and only these actually have cp0 partial folders
@ -1613,6 +1614,8 @@
(simple #b0000100000) (simple #b0000100000)
(boolean-valued-known #b0001000000) (boolean-valued-known #b0001000000)
(boolean-valued #b0010000000) (boolean-valued #b0010000000)
(single-valued-nontail-known #b0100000000)
(single-valued-nontail #b1000000000)
) )
(define-syntax define-flag-field (define-syntax define-flag-field

93
s/cp0.ss
View File

@ -755,6 +755,14 @@
(bump sc 1) (bump sc 1)
`(if ,e1 ,e2 ,e3)]))) `(if ,e1 ,e2 ,e3)])))
(define make-nontail
(lambda (ctxt e)
(if (or (not (eq? (app-ctxt ctxt) 'tail))
(single-valued-nontail? e))
e
(let ([tmp (cp0-make-temp #f)])
(build-let (list tmp) (list e) (build-ref tmp))))))
(define result-exp (define result-exp
(lambda (e) (lambda (e)
(nanopass-case (Lsrc Expr) e (nanopass-case (Lsrc Expr) e
@ -879,7 +887,7 @@
((ids->do-clause '()) clause) ((ids->do-clause '()) clause)
#t)))) #t))))
(module (pure? ivory? simple? simple/profile? boolean-valued?) (module (pure? ivory? simple? simple/profile? boolean-valued? single-valued-nontail?)
(define-syntax make-$memoize (define-syntax make-$memoize
(syntax-rules () (syntax-rules ()
[(_ flag-known flag) [(_ flag-known flag)
@ -1140,6 +1148,43 @@
[(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) #f] [(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) #f]
[(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) #f] [(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) #f]
[(pariah) #f] [(pariah) #f]
[else ($oops who "unrecognized record ~s" e)]))))
(define-who single-valued-nontail?
(lambda (e)
(with-memoize (single-valued-nontail-known single-valued-nontail) e
; known to produce a single value, and does not observe
; or affect the immediate continuation frame (so removing
; (an enclosing frame would be ok)
(nanopass-case (Lsrc Expr) e
[(quote ,d) #t]
[(call ,preinfo ,e ,e* ...)
(nanopass-case (Lsrc Expr) e
[,pr (all-set? (prim-mask single-valued) (primref-flags pr))]
[(case-lambda ,preinfo1 (clause (,x* ...) ,interface ,body))
(guard (fx= interface (length e*)))
(memoize (single-valued-nontail? body))]
[else #f])]
[(ref ,maybe-src ,x) #t]
[(case-lambda ,preinfo ,cl* ...) #t]
[(if ,e1 ,e2 ,e3) (memoize (and (single-valued-nontail? e2) (single-valued-nontail? e3)))]
[(seq ,e1 ,e2) (memoize (single-valued-nontail? e2))]
[(set! ,maybe-src ,x ,e) #t]
[(immutable-list (,e* ...) ,e) #t]
[(letrec ([,x* ,e*] ...) ,body) (memoize (single-valued-nontail? body))]
[(letrec* ([,x* ,e*] ...) ,body) (memoize (single-valued-nontail? body))]
[,pr #t]
[(record-cd ,rcd ,rtd-expr ,e) #t]
[(record-ref ,rtd ,type ,index ,e) #t]
[(record-set! ,rtd ,type ,index ,e1 ,e2) #t]
[(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) #t]
[(record-type ,rtd ,e) #t]
[(record ,rtd ,rtd-expr ,e* ...) #t]
[(pariah) #t]
[(profile ,src) #t]
[(cte-optimization-loc ,box ,e) (memoize (single-valued-nontail? e))]
[(moi) #t]
[(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) #t]
[else ($oops who "unrecognized record ~s" e)]))))) [else ($oops who "unrecognized record ~s" e)])))))
(define find-call-lambda-clause (define find-call-lambda-clause
@ -1271,7 +1316,9 @@
[(and (= (length id*) 1) [(and (= (length id*) 1)
(nanopass-case (Lsrc Expr) body (nanopass-case (Lsrc Expr) body
[(ref ,maybe-src ,x) (eq? x (car id*))] [(ref ,maybe-src ,x) (eq? x (car id*))]
[else #f])) [else #f])
(or (not (eq? (app-ctxt ctxt) 'tail))
(single-valued-nontail? (car rhs*))))
; (let ((x e)) x) => e ; (let ((x e)) x) => e
; x is clearly not assigned, even if flags are polluted and say it is ; x is clearly not assigned, even if flags are polluted and say it is
(car rhs*)] (car rhs*)]
@ -1609,7 +1656,7 @@
[else (residualize-ref maybe-src id sc)])] [else (residualize-ref maybe-src id sc)])]
[,pr [,pr
(context-case ctxt (context-case ctxt
[(value) [(value tail)
(if (all-set? (prim-mask (or primitive proc)) (primref-flags pr)) (if (all-set? (prim-mask (or primitive proc)) (primref-flags pr))
rhs rhs
(residualize-ref maybe-src id sc))] (residualize-ref maybe-src id sc))]
@ -2117,9 +2164,9 @@
[args #f]) [args #f])
(define-inline 2 (cons* list* values append append!) (define-inline 2 (cons* list* values append append!)
[(x) (let ((xval (value-visit-operand! x))) [(x) (begin
(residualize-seq (list x) '() ctxt) (residualize-seq (list x) '() ctxt)
xval)] (make-nontail ctxt (value-visit-operand! x)))]
[args #f]) [args #f])
(define-inline 2 vector (define-inline 2 vector
@ -4177,19 +4224,19 @@
(and (not (null? e*)) (and (not (null? e*))
(begin (begin
(residualize-seq '() (list ?x) ctxt) (residualize-seq '() (list ?x) ctxt)
(car e*)))] (make-nontail ctxt (car e*))))]
[(call ,preinfo ,pr ,e1 ,e2) [(call ,preinfo ,pr ,e1 ,e2)
(guard (eq? (primref-name pr) 'cons)) (guard (eq? (primref-name pr) 'cons))
(residualize-seq (list ?x) '() ctxt) (residualize-seq (list ?x) '() ctxt)
(non-result-exp (operand-value ?x) (non-result-exp (operand-value ?x)
(make-seq (app-ctxt ctxt) e2 e1))] (make-seq (app-ctxt ctxt) e2 (make-nontail ctxt e1)))]
[(call ,preinfo ,pr ,e* ...) [(call ,preinfo ,pr ,e* ...)
(guard (memq (primref-name pr) '(list list* cons*)) (not (null? e*))) (guard (memq (primref-name pr) '(list list* cons*)) (not (null? e*)))
(residualize-seq (list ?x) '() ctxt) (residualize-seq (list ?x) '() ctxt)
(non-result-exp (operand-value ?x) (non-result-exp (operand-value ?x)
(fold-right (fold-right
(lambda (e1 e2) (make-seq (app-ctxt ctxt) e1 e2)) (lambda (e1 e2) (make-seq (app-ctxt ctxt) e1 e2))
(car e*) (make-nontail ctxt (car e*))
(cdr e*)))] (cdr e*)))]
[else #f])]) [else #f])])
@ -4207,7 +4254,7 @@
(guard (eq? (primref-name pr) 'cons)) (guard (eq? (primref-name pr) 'cons))
(residualize-seq (list ?x) '() ctxt) (residualize-seq (list ?x) '() ctxt)
(non-result-exp (operand-value ?x) (non-result-exp (operand-value ?x)
(make-seq (app-ctxt ctxt) e1 e2))] (make-seq (app-ctxt ctxt) e1 (make-nontail ctxt e2)))]
[(call ,preinfo ,pr ,e* ...) [(call ,preinfo ,pr ,e* ...)
(guard (eq? (primref-name pr) 'list) (not (null? e*))) (guard (eq? (primref-name pr) 'list) (not (null? e*)))
(residualize-seq (list ?x) '() ctxt) (residualize-seq (list ?x) '() ctxt)
@ -4237,7 +4284,7 @@
(residualize-seq (list ?x ?i) '() ctxt) (residualize-seq (list ?x ?i) '() ctxt)
(non-result-exp (operand-value ?i) ; do first ... (non-result-exp (operand-value ?i) ; do first ...
(non-result-exp (operand-value ?x) ; ... so we keep ?x related side effects together (non-result-exp (operand-value ?x) ; ... so we keep ?x related side effects together
e))))))) (make-nontail ctxt e))))))))
(define tryref (define tryref
(lambda (ctxt ?x ?i seqprim maybe-pred) (lambda (ctxt ?x ?i seqprim maybe-pred)
@ -4561,7 +4608,7 @@
(let ([x ($symbol-name name)]) (let ([x ($symbol-name name)])
(if (pair? x) (cdr x) x)))) (if (pair? x) (cdr x) x))))
(context-case ctxt (context-case ctxt
[(value) [(value tail)
(bump sc 1) (bump sc 1)
`(case-lambda ,preinfo `(case-lambda ,preinfo
,(let f ([cl* cl*] [mask 0]) ,(let f ([cl* cl*] [mask 0])
@ -4574,7 +4621,7 @@
(f (cdr cl*) new-mask) (f (cdr cl*) new-mask)
(cons (cons
(with-extended-env ((env x*) (env x* #f)) (with-extended-env ((env x*) (env x* #f))
`(clause (,x* ...) ,interface ,(cp0 body 'value env sc wd #f name))) `(clause (,x* ...) ,interface ,(cp0 body 'tail env sc wd #f name)))
(f (cdr cl*) new-mask))))]))) (f (cdr cl*) new-mask))))])))
...)] ...)]
[(effect) void-rec] [(effect) void-rec]
@ -4607,11 +4654,13 @@
(make-if ctxt sc e1 (make-if ctxt sc e1
true-rec true-rec
(do-e3))])) (do-e3))]))
(if (eq? (app-ctxt ctxt) 'value) (let ([r-ctxt (app-ctxt ctxt)])
(let ([e1 (value-visit-operand! (car (app-opnds ctxt)))]) (if (or (eq? r-ctxt 'value)
(and (boolean-valued? e1) (finish e1))) (eq? r-ctxt 'tail))
(and (eq? (app-ctxt ctxt) 'test) (let ([e1 (visit-operand! (car (app-opnds ctxt)) r-ctxt)])
(finish (test-visit-operand! (car (app-opnds ctxt)))))))] (and (boolean-valued? e1) (finish e1)))
(and (eq? (app-ctxt ctxt) 'test)
(finish (test-visit-operand! (car (app-opnds ctxt))))))))]
[else #f])) [else #f]))
(cp0-let preinfo ids body ctxt env sc wd name moi))] (cp0-let preinfo ids body ctxt env sc wd name moi))]
[() (cp0 ir 'value env sc wd name moi)]))])] [() (cp0 ir 'value env sc wd name moi)]))])]
@ -4620,7 +4669,7 @@
[(letrec* ([,x* ,e*] ...) ,body) [(letrec* ([,x* ,e*] ...) ,body)
(cp0-rec-let #t x* e* body ctxt env sc wd name moi)] (cp0-rec-let #t x* e* body ctxt env sc wd name moi)]
[,pr (context-case ctxt [,pr (context-case ctxt
[(value) (bump sc 1) pr] [(value tail) (bump sc 1) pr]
[(effect) void-rec] [(effect) void-rec]
[(test) [(test)
(if (all-set? (prim-mask proc) (primref-flags pr)) (if (all-set? (prim-mask proc) (primref-flags pr))
@ -4629,16 +4678,16 @@
[(app) (fold-primref pr ctxt sc wd name moi)])] [(app) (fold-primref pr ctxt sc wd name moi)])]
[(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) [(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type)
(context-case ctxt (context-case ctxt
[(value app) (bump sc 1) `(foreign (,conv* ...) ,name ,(cp0 e 'value env sc wd #f moi) (,arg-type* ...) ,result-type)] [(value tail app) (bump sc 1) `(foreign (,conv* ...) ,name ,(cp0 e 'value env sc wd #f moi) (,arg-type* ...) ,result-type)]
[(effect test) (cp0 `(seq ,e ,true-rec) ctxt env sc wd #f moi)])] [(effect test) (cp0 `(seq ,e ,true-rec) ctxt env sc wd #f moi)])]
[(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) [(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type)
(context-case ctxt (context-case ctxt
[(value app) (bump sc 1) `(fcallable (,conv* ...) ,(cp0 e 'value env sc wd #f moi) (,arg-type* ...) ,result-type)] [(value tail app) (bump sc 1) `(fcallable (,conv* ...) ,(cp0 e 'value env sc wd #f moi) (,arg-type* ...) ,result-type)]
[(effect) (cp0 e 'effect env sc wd #f moi)] [(effect) (cp0 e 'effect env sc wd #f moi)]
[(test) (make-seq ctxt (cp0 e 'effect env sc wd #f moi) true-rec)])] [(test) (make-seq ctxt (cp0 e 'effect env sc wd #f moi) true-rec)])]
[(record ,rtd ,rtd-expr ,e* ...) [(record ,rtd ,rtd-expr ,e* ...)
(context-case ctxt (context-case ctxt
[(value app) [(value tail app)
(let ([rtd-expr (cp0 rtd-expr 'value env sc wd #f moi)] (let ([rtd-expr (cp0 rtd-expr 'value env sc wd #f moi)]
[e* (map (lambda (e) (cp0 e 'value env sc wd #f moi)) e*)]) [e* (map (lambda (e) (cp0 e 'value env sc wd #f moi)) e*)])
(or (nanopass-case (Lsrc Expr) (result-exp rtd-expr) (or (nanopass-case (Lsrc Expr) (result-exp rtd-expr)
@ -4744,7 +4793,7 @@
(fluid-let ([likely-to-be-compiled? ltbc?] (fluid-let ([likely-to-be-compiled? ltbc?]
[opending-list '()] [opending-list '()]
[cp0-info-hashtable (make-weak-eq-hashtable)]) [cp0-info-hashtable (make-weak-eq-hashtable)])
(cp0 x 'value empty-env (new-scorer) (new-watchdog) #f #f))])))) (cp0 x 'tail empty-env (new-scorer) (new-watchdog) #f #f))]))))
; check to make sure all required handlers were seen, after expansion of the ; check to make sure all required handlers were seen, after expansion of the
; expression above has been completed ; expression above has been completed

6
s/primdata.ss
View File

@ -1690,7 +1690,7 @@
(top-level-mutable? [sig [(symbol) (symbol environment) -> (boolean)]] [flags discard]) (top-level-mutable? [sig [(symbol) (symbol environment) -> (boolean)]] [flags discard])
(top-level-syntax [sig [(symbol) (symbol environment) -> (ptr)]] [flags discard]) (top-level-syntax [sig [(symbol) (symbol environment) -> (ptr)]] [flags discard])
(top-level-syntax? [sig [(symbol) (symbol environment) -> (boolean)]] [flags discard]) (top-level-syntax? [sig [(symbol) (symbol environment) -> (boolean)]] [flags discard])
(top-level-value [sig [(symbol) (symbol environment) -> (ptr)]] [flags discard]) (top-level-value [sig [(symbol) (symbol environment) -> (ptr)]] [flags discard single-valued])
(transcoder? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (transcoder? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
(transcript-cafe [sig [(pathname) -> (ptr ...)]] [flags]) (transcript-cafe [sig [(pathname) -> (ptr ...)]] [flags])
(transcript-off [sig [() -> (void)]] [flags true ieee r5rs]) (transcript-off [sig [() -> (void)]] [flags true ieee r5rs])
@ -2242,8 +2242,8 @@
($tlc-ht [flags mifoldable discard]) ($tlc-ht [flags mifoldable discard])
($tlc-keyval [flags pure mifoldable discard]) ($tlc-keyval [flags pure mifoldable discard])
($tlc-next [flags mifoldable discard]) ($tlc-next [flags mifoldable discard])
($top-level-bound? [flags discard]) ($top-level-bound? [flags discard single-valued])
($top-level-value [flags discard cp02]) ($top-level-value [flags discard cp02 single-valued])
($trace-closure [flags pure alloc]) ($trace-closure [flags pure alloc])
($trace [flags]) ($trace [flags])
($track-dynamic-closure-counts [flags]) ; added for closure instrumentation ($track-dynamic-closure-counts [flags]) ; added for closure instrumentation

2
s/syntax.ss
View File

@ -8766,7 +8766,7 @@
;; but tell `$foreign-procedure` that the result is actually an & form ;; but tell `$foreign-procedure` that the result is actually an & form
#`((lambda (r) (void)) #,(datum->syntax #'foreign-procedure result-type))] #`((lambda (r) (void)) #,(datum->syntax #'foreign-procedure result-type))]
[else [else
#`(values #,(datum->syntax #'foreign-procedure result-type))])])] #`(begin #,(datum->syntax #'foreign-procedure result-type))])])]
[([extra ...] [extra-arg ...] [extra-check ...]) [([extra ...] [extra-arg ...] [extra-check ...])
;; When the result type is `(& <ftype>)`, the `$foreign-procedure` result ;; When the result type is `(& <ftype>)`, the `$foreign-procedure` result
;; expects an extra argument as a `(* <ftype>)` that it uses to store the ;; expects an extra argument as a `(* <ftype>)` that it uses to store the