cptypes: discard call form around an error, better cm support
An an example of better error handling,
(f (error 'x "x") y x)
turns into
(error 'x "x")
which may allow further propagation through `begin` and `if` as
alerady implemented.
Also, make cp0 and cptypes more aware of
`call-{setting,getting,cosuming}-continuation-attachment` in terms of
result types and single-valuedness. The single-valued part requires
some generalization to the existing `single-valued?` support (by
default, "single-valued" => "doesn't inspect/changed immediate mark")
in both cp0 and cptypes.
Finally, the "optimize.rktl" test suite is now enabled for Racket CS.
The tests helped expose some missed opportunities and bugs, and it
should be particularly helpful going forward, since we're back to
having a place for Racket-level optimization tests. Not all tests
written for BC pass with CS. Grep for 'chez-scheme for missed
optimization opportunities.
This commit is contained in:
Matthew Flatt
parent
73eeff4f60
commit
75ba7ff5bc
|
|
@ -41,8 +41,7 @@
|
|||
(load-relative "path.rktl")
|
||||
(unless (or building-flat-tests? in-drscheme?)
|
||||
(load-relative "jitinline.rktl")
|
||||
(when (eq? 'racket (system-type 'vm))
|
||||
(load-relative "optimize.rktl")))
|
||||
(load-relative "optimize.rktl"))
|
||||
(unless building-flat-tests?
|
||||
(load-relative "name.rktl"))
|
||||
(load-relative "srcloc.rktl")
|
||||
|
|
|
|||
|
|
@ -3724,7 +3724,7 @@
|
|||
(test-comp '(module m racket/base
|
||||
(define-values (struct:a a a? a-x a-y)
|
||||
(let-values ([(struct:a a a? a-ref a-set!)
|
||||
(make-struct-type 'a #f 2 0 #f)])
|
||||
(make-struct-type 'a #f 2 0 #f)]) ; 'chez-scheme needs at least this many arguments
|
||||
(values struct:a a a?
|
||||
(make-struct-field-accessor a-ref 0)
|
||||
(make-struct-field-accessor a-ref 1))))
|
||||
|
|
@ -4378,22 +4378,26 @@
|
|||
#:implies-real? [implies-real? #t]
|
||||
#:needs-two-args? [needs-two-args? #f])
|
||||
(test-comp `(lambda (x y)
|
||||
(list (,op x y)
|
||||
(number? x)
|
||||
(number? y)))
|
||||
(list (,op x y)
|
||||
(random) ; 'chez-scheme needs this to force ordering in schemify
|
||||
(number? x)
|
||||
(number? y)))
|
||||
`(lambda (x y)
|
||||
(list (,op x y)
|
||||
#t
|
||||
#t)))
|
||||
(list (,op x y)
|
||||
(random)
|
||||
#t
|
||||
#t)))
|
||||
(when implies-real?
|
||||
(test-comp `(lambda (x y)
|
||||
(list (,op x y)
|
||||
(random)
|
||||
(real? x)
|
||||
(real? y)
|
||||
(number? x)
|
||||
(number? y)))
|
||||
`(lambda (x y)
|
||||
(list (,op x y)
|
||||
(random)
|
||||
#t
|
||||
#t
|
||||
#t
|
||||
|
|
@ -4402,18 +4406,21 @@
|
|||
(let ([? (if implies-real? 'real? 'number?)])
|
||||
(test-comp `(lambda (x y z w)
|
||||
(list (,op x y z w)
|
||||
(random)
|
||||
(,? x)
|
||||
(,? y)
|
||||
(,? z)
|
||||
(,? w)))
|
||||
`(lambda (x y z w)
|
||||
(list (,op x y z w)
|
||||
(random)
|
||||
#t
|
||||
#t
|
||||
#t
|
||||
#t)))))
|
||||
(when can-omit?
|
||||
(test-comp `(lambda (x y)
|
||||
(test-comp #:except 'chez-scheme ; need call-setting-attachment optimization
|
||||
`(lambda (x y)
|
||||
(if (and (real? x) (real? y))
|
||||
(with-continuation-mark
|
||||
'x 'y
|
||||
|
|
@ -4449,25 +4456,29 @@
|
|||
|
||||
(define (check-number-op op [closed-under-reals? #t])
|
||||
(test-comp `(lambda (x y)
|
||||
(list (,op x y)
|
||||
(number? x)
|
||||
(number? y)))
|
||||
(list (,op x y)
|
||||
(random) ; 'chez-scheme needs this to force ordering in schemify
|
||||
(number? x)
|
||||
(number? y)))
|
||||
`(lambda (x y)
|
||||
(list (,op x y)
|
||||
#t
|
||||
#t)))
|
||||
(list (,op x y)
|
||||
(random)
|
||||
#t
|
||||
#t)))
|
||||
(test-comp `(lambda (x y z w)
|
||||
(list (,op x y z w)
|
||||
(number? x)
|
||||
(number? y)
|
||||
(number? z)
|
||||
(number? w)))
|
||||
(list (,op x y z w)
|
||||
(random)
|
||||
(number? x)
|
||||
(number? y)
|
||||
(number? z)
|
||||
(number? w)))
|
||||
`(lambda (x y z w)
|
||||
(list (,op x y z w)
|
||||
#t
|
||||
#t
|
||||
#t
|
||||
#t)))
|
||||
(list (,op x y z w)
|
||||
(random)
|
||||
#t
|
||||
#t
|
||||
#t
|
||||
#t)))
|
||||
(test-comp `(lambda (x y)
|
||||
(list (,op x y)
|
||||
(real? x)))
|
||||
|
|
@ -4477,7 +4488,8 @@
|
|||
;; cannot assume `real?`
|
||||
#f)
|
||||
(when closed-under-reals?
|
||||
(test-comp `(lambda (x y)
|
||||
(test-comp #:except 'chez-scheme ; need call-setting-attachment optimization
|
||||
`(lambda (x y)
|
||||
(if (and (real? x) (real? y))
|
||||
(let ([v (,op x y)])
|
||||
(with-continuation-mark
|
||||
|
|
@ -4499,13 +4511,16 @@
|
|||
|
||||
(define (check-number-op-unary op)
|
||||
(test-comp `(lambda (x y)
|
||||
(list (,op x)
|
||||
(number? x)))
|
||||
(list (,op x)
|
||||
(random) ; 'chez-scheme needs this to force ordering in schemify
|
||||
(number? x)))
|
||||
`(lambda (x y)
|
||||
(list (,op x)
|
||||
#t)))
|
||||
(list (,op x)
|
||||
(random)
|
||||
#t)))
|
||||
;; Check closed under reals:
|
||||
(test-comp `(lambda (x y)
|
||||
(test-comp #:except 'chez-scheme ; need call-setting-attachment optimization
|
||||
`(lambda (x y)
|
||||
(if (real? x)
|
||||
(with-continuation-mark
|
||||
'x 'y
|
||||
|
|
@ -4653,7 +4668,8 @@
|
|||
'(lambda (f) (let ([x (random)] [y (random)]) (f x x y y) (error 'error)) 5))
|
||||
(test-comp '(lambda (f) (let-values ([(x) (error 'error)] [(y) #f] [(z) #f] ) #f))
|
||||
'(lambda (f) (let-values ([(x) (error 'error)] [(y z) (f)]) (f x x y y z z)) 5))
|
||||
(test-comp '(lambda (f) (let-values ([(x) (error 'error)] [(y) #f] [(z) #f]) #f))
|
||||
(test-comp #:except 'chez-scheme ; would need one more cp0 pass?
|
||||
'(lambda (f) (let-values ([(x) (error 'error)] [(y) #f] [(z) #f]) #f))
|
||||
'(lambda (f) (let-values ([(x y) (values (error 'error) (k:random))] [(z) (f)]) (f x x y y z z)) 5))
|
||||
(test-comp '(lambda (f) (let-values ([(x) (begin (random) (error 'error))] [(y) #f] [(z) #f]) #f))
|
||||
'(lambda (f) (let-values ([(x y) (values (random) (error 'error))] [(z) (f)]) (f x x y y z z)) 5))
|
||||
|
|
@ -4663,11 +4679,12 @@
|
|||
|
||||
(test-comp '(lambda (f) (letrec ([x (lambda() y)] [y (lambda () x)]) (f x y) (error 'error)))
|
||||
'(lambda (f) (letrec ([x (lambda() y)] [y (lambda () x)]) (f x y) (error 'error)) 5))
|
||||
(test-comp '(lambda (f) (letrec ([x (lambda() y)] [y (lambda () x)] [z (error 'error)]) #f))
|
||||
(test-comp #:except 'chez-scheme ; happens to differ in `let` vs `let*`
|
||||
'(lambda (f) (letrec ([x (lambda() y)] [y (lambda () x)] [z (error 'error)]) #f))
|
||||
'(lambda (f) (letrec ([x (lambda() y)] [y (lambda () x)] [z (error 'error)]) (f x y z)) 5))
|
||||
(test-comp '(lambda (f) (letrec ([x (lambda() y)] [z (error 'error)] [y #f]) #f))
|
||||
'(lambda (f) (letrec ([x (lambda() y)] [z (error 'error)] [y (lambda () x)]) (f x y z)) 5)
|
||||
#f) ; letrec-check pass determines that the body of `x` is dead
|
||||
(test-comp #:except 'racket ; letrec-check pass determines that the body of `x` is dead
|
||||
'(lambda (f) (letrec ([x (lambda() y)] [z (error 'error)] [y #f]) #f))
|
||||
'(lambda (f) (letrec ([x (lambda() y)] [z (error 'error)] [y (lambda () x)]) (f x y z)) 5))
|
||||
(test-comp '(lambda (f) (letrec ([z (error 'error)] [x #f] [y #f]) #f))
|
||||
'(lambda (f) (letrec ([z (error 'error)] [x (lambda() y)] [y (lambda () x)]) (f x y z)) 5))
|
||||
|
||||
|
|
@ -4814,8 +4831,9 @@
|
|||
(f)))
|
||||
|
||||
(let ([check-wcm-wrap
|
||||
(lambda (nontail-wrap)
|
||||
(test-comp `(lambda (p)
|
||||
(lambda (nontail-wrap #:except [except #f])
|
||||
(test-comp #:except except
|
||||
`(lambda (p)
|
||||
(with-continuation-mark
|
||||
'contrast-dye 1
|
||||
,(nontail-wrap `(with-continuation-mark
|
||||
|
|
@ -4833,25 +4851,33 @@
|
|||
`(unsafe-fx+ 0 ,e)))
|
||||
(check-wcm-wrap (lambda (e)
|
||||
`(unsafe-fx+ ,e 0)))
|
||||
(check-wcm-wrap (lambda (e)
|
||||
(check-wcm-wrap #:except 'chez-scheme ; cp0 doesn't discard trailing 0 for unsafe-fx-
|
||||
(lambda (e)
|
||||
`(unsafe-fx- ,e 0)))
|
||||
(check-wcm-wrap (lambda (e)
|
||||
`(unsafe-fx* 1 ,e)))
|
||||
(check-wcm-wrap (lambda (e)
|
||||
`(unsafe-fx* ,e 1)))
|
||||
(check-wcm-wrap (lambda (e)
|
||||
(check-wcm-wrap #:except 'chez-scheme ; cp0 doesn't discard trailing 1 for unsafe-fxquotient
|
||||
(lambda (e)
|
||||
`(unsafe-fxquotient ,e 1)))
|
||||
(check-wcm-wrap (lambda (e)
|
||||
(check-wcm-wrap #:except 'chez-scheme ; no 0.0 specialization
|
||||
(lambda (e)
|
||||
`(unsafe-fl+ 0.0 ,e)))
|
||||
(check-wcm-wrap (lambda (e)
|
||||
(check-wcm-wrap #:except 'chez-scheme ; no 0.0 specialization
|
||||
(lambda (e)
|
||||
`(unsafe-fl+ ,e 0.0)))
|
||||
(check-wcm-wrap (lambda (e)
|
||||
(check-wcm-wrap #:except 'chez-scheme ; no 0.0 specialization
|
||||
(lambda (e)
|
||||
`(unsafe-fl- ,e 0.0)))
|
||||
(check-wcm-wrap (lambda (e)
|
||||
(check-wcm-wrap #:except 'chez-scheme ; no 1.0 specialization
|
||||
(lambda (e)
|
||||
`(unsafe-fl* 1.0 ,e)))
|
||||
(check-wcm-wrap (lambda (e)
|
||||
(check-wcm-wrap #:except 'chez-scheme ; no 1.0 specialization
|
||||
(lambda (e)
|
||||
`(unsafe-fl* ,e 1.0)))
|
||||
(check-wcm-wrap (lambda (e)
|
||||
(check-wcm-wrap #:except 'chez-scheme ; no 1.0 specialization
|
||||
(lambda (e)
|
||||
`(unsafe-fl/ ,e 1.0))))
|
||||
|
||||
;; Check `if` reduction in a boolen context:
|
||||
|
|
@ -4900,11 +4926,14 @@
|
|||
'(lambda () #f))
|
||||
(test-comp '(lambda () (string=? "123" "456"))
|
||||
'(lambda () #f))
|
||||
(test-comp '(lambda () (bytes=? #"123" #"123"))
|
||||
(test-comp #:except 'chez-scheme ; no `bytes=?` folding
|
||||
'(lambda () (bytes=? #"123" #"123"))
|
||||
'(lambda () #t))
|
||||
(test-comp '(lambda () (bytes=? #"123" #"123456"))
|
||||
(test-comp #:except 'chez-scheme ; no `bytes=?` folding
|
||||
'(lambda () (bytes=? #"123" #"123456"))
|
||||
'(lambda () #f))
|
||||
(test-comp '(lambda () (bytes=? #"123" #"456"))
|
||||
(test-comp #:except 'chez-scheme ; no `bytes=?` folding
|
||||
'(lambda () (bytes=? #"123" #"456"))
|
||||
'(lambda () #f))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -4951,11 +4980,14 @@
|
|||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Check that the unused continuations are removed
|
||||
|
||||
(test-comp '(call-with-current-continuation (lambda (ignored) 5))
|
||||
(test-comp #:except 'chez-scheme
|
||||
'(call-with-current-continuation (lambda (ignored) 5))
|
||||
5)
|
||||
(test-comp '(call-with-composable-continuation (lambda (ignored) 5))
|
||||
(test-comp #:except 'chez-scheme
|
||||
'(call-with-composable-continuation (lambda (ignored) 5))
|
||||
5)
|
||||
(test-comp '(call-with-escape-continuation (lambda (ignored) 5))
|
||||
(test-comp #:except 'chez-scheme
|
||||
'(call-with-escape-continuation (lambda (ignored) 5))
|
||||
5)
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -4972,7 +5004,8 @@
|
|||
(define y 2)
|
||||
(define z 4)
|
||||
(define w 5)))
|
||||
(test-comp `(module m racket/base
|
||||
(test-comp #:except 'chez-scheme ; schemify doesn't recognize this pattern
|
||||
`(module m racket/base
|
||||
(define-values (x y)
|
||||
(let ([x (lambda (x) x)]
|
||||
[y (lambda (x y) y)])
|
||||
|
|
@ -4980,7 +5013,8 @@
|
|||
`(module m racket/base
|
||||
(define x (lambda (x) x))
|
||||
(define y (lambda (x y) y))))
|
||||
(test-comp `(module m racket/base
|
||||
(test-comp #:except 'chez-scheme ; schemify doesn't recognize this pattern
|
||||
`(module m racket/base
|
||||
(define-values (x y z)
|
||||
(let ([x (lambda (x) x)]
|
||||
[y (lambda (x y) y)]
|
||||
|
|
@ -5145,18 +5179,22 @@
|
|||
;; Transform call-with-values to direct application:
|
||||
(test-comp '(lambda (f) (f 7))
|
||||
'(lambda (f) (call-with-values (lambda () 7) (lambda (x) (f x)))))
|
||||
(test-comp '(lambda () (car 7))
|
||||
(test-comp #:except 'chez-scheme ; `call-with-values` conversion currently requires a lambda consumer
|
||||
'(lambda () (car 7))
|
||||
'(lambda () (call-with-values (lambda () 7) car)))
|
||||
(test-comp '(lambda () ('not-a-procedure 7))
|
||||
(test-comp #:except 'chez-scheme
|
||||
'(lambda () ('not-a-procedure 7))
|
||||
'(lambda () (call-with-values (lambda () 7) 'not-a-procedure))
|
||||
#f)
|
||||
(test-comp '(module ? racket/base
|
||||
(test-comp #:except 'chez-scheme
|
||||
'(module ? racket/base
|
||||
(define f (lambda (x) (list x 0)))
|
||||
(lambda () (display f) (f 7)))
|
||||
'(module ? racket/base
|
||||
(define f (lambda (x) (list x 0)))
|
||||
(lambda () (display f) (call-with-values (lambda () 7) f))))
|
||||
(test-comp '(module ? racket/base
|
||||
(test-comp #:except 'chez-scheme
|
||||
'(module ? racket/base
|
||||
(define f (let ([tmp (list 0)]) (lambda (x) (list x tmp))))
|
||||
(lambda () (f 7)))
|
||||
'(module ? racket/base
|
||||
|
|
|
|||
|
|
@ -2614,7 +2614,8 @@
|
|||
(begin (#%write 'f) #\y)
|
||||
(begin (#%write 'g) ($zzz-ok))))
|
||||
(begin (#%write 'h) 1)))))
|
||||
(expansion-matches?
|
||||
(parameterize ([enable-type-recovery #f])
|
||||
(expansion-matches?
|
||||
'(begin (write 'a)
|
||||
((begin (write 'b) string-ref)
|
||||
(begin (write 'c)
|
||||
|
|
@ -2637,7 +2638,7 @@
|
|||
(begin (#%write 'e) ($xxx-ok))
|
||||
(begin (#%write 'f) 'oops)
|
||||
(begin (#%write 'g) ($zzz-ok))))
|
||||
(begin (#%write 'h) 1)))))
|
||||
(begin (#%write 'h) 1))))))
|
||||
(expansion-matches?
|
||||
`(begin (write 'a)
|
||||
((begin (write 'b) string-ref)
|
||||
|
|
@ -2730,7 +2731,8 @@
|
|||
(begin (#%write 'f) 121)
|
||||
(begin (#%write 'g) ($zzz-ok))))
|
||||
(begin (#%write 'h) 1)))))
|
||||
(expansion-matches?
|
||||
(parameterize ([enable-type-recovery #f])
|
||||
(expansion-matches?
|
||||
'(begin (write 'a)
|
||||
((begin (write 'b) fxvector-ref)
|
||||
(begin (write 'c)
|
||||
|
|
@ -2753,7 +2755,7 @@
|
|||
(begin (#%write 'e) ($xxx-ok))
|
||||
(begin (#%write 'f) 'oops)
|
||||
(begin (#%write 'g) ($zzz-ok))))
|
||||
(begin (#%write 'h) 1)))))
|
||||
(begin (#%write 'h) 1))))))
|
||||
(expansion-matches?
|
||||
`(begin (write 'a)
|
||||
((begin (write 'b) fxvector-ref)
|
||||
|
|
@ -2894,12 +2896,12 @@
|
|||
(expand/optimize
|
||||
'(lambda (v)
|
||||
(let ([v2 (if (vector? v) v (error))])
|
||||
(let ([q (vector-sort v2)] [n (#3%vector-length v)])
|
||||
(let ([q (vector-sort < v2)] [n (#3%vector-length v)])
|
||||
(display "1")
|
||||
(list q n))))))
|
||||
'(lambda (v)
|
||||
(let ([v2 (begin (if (#2%vector? v) (#2%void) (#2%error)) v)])
|
||||
(let ([q (#2%vector-sort v2)] [n (#3%vector-length v)])
|
||||
(let ([q (#2%vector-sort #2%< v2)] [n (#3%vector-length v)])
|
||||
(#2%display "1")
|
||||
(#2%list q n)))))
|
||||
(equivalent-expansion?
|
||||
|
|
@ -2907,11 +2909,11 @@
|
|||
(expand/optimize
|
||||
'(lambda (v)
|
||||
(let ([v2 (if (vector? v) v (error))])
|
||||
(let ([q (vector-sort v2)] [n (or v 72)])
|
||||
(let ([q (vector-sort < v2)] [n (or v 72)])
|
||||
(display "1")
|
||||
(list q n))))))
|
||||
'(lambda (v)
|
||||
(let ([q (#2%vector-sort (begin (if (#2%vector? v) (#2%void) (#2%error)) v))]
|
||||
(let ([q (#2%vector-sort #2%< (begin (if (#2%vector? v) (#2%void) (#2%error)) v))]
|
||||
[n (if v v 72)])
|
||||
(#2%display "1")
|
||||
(#2%list q n))))
|
||||
|
|
@ -2923,7 +2925,7 @@
|
|||
(syntax-rules ()
|
||||
[(_ eqprim) (eqtest eqprim #f)]
|
||||
[(_ eqprim generic?)
|
||||
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||||
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [enable-type-recovery #f])
|
||||
(let ([arity-mask (procedure-arity-mask eqprim)] [primref `($primitive ,(if (= (optimize-level) 3) 3 2) eqprim)])
|
||||
(define-syntax ifsafe
|
||||
(syntax-rules ()
|
||||
|
|
|
|||
|
|
@ -1205,3 +1205,61 @@
|
|||
'(lambda (x) (if (pair? x) (car x) (#2%assert-unreachable)))
|
||||
'(lambda (x) (#3%car x))))
|
||||
)
|
||||
|
||||
(mat cptypes-bottom
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (x) (error 'x "no") (add1 x))
|
||||
'(lambda (x) (error 'x "no")))
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (f) (f (error 'x "no") f))
|
||||
'(lambda (f) (error 'x "no")))
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (f) ((error 'x "no") f f))
|
||||
'(lambda (f) (error 'x "no")))
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (x) (if (error 'x "no") (add1 x) (sub1 x)))
|
||||
'(lambda (x) (error 'x "no")))
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (x) (+ (error 'x "no") x))
|
||||
'(lambda (x) (error 'x "no")))
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (x) (list x (add1 x) (error 'x "no") (sub1 x)))
|
||||
'(lambda (x) (error 'x "no")))
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (x) (apply x (add1 x) (error 'x "no") (sub1 x)))
|
||||
'(lambda (x) (error 'x "no")))
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (x) (apply (error 'x "no") (add1 x) (sub1 x)))
|
||||
'(lambda (x) (error 'x "no")))
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (x) (let* ([x (add1 x)] [y (error 'x "no")]) (+ x y)))
|
||||
'(lambda (x) (add1 x) (error 'x "no")))
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (x) (list (if (odd? x) (error 'x "no") (error 'x "nah")) 17))
|
||||
'(lambda (x) (if (odd? x) (error 'x "no") (error 'x "nah"))))
|
||||
(cptypes-equivalent-expansion?
|
||||
'(let ([x #f]) (case-lambda [() x] [(y) (set! x (error 'x "no"))]))
|
||||
'(let ([x #f]) (case-lambda [() x] [(y) (error 'x "no")])))
|
||||
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (x) (+ (call-setting-continuation-attachment 'a (lambda () (error 'x "no"))) 1))
|
||||
'(lambda (x) (#%$value (call-setting-continuation-attachment 'a (lambda () (error 'x "no"))))))
|
||||
(not
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (x) (+ (call-setting-continuation-attachment 'a (lambda () (error 'x "no"))) 1))
|
||||
'(lambda (x) (call-setting-continuation-attachment 'a (lambda () (error 'x "no"))))))
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (x) (+ (call-getting-continuation-attachment 'a (lambda (a) (error 'x "no"))) 1))
|
||||
'(lambda (x) (#%$value (call-getting-continuation-attachment 'a (lambda (a) (error 'x "no"))))))
|
||||
(not
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (x) (+ (call-getting-continuation-attachment 'a (lambda (a) (error 'x "no"))) 1))
|
||||
'(lambda (x) (call-getting-continuation-attachment 'a (lambda (a) (error 'x "no"))))))
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (x) (+ (call-consuming-continuation-attachment 'a (lambda (a) (error 'x "no"))) 1))
|
||||
'(lambda (x) (#%$value (call-consuming-continuation-attachment 'a (lambda (a) (error 'x "no"))))))
|
||||
(not
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (x) (+ (call-consuming-continuation-attachment 'a (lambda (a) (error 'x "no"))) 1))
|
||||
'(lambda (x) (call-consuming-continuation-attachment 'a (lambda (a) (error 'x "no"))))))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -843,7 +843,7 @@
|
|||
[(and (eq? ctxt 'ignored) (simple1? e2)
|
||||
;; don't move e1 into a single-value
|
||||
;; position unless that's ok
|
||||
(single-valued? e1))
|
||||
(single-valued/inspect-ok? e1))
|
||||
e1]
|
||||
[else
|
||||
(let ([e1 (nanopass-case (Lsrc Expr) e1
|
||||
|
|
@ -863,7 +863,7 @@
|
|||
|
||||
(define (safe-single-value e1)
|
||||
(if (or (fx= (optimize-level) 3)
|
||||
(single-valued? e1))
|
||||
(single-valued/inspect-ok? e1))
|
||||
e1
|
||||
(build-primcall 3 '$value (list e1))))
|
||||
|
||||
|
|
@ -911,7 +911,7 @@
|
|||
(lambda (ctxt e)
|
||||
(context-case ctxt
|
||||
[(tail)
|
||||
(if (single-valued-without-inspecting-continuation? e)
|
||||
(if (single-valued? e)
|
||||
e
|
||||
(build-primcall 3 '$value (list e)))]
|
||||
;; An 'effect, 'ignored, 'value, or 'test position will not
|
||||
|
|
@ -1071,7 +1071,7 @@
|
|||
|
||||
(module (pure? ivory? ivory1? simple? simple1? simple/profile? simple/profile1? boolean-valued?
|
||||
single-valued? single-valued single-valued-join single-valued-reduce?
|
||||
single-valued-without-inspecting-continuation?)
|
||||
single-valued/inspect-ok?)
|
||||
|
||||
;; The memoization table has, for each key, either a flags integer
|
||||
;; or a pair of a flags integer and a value. The value corresponds to
|
||||
|
|
@ -1099,8 +1099,9 @@
|
|||
(car val)
|
||||
(let ([r (pred?)])
|
||||
(let ([p (cdr a)])
|
||||
(unless (pair? p)
|
||||
(set-cdr! a (cons r p))))
|
||||
;; p may have been set meanwhile, but we want to update
|
||||
;; the cdr to handle joins around recursive calls
|
||||
(set-cdr! a (cons r (if (pair? p) (cdr p) p))))
|
||||
r)))))]))
|
||||
|
||||
(define-syntax with-memoize
|
||||
|
|
@ -1354,6 +1355,15 @@
|
|||
(car e*))]
|
||||
[else #f]))
|
||||
|
||||
(define (extract-called-procedure/inspect-ok pr e*)
|
||||
(case (primref-name pr)
|
||||
[(call-setting-continuation-attachment
|
||||
call-getting-continuation-attachment
|
||||
call-consuming-continuation-attachment)
|
||||
(and (fx= (length e*) 2)
|
||||
(cadr e*))]
|
||||
[else #f]))
|
||||
|
||||
(define-who boolean-valued?
|
||||
(lambda (e)
|
||||
(with-memoize (boolean-valued-known boolean-valued) e
|
||||
|
|
@ -1398,8 +1408,9 @@
|
|||
[(pariah) #f]
|
||||
[else ($oops who "unrecognized record ~s" e)]))))
|
||||
|
||||
;; Returns #t, #f, or a prelex for a lambda that needs to be
|
||||
;; single-valued to imply #t. The prelex case is useful to
|
||||
;; Returns #t, #f, 'value/inspect (single-valued, but may
|
||||
;; inspect continuation), or a prelex for a lambda that needs to
|
||||
;; be single-valued to imply #t. The prelex case is useful to
|
||||
;; detect a single-valued loop.
|
||||
(define-who single-valued
|
||||
(lambda (e)
|
||||
|
|
@ -1416,9 +1427,15 @@
|
|||
(or (all-set? (prim-mask single-valued) (primref-flags pr))
|
||||
(all-set? (prim-mask abort-op) (primref-flags pr))
|
||||
(and e*
|
||||
(let ([proc-e (extract-called-procedure pr e*)])
|
||||
(and proc-e
|
||||
(memoize (procedure-single-valued proc-e #f))))))]
|
||||
(cond
|
||||
[(extract-called-procedure pr e*)
|
||||
=> (lambda (proc-e)
|
||||
(memoize (procedure-single-valued proc-e #f)))]
|
||||
[(extract-called-procedure/inspect-ok pr e*)
|
||||
=> (lambda (proc-e)
|
||||
(memoize (single-valued-join 'value/inspect
|
||||
(procedure-single-valued proc-e #f))))]
|
||||
[else #f])))]
|
||||
[(case-lambda ,preinfo ,cl* ...)
|
||||
(memoize (or
|
||||
(all-set? (constant code-flag-single-valued)
|
||||
|
|
@ -1498,32 +1515,31 @@
|
|||
[(eq? a b) a]
|
||||
[(eq? a #t) b]
|
||||
[(eq? b #t) a]
|
||||
[(eq? a 'value/inspect) b]
|
||||
[(eq? b 'value/inspect) a]
|
||||
;; If `a` and `b` are different prelexes, we currently give
|
||||
;; up, because a prelex is used only to find a
|
||||
;; single-function fixpoint.
|
||||
[else #f])))
|
||||
|
||||
(define-who single-valued?
|
||||
(define-who single-valued/inspect-ok?
|
||||
(lambda (e)
|
||||
(single-valued-reduce? (single-valued e))))
|
||||
(let ([r (single-valued e)])
|
||||
(or (eq? r 'value/inspect) ; i.e., ok to inspect continuation
|
||||
(single-valued-reduce? r)))))
|
||||
|
||||
(define single-valued-reduce?
|
||||
(lambda (r)
|
||||
(cond
|
||||
[(eq? r #t) #t]
|
||||
[(eq? r #f) #f]
|
||||
[(eq? r 'value/inspect) #f]
|
||||
;; conservative assumption for a prelex:
|
||||
[else #f])))
|
||||
|
||||
(define-who single-valued-without-inspecting-continuation?
|
||||
(define-who single-valued?
|
||||
(lambda (e)
|
||||
;; Single-valued and does not observe or affect the
|
||||
;; immediate continuation frame (so removing (an enclosing
|
||||
;; frame would be ok). This currently can be implemented as
|
||||
;; `single-valued?`, because `single-valued?` does not look
|
||||
;; into continuation-observing calls like `(call/cc (lambda
|
||||
;; (k) <body>))` to detect that `<body>` is single valued.
|
||||
(single-valued? e))))
|
||||
(single-valued-reduce? (single-valued e)))))
|
||||
|
||||
(define find-call-lambda-clause
|
||||
(lambda (exp opnds)
|
||||
|
|
@ -2474,7 +2490,7 @@
|
|||
[(call ,preinfo ,pr ,e* ...)
|
||||
(guard (eq? (primref-name pr) 'values))
|
||||
e*]
|
||||
[else (and (single-valued? e)
|
||||
[else (and (single-valued/inspect-ok? e)
|
||||
(list e))]))) =>
|
||||
(lambda (args)
|
||||
; (with-values (values arg ...) c-temp) => (c-temp arg ...)
|
||||
|
|
@ -2666,7 +2682,7 @@
|
|||
[(null? val*) `(quote ,a)]
|
||||
[(eqv? a ident)
|
||||
(if (and (fx= level 3) (null? (cdr val*)) (direct-result? (car val*)))
|
||||
(car val*)
|
||||
(make-nontail (app-ctxt ctxt) (car val*))
|
||||
(if (and (null? (cdr val*))
|
||||
;; `op` may require exactly 2 arguments
|
||||
(eqv? (procedure-arity-mask op) 4))
|
||||
|
|
@ -5480,7 +5496,7 @@
|
|||
[sv? (andmap (lambda (cl)
|
||||
(nanopass-case (Lsrc CaseLambdaClause) cl
|
||||
[(clause (,x* ...) ,interface ,body)
|
||||
(single-valued? body)]))
|
||||
(single-valued/inspect-ok? body)]))
|
||||
cl*)])
|
||||
(when (or (pair? new-cl*) sv?)
|
||||
(update-box! box (make-cte-info
|
||||
|
|
|
|||
|
|
@ -123,8 +123,13 @@ Notes:
|
|||
[(if ,e1 ,e2, e3)
|
||||
(and (sv? e2 fuel)
|
||||
(sv? e3 fuel))]
|
||||
[(call ,preinfo ,e0 ,e* ...)
|
||||
(guard (preinfo-call-single-valued? preinfo))
|
||||
#t]
|
||||
[(call ,preinfo ,pr ,e* ...)
|
||||
(all-set? (prim-mask single-valued) (primref-flags pr))]
|
||||
(let ([flags (primref-flags pr)])
|
||||
(or (all-set? (prim-mask abort-op) flags)
|
||||
(all-set? (prim-mask single-valued) flags)))]
|
||||
[(call ,preinfo1 (case-lambda ,preinfo2 (clause (,x* ...) ,interface ,body)) ,e* ...) ; let-like expressions
|
||||
(guard (fx= interface (length e*)))
|
||||
(sv? body fuel)]
|
||||
|
|
@ -233,6 +238,17 @@ Notes:
|
|||
(all-set? (prim-mask unsafe) (primref-flags pr))))
|
||||
#t]
|
||||
[else #f]))
|
||||
|
||||
(define make-nontail
|
||||
(lambda (ctxt e)
|
||||
(case ctxt
|
||||
[(value)
|
||||
(if (single-valued? e)
|
||||
e
|
||||
`(call ,(make-preinfo-call) ,(lookup-primref 3 '$value) ,e))]
|
||||
[else
|
||||
;; 'test and 'effect contexts cannot have an active attachment
|
||||
e])))
|
||||
|
||||
(define make-seq
|
||||
; ensures that the right subtree of the output seq is not a seq if the
|
||||
|
|
@ -242,7 +258,6 @@ Notes:
|
|||
(make-seq/no-drop ctxt (drop e1) e2)]
|
||||
[(ctxt e1 e2 e3)
|
||||
(make-seq ctxt (make-seq 'effect e1 e2) e3)]))
|
||||
|
||||
|
||||
(define make-seq/no-drop
|
||||
; like make-seq, but don't call drop on the not-last arguments to avoid
|
||||
|
|
@ -252,7 +267,7 @@ Notes:
|
|||
(if (simple? e1)
|
||||
e2
|
||||
(if (and (eq? ctxt 'effect) (simple? e2))
|
||||
e1 ; TODO: double check that it is not necessary to wrap e1 with $value
|
||||
(make-nontail ctxt e1)
|
||||
(nanopass-case (Lsrc Expr) e2
|
||||
[(seq ,e21 ,e22) `(seq (seq ,e1 ,e21) ,e22)]
|
||||
[else `(seq ,e1 ,e2)])))]
|
||||
|
|
@ -634,6 +649,8 @@ Notes:
|
|||
(and (not (check-constant-is? e (lambda (e) #t)))
|
||||
(predicate-implies? x $fixmediate-pred)))
|
||||
|
||||
(define (unwrapped-error ctxt e)
|
||||
(values (make-nontail ctxt e) 'bottom pred-env-bottom #f #f))
|
||||
|
||||
(module ()
|
||||
(with-output-language (Lsrc Expr)
|
||||
|
|
@ -1005,9 +1022,9 @@ Notes:
|
|||
#f #f)]))])
|
||||
|
||||
(define-specialize/unrestricted 2 call-with-values
|
||||
[(e1 e2) (let-values ([(e1 ret1 types1 t-types1 f-types1)
|
||||
[(e1 e2) (let-values ([(e1 ret1 types1 t-types1 f-types1 bottom1?)
|
||||
(Expr/call e1 'value oldtypes oldtypes plxc)])
|
||||
(let-values ([(e2 ret2 types2 t-types2 f-types2)
|
||||
(let-values ([(e2 ret2 types2 t-types2 f-types2 bottom2?)
|
||||
(Expr/call e2 ctxt types1 oldtypes plxc)])
|
||||
(values `(call ,preinfo ,pr ,e1 ,e2)
|
||||
(if (predicate-implies? ret1 'bottom) ; check if necesary
|
||||
|
|
@ -1018,12 +1035,19 @@ Notes:
|
|||
(define-specialize/unrestricted 2 apply
|
||||
[(proc . e*) (let-values ([(e* r* t* t-t* f-t*)
|
||||
(map-values 5 (lambda (e) (Expr e 'value oldtypes plxc)) e*)])
|
||||
(let ([mtypes (fold-left (lambda (f t) (pred-env-intersect/base f t oldtypes)) oldtypes t*)])
|
||||
(let-values ([(proc retproc typesproc t-typesproc f-typesproc)
|
||||
(Expr/call proc ctxt mtypes oldtypes plxc)])
|
||||
(values `(call ,preinfo ,pr ,proc ,e* ...)
|
||||
retproc typesproc t-typesproc f-typesproc))))])
|
||||
|
||||
(cond
|
||||
[(ormap (lambda (e r) (and (predicate-implies? r 'bottom) e)) e* r*)
|
||||
=> (lambda (e) (unwrapped-error ctxt e))]
|
||||
[else
|
||||
(let ([mtypes (fold-left (lambda (f t) (pred-env-intersect/base f t oldtypes)) oldtypes t*)])
|
||||
(let-values ([(proc retproc typesproc t-typesproc f-typesproc proc-bottom?)
|
||||
(Expr/call proc ctxt mtypes oldtypes plxc)])
|
||||
(cond
|
||||
[proc-bottom? (unwrapped-error ctxt proc)]
|
||||
[else
|
||||
(values `(call ,preinfo ,pr ,proc ,e* ...)
|
||||
retproc typesproc t-typesproc f-typesproc)])))]))])
|
||||
|
||||
(define-specialize/unrestricted 2 $apply
|
||||
[(proc n args) (let*-values ([(n rn tn t-tn f-tn)
|
||||
(Expr n 'value oldtypes plxc)]
|
||||
|
|
@ -1040,22 +1064,47 @@ Notes:
|
|||
targs)]
|
||||
[targs (pred-env-add/ref targs args predargs plxc)]
|
||||
[mtypes (pred-env-intersect/base tn targs oldtypes)])
|
||||
(let-values ([(proc retproc typesproc t-typesproc f-typesproc)
|
||||
(let-values ([(proc retproc typesproc t-typesproc f-typesproc proc-bottom?)
|
||||
(Expr/call proc ctxt mtypes oldtypes plxc)])
|
||||
(values `(call ,preinfo ,pr ,proc ,n ,args)
|
||||
retproc typesproc t-typesproc f-typesproc))))])
|
||||
|
||||
(let ()
|
||||
(define (handle-call-attachment preinfo pr e1 e2 ctxt oldtypes plxc body-ctxt)
|
||||
(let-values ([(e1 ret1 types1 t-types1 f-types1)
|
||||
(Expr e1 'value oldtypes plxc)])
|
||||
(cond
|
||||
[(predicate-implies? ret1 'bottom) (unwrapped-error ctxt e1)]
|
||||
[else
|
||||
(let-values ([(e2 ret2 types2 t-types2 f-types2 bottom2?)
|
||||
(Expr/call e2 body-ctxt types1 oldtypes plxc)])
|
||||
(values `(call ,preinfo ,pr ,e1 ,e2)
|
||||
(if (predicate-implies? ret1 'bottom) ; check if necesary
|
||||
'bottom
|
||||
ret2)
|
||||
types2 t-types2 f-types2))])))
|
||||
|
||||
(define-specialize/unrestricted 2 call-setting-continuation-attachment
|
||||
;; body is in 'value context, because called with a mark
|
||||
[(e1 e2) (handle-call-attachment preinfo pr e1 e2 ctxt oldtypes plxc 'value)])
|
||||
|
||||
(define-specialize/unrestricted 2 call-getting-continuation-attachment
|
||||
[(e1 e2) (handle-call-attachment preinfo pr e1 e2 ctxt oldtypes plxc ctxt)])
|
||||
|
||||
(define-specialize/unrestricted 2 call-consuming-continuation-attachment
|
||||
[(e1 e2) (handle-call-attachment preinfo pr e1 e2 ctxt oldtypes plxc ctxt)]))
|
||||
|
||||
(let ()
|
||||
(define (handle-dynamic-wind critical? in body out ctxt oldtypes plxc)
|
||||
(let*-values ([(critical? rcritical? tcritical? t-tcritical? f-tcritical?)
|
||||
(if critical?
|
||||
(Expr critical? 'value oldtypes plxc)
|
||||
(values #f #f oldtypes #f #f))]
|
||||
[(ìn rin tin t-tin f-tin)
|
||||
[(ìn rin tin t-tin f-tin in-bottom?)
|
||||
(Expr/call in 'value tcritical? oldtypes plxc)]
|
||||
[(body rbody tbody t-tbody f-tbody)
|
||||
[(body rbody tbody t-tbody f-tbody body-bottom?)
|
||||
(Expr/call body 'value tin oldtypes plxc)] ; it's almost possible to use ctxt instead of 'value here
|
||||
[(out rout tout t-tout f-tout)
|
||||
[(out rout tout t-tout f-tout out-bottom?)
|
||||
(Expr/call out 'value tin oldtypes plxc)]) ; use tin instead of tbody in case of error or jump.
|
||||
(let* ([n-types (pred-env-intersect/base tbody tout tin)]
|
||||
[t-types (and (eq? ctxt 'test)
|
||||
|
|
@ -1129,35 +1178,39 @@ Notes:
|
|||
(define (fold-primref/next preinfo pr e* ctxt oldtypes plxc)
|
||||
(let-values ([(t e* r* t* t-t* f-t*)
|
||||
(map-Expr/delayed e* oldtypes plxc)])
|
||||
(let* ([len (length e*)]
|
||||
[ret (primref->result-predicate pr len)])
|
||||
(let-values ([(ret t)
|
||||
(let loop ([e* e*] [r* r*] [n 0] [ret ret] [t t])
|
||||
(if (null? e*)
|
||||
(values ret t)
|
||||
(let ([pred (primref->argument-predicate pr n len #t)])
|
||||
(loop (cdr e*)
|
||||
(cdr r*)
|
||||
(fx+ n 1)
|
||||
(if (predicate-disjoint? (car r*) pred)
|
||||
'bottom
|
||||
ret)
|
||||
(pred-env-add/ref t (car e*) pred plxc)))))])
|
||||
(cond
|
||||
[(or (predicate-implies? ret 'bottom)
|
||||
(not (arity-okay? (primref-arity pr) (length e*))))
|
||||
(fold-primref/default preinfo pr e* 'bottom r* ctxt pred-env-bottom oldtypes plxc)]
|
||||
[else
|
||||
(let* ([to-unsafe (and (not (all-set? (prim-mask unsafe) (primref-flags pr)))
|
||||
(all-set? (prim-mask safeongoodargs) (primref-flags pr))
|
||||
(andmap (lambda (r n)
|
||||
(predicate-implies? r
|
||||
(primref->argument-predicate pr n (length e*) #f)))
|
||||
r* (enumerate r*)))]
|
||||
[pr (if to-unsafe
|
||||
(primref->unsafe-primref pr)
|
||||
pr)])
|
||||
(fold-primref/normal preinfo pr e* ret r* ctxt t oldtypes plxc))])))))
|
||||
(cond
|
||||
[(ormap (lambda (e r) (and (predicate-implies? r 'bottom) e)) e* r*)
|
||||
=> (lambda (e) (unwrapped-error ctxt e))]
|
||||
[else
|
||||
(let* ([len (length e*)]
|
||||
[ret (primref->result-predicate pr len)])
|
||||
(let-values ([(ret t)
|
||||
(let loop ([e* e*] [r* r*] [n 0] [ret ret] [t t])
|
||||
(if (null? e*)
|
||||
(values ret t)
|
||||
(let ([pred (primref->argument-predicate pr n len #t)])
|
||||
(loop (cdr e*)
|
||||
(cdr r*)
|
||||
(fx+ n 1)
|
||||
(if (predicate-disjoint? (car r*) pred)
|
||||
'bottom
|
||||
ret)
|
||||
(pred-env-add/ref t (car e*) pred plxc)))))])
|
||||
(cond
|
||||
[(or (predicate-implies? ret 'bottom)
|
||||
(not (arity-okay? (primref-arity pr) (length e*))))
|
||||
(fold-primref/default preinfo pr e* 'bottom r* ctxt pred-env-bottom oldtypes plxc)]
|
||||
[else
|
||||
(let* ([to-unsafe (and (not (all-set? (prim-mask unsafe) (primref-flags pr)))
|
||||
(all-set? (prim-mask safeongoodargs) (primref-flags pr))
|
||||
(andmap (lambda (r n)
|
||||
(predicate-implies? r
|
||||
(primref->argument-predicate pr n (length e*) #f)))
|
||||
r* (enumerate r*)))]
|
||||
[pr (if to-unsafe
|
||||
(primref->unsafe-primref pr)
|
||||
pr)])
|
||||
(fold-primref/normal preinfo pr e* ret r* ctxt t oldtypes plxc))])))])))
|
||||
|
||||
(define (fold-primref/normal preinfo pr e* ret r* ctxt ntypes oldtypes plxc)
|
||||
(cond
|
||||
|
|
@ -1204,26 +1257,30 @@ Notes:
|
|||
(cons (car r*) (loop (fx- i 1) (cdr r*))))))
|
||||
(let*-values ([(ntypes e* r* t* t-t* f-t*)
|
||||
(map-Expr/delayed e* oldtypes plxc)])
|
||||
(nanopass-case (Lsrc Expr) e0
|
||||
[(case-lambda ,preinfo2 (clause (,x** ...) ,interface* ,body*) ...)
|
||||
(let ([len (length e*)])
|
||||
(let loop ([x** x**] [interface* interface*] [body* body*])
|
||||
(cond
|
||||
[(null? interface*)
|
||||
(bad-arity preinfo e0 e* ctxt ntypes)]
|
||||
[else
|
||||
(let ([interface (car interface*)])
|
||||
(cond
|
||||
[(fx< interface 0)
|
||||
(let ([nfixed (fxlognot interface)])
|
||||
(if (fx>= len nfixed)
|
||||
(let ([r* (cut-r* r* nfixed)])
|
||||
(finish preinfo preinfo2 (car x**) interface (car body*) e* r* ntypes))
|
||||
(loop (cdr x**) (cdr interface*) (cdr body*))))]
|
||||
[else
|
||||
(if (fx= interface len)
|
||||
(finish preinfo preinfo2 (car x**) interface (car body*) e* r* ntypes)
|
||||
(loop (cdr x**) (cdr interface*) (cdr body*)))]))])))])))
|
||||
(cond
|
||||
[(ormap (lambda (e r) (and (predicate-implies? r 'bottom) e)) e* r*)
|
||||
=> (lambda (e) (unwrapped-error ctxt e))]
|
||||
[else
|
||||
(nanopass-case (Lsrc Expr) e0
|
||||
[(case-lambda ,preinfo2 (clause (,x** ...) ,interface* ,body*) ...)
|
||||
(let ([len (length e*)])
|
||||
(let loop ([x** x**] [interface* interface*] [body* body*])
|
||||
(cond
|
||||
[(null? interface*)
|
||||
(bad-arity preinfo e0 e* ctxt ntypes)]
|
||||
[else
|
||||
(let ([interface (car interface*)])
|
||||
(cond
|
||||
[(fx< interface 0)
|
||||
(let ([nfixed (fxlognot interface)])
|
||||
(if (fx>= len nfixed)
|
||||
(let ([r* (cut-r* r* nfixed)])
|
||||
(finish preinfo preinfo2 (car x**) interface (car body*) e* r* ntypes))
|
||||
(loop (cdr x**) (cdr interface*) (cdr body*))))]
|
||||
[else
|
||||
(if (fx= interface len)
|
||||
(finish preinfo preinfo2 (car x**) interface (car body*) e* r* ntypes)
|
||||
(loop (cdr x**) (cdr interface*) (cdr body*)))]))])))])])))
|
||||
|
||||
(define (pred-env-triple-filter/base ntypes ttypes ftypes x* ctxt base plxc)
|
||||
(let* ([ttypes (and (not (eq? ntypes ttypes)) ttypes)]
|
||||
|
|
@ -1241,10 +1298,15 @@ Notes:
|
|||
(define (fold-call/other preinfo e0 e* ctxt oldtypes plxc)
|
||||
(let*-values ([(ntypes e* r* t* t-t* f-t*)
|
||||
(map-Expr/delayed e* oldtypes plxc)]
|
||||
[(e0 ret0 types0 t-types0 f-types0)
|
||||
[(e0 ret0 types0 t-types0 f-types0 e0-bottom?)
|
||||
(Expr/call e0 'value ntypes oldtypes plxc)])
|
||||
(values `(call ,preinfo ,e0 ,e* ...)
|
||||
(if (preinfo-call-no-return? preinfo) 'bottom ret0) types0 t-types0 f-types0)))
|
||||
(cond
|
||||
[(or (and e0-bottom? e0)
|
||||
(ormap (lambda (e r) (and (predicate-implies? r 'bottom) e)) e* r*))
|
||||
=> (lambda (e) (unwrapped-error ctxt e))]
|
||||
[else
|
||||
(values `(call ,preinfo ,e0 ,e* ...)
|
||||
(if (preinfo-call-no-return? preinfo) 'bottom ret0) types0 t-types0 f-types0)])))
|
||||
|
||||
(define (map-Expr/delayed e* oldtypes plxc)
|
||||
(define first-pass* (map (lambda (e)
|
||||
|
|
@ -1305,7 +1367,7 @@ Notes:
|
|||
|
||||
(define (Expr/call ir ctxt types outtypes plxc) ; TODO: Add arity
|
||||
(nanopass-case (Lsrc Expr) ir
|
||||
[,pr (values pr (primref->result-predicate pr #f) types #f #f)]
|
||||
[,pr (values pr (primref->result-predicate pr #f) types #f #f #f)]
|
||||
[(case-lambda ,preinfo ,cl* ...)
|
||||
(let loop ([cl* cl*]
|
||||
[rev-rcl* '()]
|
||||
|
|
@ -1317,7 +1379,7 @@ Notes:
|
|||
[(null? cl*)
|
||||
(let ([retcl* (reverse rev-rcl*)])
|
||||
(values `(case-lambda ,preinfo ,retcl* ...)
|
||||
rret rtypes rt-types rf-types))]
|
||||
rret rtypes rt-types rf-types #f))]
|
||||
[else
|
||||
(nanopass-case (Lsrc CaseLambdaClause) (car cl*)
|
||||
[(clause (,x* ...) ,interface ,body)
|
||||
|
|
@ -1375,7 +1437,7 @@ Notes:
|
|||
#f)
|
||||
(pred-env-add/ref (pred-env-intersect/base n-types types outtypes)
|
||||
ir 'procedure plxc)
|
||||
#f #f))]))
|
||||
#f #f (predicate-implies? ret 'bottom)))]))
|
||||
)
|
||||
|
||||
(define-pass cptypes : Lsrc (ir ctxt types plxc) -> Lsrc (ret types t-types f-types)
|
||||
|
|
@ -1410,7 +1472,7 @@ Notes:
|
|||
[(seq ,[e1 'effect types plxc -> e1 ret1 types t-types f-types] ,e2)
|
||||
(cond
|
||||
[(predicate-implies? ret1 'bottom)
|
||||
(values e1 'bottom pred-env-bottom #f #f)]
|
||||
(unwrapped-error ctxt e1)]
|
||||
[else
|
||||
(let-values ([(e2 ret types t-types f-types)
|
||||
(Expr e2 ctxt types plxc)])
|
||||
|
|
@ -1418,7 +1480,7 @@ Notes:
|
|||
[(if ,[Expr/fix-tf-types : e1 'test types plxc -> e1 ret1 types1 t-types1 f-types1] ,e2 ,e3)
|
||||
(cond
|
||||
[(predicate-implies? ret1 'bottom) ;check bottom first
|
||||
(values e1 'bottom pred-env-bottom #f #f)]
|
||||
(unwrapped-error ctxt e1)]
|
||||
[(predicate-implies? ret1 true-pred)
|
||||
(let-values ([(e2 ret types t-types f-types)
|
||||
(Expr e2 ctxt types1 plxc)])
|
||||
|
|
@ -1478,10 +1540,14 @@ Notes:
|
|||
types1
|
||||
new-types)])))])))])]
|
||||
[(set! ,maybe-src ,x ,[e 'value types plxc -> e ret types t-types f-types])
|
||||
(values `(set! ,maybe-src ,x ,(if (non-literal-fixmediate? e ret)
|
||||
`(call ,(make-preinfo-call) ,(lookup-primref 3 '$fixmediate) ,e)
|
||||
e))
|
||||
void-rec types #f #f)]
|
||||
(cond
|
||||
[(predicate-implies? ret 'bottom)
|
||||
(unwrapped-error ctxt e)]
|
||||
[else
|
||||
(values `(set! ,maybe-src ,x ,(if (non-literal-fixmediate? e ret)
|
||||
`(call ,(make-preinfo-call) ,(lookup-primref 3 '$fixmediate) ,e)
|
||||
e))
|
||||
void-rec types #f #f)])]
|
||||
[(call ,preinfo ,pr ,e* ...)
|
||||
(fold-call/primref preinfo pr e* ctxt types plxc)]
|
||||
[(case-lambda ,preinfo ,cl* ...)
|
||||
|
|
|
|||
|
|
@ -1195,12 +1195,12 @@
|
|||
(bytevector-compress [sig [(ptr) -> (ptr)]] [flags])
|
||||
(bytevector-uncompress [sig [(ptr) -> (ptr)]] [flags])
|
||||
(call/1cc [sig [(procedure) -> (ptr ...)]] [flags])
|
||||
(call-consuming-continuation-attachment [sig [(ptr procedure) -> (ptr ...)]] [flags])
|
||||
(call-getting-continuation-attachment [sig [(ptr procedure) -> (ptr ...)]] [flags])
|
||||
(call-consuming-continuation-attachment [sig [(ptr procedure) -> (ptr ...)]] [flags cptypes2x])
|
||||
(call-getting-continuation-attachment [sig [(ptr procedure) -> (ptr ...)]] [flags cptypes2x])
|
||||
(call-in-continuation [sig [(ptr procedure) -> (ptr ...)] [(ptr ptr procedure) -> (ptr ...)]] [flags])
|
||||
(call-with-input-file [sig [(pathname procedure) (pathname procedure sub-ptr) -> (ptr ...)]] [flags ieee r5rs]) ; has options argument
|
||||
(call-with-output-file [sig [(pathname procedure) (pathname procedure sub-ptr) -> (ptr ...)]] [flags ieee r5rs]) ; has options argument
|
||||
(call-setting-continuation-attachment [sig [(ptr procedure) -> (ptr ...)]] [flags])
|
||||
(call-setting-continuation-attachment [sig [(ptr procedure) -> (ptr ...)]] [flags cptypes2x])
|
||||
(cfl* [sig [(cflonum ...) -> (cflonum)]] [flags arith-op partial-folder safeongoodargs])
|
||||
(cfl+ [sig [(cflonum ...) -> (cflonum)]] [flags arith-op partial-folder safeongoodargs])
|
||||
(cfl- [sig [(cflonum cflonum ...) -> (cflonum)]] [flags arith-op partial-folder safeongoodargs])
|
||||
|
|
|
|||
|
|
@ -434,12 +434,16 @@
|
|||
(#2%apply f args)))
|
||||
|
||||
;; Implies no-inline, and in unsafe mode, asserts that the
|
||||
;; application will not return
|
||||
;; application will not return and that it does not inspect/change
|
||||
;; the immediate continuation attachment (so it can be moved to a
|
||||
;; more-tail position)
|
||||
(define $app/no-return
|
||||
(lambda (f . args)
|
||||
(#2%apply f args)))
|
||||
|
||||
;; In unsafe mode, asserts that the applicaiton returns a single value
|
||||
;; and that it does not inspect/change the immediate continuation
|
||||
;; attachment (so it can be moved to a more-tail position)
|
||||
(define $app/value
|
||||
(lambda (f . args)
|
||||
(#2%apply f args)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user