cs & schemify: improve folding of procedure? and procedure-arity-includes?
This commit is contained in:
Matthew Flatt
parent
23300fd18d
commit
30eb35b99c
|
|
@ -161,6 +161,8 @@
|
||||||
[`(,es ...)
|
[`(,es ...)
|
||||||
(for/list ([e (in-list es)])
|
(for/list ([e (in-list es)])
|
||||||
(loop e env))]
|
(loop e env))]
|
||||||
|
[`(,e1 . ,e2)
|
||||||
|
(cons (loop e1 env) (loop e2 env))]
|
||||||
[else
|
[else
|
||||||
(hash-ref env s s)])))))
|
(hash-ref env s s)])))))
|
||||||
|
|
||||||
|
|
@ -1001,8 +1003,7 @@
|
||||||
(let ([l (list (random))])
|
(let ([l (list (random))])
|
||||||
(list (unsafe-car l) (unsafe-cdr l))))))
|
(list (unsafe-car l) (unsafe-cdr l))))))
|
||||||
|
|
||||||
(test-comp #:except 'chez-scheme ;; `procedure?` is not primitive
|
(test-comp '(lambda (w z)
|
||||||
'(lambda (w z)
|
|
||||||
(let ([l (if w
|
(let ([l (if w
|
||||||
(lambda () w)
|
(lambda () w)
|
||||||
(lambda () z))])
|
(lambda () z))])
|
||||||
|
|
@ -1750,16 +1751,14 @@
|
||||||
(+ y 1))))
|
(+ y 1))))
|
||||||
|
|
||||||
|
|
||||||
(test-comp #:except 'chez-scheme ; procedure-specialize doesn't inline enough
|
(test-comp '(let ()
|
||||||
'(let ()
|
|
||||||
(define (f x)
|
(define (f x)
|
||||||
(procedure-specialize
|
(procedure-specialize
|
||||||
(lambda (y) (+ x y))))
|
(lambda (y) (+ x y))))
|
||||||
((f 10) 12))
|
((f 10) 12))
|
||||||
'22)
|
'22)
|
||||||
|
|
||||||
(test-comp #:except 'chez-scheme ; procedure-specialize doesn't inline enough
|
(test-comp '(let ()
|
||||||
'(let ()
|
|
||||||
(define (f x)
|
(define (f x)
|
||||||
(procedure-specialize
|
(procedure-specialize
|
||||||
(lambda (y) (+ x y))))
|
(lambda (y) (+ x y))))
|
||||||
|
|
@ -2314,11 +2313,9 @@
|
||||||
'(procedure? add1))
|
'(procedure? add1))
|
||||||
(test-comp '(lambda () #t)
|
(test-comp '(lambda () #t)
|
||||||
'(lambda () (procedure? add1)))
|
'(lambda () (procedure? add1)))
|
||||||
(test-comp #:except 'chez-scheme
|
(test-comp #t
|
||||||
#t
|
|
||||||
'(procedure? (lambda (x) x)))
|
'(procedure? (lambda (x) x)))
|
||||||
(test-comp #:except 'chez-scheme
|
(test-comp '(lambda () #t)
|
||||||
'(lambda () #t)
|
|
||||||
'(lambda () (procedure? (lambda (x) x))))
|
'(lambda () (procedure? (lambda (x) x))))
|
||||||
(test-comp #f
|
(test-comp #f
|
||||||
'(pair? (lambda (x) x)))
|
'(pair? (lambda (x) x)))
|
||||||
|
|
@ -2330,8 +2327,7 @@
|
||||||
88))
|
88))
|
||||||
'(let ([f (lambda (x) x)])
|
'(let ([f (lambda (x) x)])
|
||||||
(list f)))
|
(list f)))
|
||||||
(test-comp #:except 'chez-scheme
|
(test-comp '(let ([f (lambda (x) x)])
|
||||||
'(let ([f (lambda (x) x)])
|
|
||||||
(list
|
(list
|
||||||
f
|
f
|
||||||
f
|
f
|
||||||
|
|
@ -2354,13 +2350,11 @@
|
||||||
|
|
||||||
(test-comp '(lambda (x) #f)
|
(test-comp '(lambda (x) #f)
|
||||||
'(lambda (x) (pair? (if x car cdr))))
|
'(lambda (x) (pair? (if x car cdr))))
|
||||||
(test-comp #:except 'chez-scheme
|
(test-comp '(lambda (x) #t)
|
||||||
'(lambda (x) #t)
|
|
||||||
'(lambda (x) (procedure? (if x car cdr))))
|
'(lambda (x) (procedure? (if x car cdr))))
|
||||||
(test-comp '(lambda (x) #t)
|
(test-comp '(lambda (x) #t)
|
||||||
'(lambda (x) (fixnum? (if x 2 3))))
|
'(lambda (x) (fixnum? (if x 2 3))))
|
||||||
(test-comp #:except 'chez-scheme
|
(test-comp '(lambda (x) #f)
|
||||||
'(lambda (x) #f)
|
|
||||||
'(lambda (x) (procedure? (if x 2 3))))
|
'(lambda (x) (procedure? (if x 2 3))))
|
||||||
|
|
||||||
(test-comp '(lambda ()
|
(test-comp '(lambda ()
|
||||||
|
|
@ -2503,8 +2497,7 @@
|
||||||
(define (q x)
|
(define (q x)
|
||||||
(+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ x 10))))))))))))))
|
(+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ x 10))))))))))))))
|
||||||
|
|
||||||
(unless (eq? 'chez-scheme (system-type 'vm)) ; procedures are not primitivee
|
(let ([check (lambda (proc arities non-arities)
|
||||||
(let ([check (lambda (proc arities non-arities)
|
|
||||||
(test-comp `(procedure? ,proc)
|
(test-comp `(procedure? ,proc)
|
||||||
#t)
|
#t)
|
||||||
(test-comp `(module m racket/base
|
(test-comp `(module m racket/base
|
||||||
|
|
@ -2550,22 +2543,26 @@
|
||||||
(check 'cons '(2) '(0 1 3))
|
(check 'cons '(2) '(0 1 3))
|
||||||
(check 'list '(0 1 2 3) '()))
|
(check 'list '(0 1 2 3) '()))
|
||||||
|
|
||||||
|
(unless (eq? 'chez-scheme (system-type 'vm)) ; procedures are not primitivee
|
||||||
(test-comp '(lambda () (primitive? car))
|
(test-comp '(lambda () (primitive? car))
|
||||||
|
'(lambda () #t)))
|
||||||
|
|
||||||
|
(test-comp '(lambda () (procedure-arity-includes? car 1))
|
||||||
'(lambda () #t))
|
'(lambda () #t))
|
||||||
(test-comp '(lambda () (procedure-arity-includes? car 1))
|
(test-comp '(lambda () (procedure-arity-includes? car 2))
|
||||||
'(lambda () #t))
|
|
||||||
(test-comp '(lambda () (procedure-arity-includes? car 2))
|
|
||||||
'(lambda () #f))
|
'(lambda () #f))
|
||||||
(test-comp '(lambda () (procedure-arity-includes? (begin (random) car) 1))
|
(test-comp #:except 'chez-scheme ; schemify only recognizes immediate identifiers
|
||||||
|
'(lambda () (procedure-arity-includes? (begin (random) car) 1))
|
||||||
'(lambda () (random) #t))
|
'(lambda () (random) #t))
|
||||||
(test-comp '(lambda () (procedure-arity-includes? (begin (random) car) 2))
|
(test-comp #:except 'chez-scheme ; schemify only recognizes immediate identifiers
|
||||||
|
'(lambda () (procedure-arity-includes? (begin (random) car) 2))
|
||||||
'(lambda () (random) #f))
|
'(lambda () (random) #f))
|
||||||
(test-comp '(lambda () (procedure-arity-includes? (begin (random) car) 1))
|
(test-comp '(lambda () (procedure-arity-includes? (begin (random) car) 1))
|
||||||
'(lambda () #t)
|
'(lambda () #t)
|
||||||
#f)
|
#f)
|
||||||
(test-comp '(lambda () (procedure-arity-includes? (begin (random) car) 2))
|
(test-comp '(lambda () (procedure-arity-includes? (begin (random) car) 2))
|
||||||
'(lambda () #f)
|
'(lambda () #f)
|
||||||
#f))
|
#f)
|
||||||
|
|
||||||
(test-comp '(lambda ()
|
(test-comp '(lambda ()
|
||||||
(let ([l '(1 2)])
|
(let ([l '(1 2)])
|
||||||
|
|
@ -2693,7 +2690,7 @@
|
||||||
(test-implies 'k:true-object? 'boolean?)
|
(test-implies 'k:true-object? 'boolean?)
|
||||||
)
|
)
|
||||||
|
|
||||||
(test-comp #:except 'chez-scheme
|
(test-comp #:except 'chez-scheme ; list-pair? is not primitive enough for cptypes
|
||||||
'(lambda (z)
|
'(lambda (z)
|
||||||
(when (and (list? z)
|
(when (and (list? z)
|
||||||
(pair? z))
|
(pair? z))
|
||||||
|
|
@ -2748,7 +2745,6 @@
|
||||||
(not (not z)))
|
(not (not z)))
|
||||||
#t)))
|
#t)))
|
||||||
|
|
||||||
|
|
||||||
(let ([test-reduce
|
(let ([test-reduce
|
||||||
(lambda (pred-name expr [val #t])
|
(lambda (pred-name expr [val #t])
|
||||||
(test-comp `(list ',pred-name (,pred-name ,expr))
|
(test-comp `(list ',pred-name (,pred-name ,expr))
|
||||||
|
|
@ -2757,6 +2753,8 @@
|
||||||
(list ',pred-name e e (,pred-name e)))
|
(list ',pred-name e e (,pred-name e)))
|
||||||
`(let ([e ,expr])
|
`(let ([e ,expr])
|
||||||
(list ',pred-name e e ,val))))])
|
(list ',pred-name e e ,val))))])
|
||||||
|
|
||||||
|
(unless (eq? 'chez-scheme (system-type 'vm)) ; cptypes doesn't yet specialize `list?`
|
||||||
(test-reduce 'list? 0 #f)
|
(test-reduce 'list? 0 #f)
|
||||||
(test-reduce 'list? ''())
|
(test-reduce 'list? ''())
|
||||||
(test-reduce 'list? ''(1))
|
(test-reduce 'list? ''(1))
|
||||||
|
|
@ -2769,7 +2767,7 @@
|
||||||
(test-reduce 'list? '(cons 1 null))
|
(test-reduce 'list? '(cons 1 null))
|
||||||
(test-reduce 'list? '(cons 1 (list 2 3)))
|
(test-reduce 'list? '(cons 1 (list 2 3)))
|
||||||
(test-reduce 'list? '(cdr (list 1 2)))
|
(test-reduce 'list? '(cdr (list 1 2)))
|
||||||
(test-reduce 'list? '(cdr (list 1)))
|
(test-reduce 'list? '(cdr (list 1))))
|
||||||
|
|
||||||
(test-reduce 'null? 0 #f)
|
(test-reduce 'null? 0 #f)
|
||||||
(test-reduce 'null? ''())
|
(test-reduce 'null? ''())
|
||||||
|
|
@ -2815,24 +2813,25 @@
|
||||||
(test-reduce 'k:list-pair? '(cdr (list 1)) #f))
|
(test-reduce 'k:list-pair? '(cdr (list 1)) #f))
|
||||||
)
|
)
|
||||||
|
|
||||||
(test-comp '(lambda (z)
|
(unless (eq? 'chez-scheme (system-type 'vm)) ; cptypes doesn't yet specialize `list?`
|
||||||
|
(test-comp '(lambda (z)
|
||||||
(when (and (list? z) (pair? z))
|
(when (and (list? z) (pair? z))
|
||||||
(list? (cdr z))))
|
(list? (cdr z))))
|
||||||
'(lambda (z)
|
'(lambda (z)
|
||||||
(when (and (list? z) (pair? z))
|
(when (and (list? z) (pair? z))
|
||||||
#t)))
|
#t)))
|
||||||
(test-comp '(lambda (z)
|
(test-comp '(lambda (z)
|
||||||
(when (list? z)
|
(when (list? z)
|
||||||
(list? (unsafe-cdr z))))
|
(list? (unsafe-cdr z))))
|
||||||
'(lambda (z)
|
'(lambda (z)
|
||||||
(when (list? z)
|
(when (list? z)
|
||||||
#t)))
|
#t)))
|
||||||
(test-comp '(lambda (z)
|
(test-comp '(lambda (z)
|
||||||
(when (list? z)
|
(when (list? z)
|
||||||
(list? (cdr z))))
|
(list? (cdr z))))
|
||||||
'(lambda (z)
|
'(lambda (z)
|
||||||
(when (list? z)
|
(when (list? z)
|
||||||
(begin (cdr z) #t))))
|
(begin (cdr z) #t)))))
|
||||||
|
|
||||||
(let ([test-bin
|
(let ([test-bin
|
||||||
(lambda (bin-name)
|
(lambda (bin-name)
|
||||||
|
|
@ -2844,7 +2843,8 @@
|
||||||
(test-bin 'eq?)
|
(test-bin 'eq?)
|
||||||
(test-bin 'eqv?))
|
(test-bin 'eqv?))
|
||||||
|
|
||||||
(for ([middle (in-list (list '(random) ; known immediate
|
(unless (eq? 'chez-scheme (system-type 'vm))
|
||||||
|
(for ([middle (in-list (list '(random) ; known immediate
|
||||||
'(read)))] ; could capture continuation?
|
'(read)))] ; could capture continuation?
|
||||||
[default-same? (in-list (list #t
|
[default-same? (in-list (list #t
|
||||||
#f))])
|
#f))])
|
||||||
|
|
@ -2875,9 +2875,9 @@
|
||||||
(test-move '(box-immutable 1 2) #f)
|
(test-move '(box-immutable 1 2) #f)
|
||||||
(test-move '(quote (1 2)) #t)))
|
(test-move '(quote (1 2)) #t)))
|
||||||
|
|
||||||
;; Check move in to `else` branch where `then`
|
;; Check move in to `else` branch where `then`
|
||||||
;; branch might capture a continuation
|
;; branch might capture a continuation
|
||||||
(test-comp `(lambda (z)
|
(test-comp `(lambda (z)
|
||||||
(let ([x (cons 1 2)])
|
(let ([x (cons 1 2)])
|
||||||
(if z
|
(if z
|
||||||
(read)
|
(read)
|
||||||
|
|
@ -2885,7 +2885,8 @@
|
||||||
`(lambda (z)
|
`(lambda (z)
|
||||||
(if z
|
(if z
|
||||||
(read)
|
(read)
|
||||||
(cons 1 2))))
|
(cons 1 2)))))
|
||||||
|
|
||||||
;; But not after the merge:
|
;; But not after the merge:
|
||||||
(test-comp `(lambda (z)
|
(test-comp `(lambda (z)
|
||||||
(let ([x (cons 1 2)])
|
(let ([x (cons 1 2)])
|
||||||
|
|
@ -2911,9 +2912,11 @@
|
||||||
(,unsafe-op x)
|
(,unsafe-op x)
|
||||||
(cdr x))))
|
(cdr x))))
|
||||||
(test-comp `(lambda (x)
|
(test-comp `(lambda (x)
|
||||||
(list (,op x) (,op x)))
|
(let ([a (,op x)])
|
||||||
|
(list a (,op x))))
|
||||||
`(lambda (x)
|
`(lambda (x)
|
||||||
(list (,op x) (,unsafe-op x)))
|
(let ([a (,op x)])
|
||||||
|
(list a (,unsafe-op x))))
|
||||||
savetype)
|
savetype)
|
||||||
(test-comp `(lambda (x)
|
(test-comp `(lambda (x)
|
||||||
(if (and (,pred x)
|
(if (and (,pred x)
|
||||||
|
|
@ -2932,22 +2935,23 @@
|
||||||
(test-use-unsafe 'pair? 'cdr 'unsafe-cdr)
|
(test-use-unsafe 'pair? 'cdr 'unsafe-cdr)
|
||||||
(test-use-unsafe 'mpair? 'mcar 'unsafe-mcar)
|
(test-use-unsafe 'mpair? 'mcar 'unsafe-mcar)
|
||||||
(test-use-unsafe 'mpair? 'mcdr 'unsafe-mcdr)
|
(test-use-unsafe 'mpair? 'mcdr 'unsafe-mcdr)
|
||||||
|
(unless (eq? 'chez-scheme (system-type 'vm)) ; impersonators currently get in the way
|
||||||
(test-use-unsafe 'box? 'unbox 'unsafe-unbox)
|
(test-use-unsafe 'box? 'unbox 'unsafe-unbox)
|
||||||
(test-use-unsafe 'vector? 'vector-length 'unsafe-vector-length)
|
(test-use-unsafe 'vector? 'vector-length 'unsafe-vector-length))
|
||||||
(test-use-unsafe 'string? 'string-length 'unsafe-string-length)
|
(test-use-unsafe 'string? 'string-length 'unsafe-string-length)
|
||||||
(test-use-unsafe 'bytes? 'bytes-length 'unsafe-bytes-length)
|
(test-use-unsafe 'bytes? 'bytes-length 'unsafe-bytes-length)
|
||||||
(test-use-unsafe/savetype 'fixnum? 'bitwise-not 'unsafe-fxnot #f)
|
(test-use-unsafe/savetype 'fixnum? 'bitwise-not 'unsafe-fxnot #f)
|
||||||
(test-use-unsafe/savetype 'fixnum? 'fxnot 'unsafe-fxnot #f))
|
(test-use-unsafe/savetype 'fixnum? 'fxnot 'unsafe-fxnot (not (eq? 'racket (system-type 'vm)))))
|
||||||
|
|
||||||
(let ([test-use-unsafe-fxbinary
|
(let ([test-use-unsafe-fxbinary
|
||||||
(lambda (op unsafe-op)
|
(lambda (op unsafe-op)
|
||||||
(test-comp `(lambda (vx vy)
|
(test-comp `(lambda (vx vy)
|
||||||
(let ([x (vector-length vx)]
|
(let ([x (string-length vx)]
|
||||||
[y (vector-length vy)])
|
[y (string-length vy)])
|
||||||
(,op x y)))
|
(,op x y)))
|
||||||
`(lambda (vx vy)
|
`(lambda (vx vy)
|
||||||
(let ([x (vector-length vx)]
|
(let ([x (string-length vx)]
|
||||||
[y (vector-length vy)])
|
[y (string-length vy)])
|
||||||
(,unsafe-op x y))))
|
(,unsafe-op x y))))
|
||||||
(test-comp `(lambda (x y)
|
(test-comp `(lambda (x y)
|
||||||
(when (and (fixnum? x) (fixnum? y))
|
(when (and (fixnum? x) (fixnum? y))
|
||||||
|
|
@ -2968,13 +2972,14 @@
|
||||||
(test-use-unsafe-fxbinary 'fxior 'unsafe-fxior)
|
(test-use-unsafe-fxbinary 'fxior 'unsafe-fxior)
|
||||||
(test-use-unsafe-fxbinary 'fxxor 'unsafe-fxxor)
|
(test-use-unsafe-fxbinary 'fxxor 'unsafe-fxxor)
|
||||||
|
|
||||||
|
(unless (eq? 'chez-scheme (system-type 'vm)) ; cptypes doesn't currently convert to fixnum ops
|
||||||
(test-use-unsafe-fxbinary '= 'unsafe-fx=)
|
(test-use-unsafe-fxbinary '= 'unsafe-fx=)
|
||||||
(test-use-unsafe-fxbinary '< 'unsafe-fx<)
|
(test-use-unsafe-fxbinary '< 'unsafe-fx<)
|
||||||
(test-use-unsafe-fxbinary '> 'unsafe-fx>)
|
(test-use-unsafe-fxbinary '> 'unsafe-fx>)
|
||||||
(test-use-unsafe-fxbinary '<= 'unsafe-fx<=)
|
(test-use-unsafe-fxbinary '<= 'unsafe-fx<=)
|
||||||
(test-use-unsafe-fxbinary '>= 'unsafe-fx>=)
|
(test-use-unsafe-fxbinary '>= 'unsafe-fx>=)
|
||||||
(test-use-unsafe-fxbinary 'min 'unsafe-fxmin)
|
(test-use-unsafe-fxbinary 'min 'unsafe-fxmin)
|
||||||
(test-use-unsafe-fxbinary 'max 'unsafe-fxmax)
|
(test-use-unsafe-fxbinary 'max 'unsafe-fxmax))
|
||||||
|
|
||||||
(test-use-unsafe-fxbinary 'fx= 'unsafe-fx=)
|
(test-use-unsafe-fxbinary 'fx= 'unsafe-fx=)
|
||||||
(test-use-unsafe-fxbinary 'fx< 'unsafe-fx<)
|
(test-use-unsafe-fxbinary 'fx< 'unsafe-fx<)
|
||||||
|
|
@ -2984,52 +2989,55 @@
|
||||||
(test-use-unsafe-fxbinary 'fxmin 'unsafe-fxmin)
|
(test-use-unsafe-fxbinary 'fxmin 'unsafe-fxmin)
|
||||||
(test-use-unsafe-fxbinary 'fxmax 'unsafe-fxmax))
|
(test-use-unsafe-fxbinary 'fxmax 'unsafe-fxmax))
|
||||||
|
|
||||||
(test-comp '(lambda (vx)
|
(unless (eq? 'chez-scheme (system-type 'vm)) ; cptypes doesn't currently convert to fixnum ops
|
||||||
(let ([x (vector-length vx)])
|
(test-comp '(lambda (vx)
|
||||||
|
(let ([x (string-length vx)])
|
||||||
(zero? x)))
|
(zero? x)))
|
||||||
'(lambda (vx)
|
'(lambda (vx)
|
||||||
(let ([x (vector-length vx)])
|
(let ([x (string-length vx)])
|
||||||
(unsafe-fx= x 0))))
|
(unsafe-fx= x 0))))
|
||||||
(test-comp '(lambda (x)
|
(test-comp '(lambda (x)
|
||||||
(when (fixnum? x)
|
(when (fixnum? x)
|
||||||
(zero? x)))
|
(zero? x)))
|
||||||
'(lambda (x)
|
'(lambda (x)
|
||||||
(when (fixnum? x)
|
(when (fixnum? x)
|
||||||
(unsafe-fx= x 0))))
|
(unsafe-fx= x 0))))
|
||||||
(test-comp '(lambda (x)
|
(test-comp '(lambda (x)
|
||||||
(when (and (fixnum? x) (zero? (random 2)))
|
(when (and (fixnum? x) (zero? (random 2)))
|
||||||
(zero? x)))
|
(zero? x)))
|
||||||
'(lambda (x)
|
'(lambda (x)
|
||||||
(when (and (fixnum? x) (zero? (random 2)))
|
(when (and (fixnum? x) (zero? (random 2)))
|
||||||
(unsafe-fx= x 0))))
|
(unsafe-fx= x 0)))))
|
||||||
|
|
||||||
;test special case for bitwise-and and fixnum?
|
(unless (eq? 'chez-scheme (system-type 'vm)) ; cptypes doesn't currently convert to fixnum ops
|
||||||
(test-comp '(lambda (x)
|
;test special case for bitwise-and and fixnum?
|
||||||
|
(test-comp '(lambda (x)
|
||||||
(let ([y (bitwise-and x 2)])
|
(let ([y (bitwise-and x 2)])
|
||||||
(list y y (fixnum? y))))
|
(list y y (fixnum? y))))
|
||||||
'(lambda (x)
|
'(lambda (x)
|
||||||
(let ([y (bitwise-and x 2)])
|
(let ([y (bitwise-and x 2)])
|
||||||
(list y y #t))))
|
(list y y #t))))
|
||||||
(test-comp '(lambda (x)
|
(test-comp '(lambda (x)
|
||||||
(let ([y (bitwise-and x 2)])
|
(let ([y (bitwise-and x 2)])
|
||||||
(fixnum? x)))
|
(fixnum? x)))
|
||||||
'(lambda (x)
|
'(lambda (x)
|
||||||
(let ([y (bitwise-and x 2)])
|
(let ([y (bitwise-and x 2)])
|
||||||
#t))
|
#t))
|
||||||
#f)
|
#f))
|
||||||
|
|
||||||
;; Make sure that `bitwise-and` is known to return a fixnum for non-negative
|
(unless (eq? 'chez-scheme (system-type 'vm)) ; no literal specializations right now
|
||||||
;; fixnum arguments but not for a negative one
|
;; Make sure that `bitwise-and` is known to return a fixnum for non-negative
|
||||||
|
;; fixnum arguments but not for a negative one
|
||||||
|
|
||||||
(test-comp '(lambda (x)
|
(test-comp '(lambda (x)
|
||||||
(bitwise-ior (bitwise-and x 7) 1))
|
(bitwise-ior (bitwise-and x 7) 1))
|
||||||
'(lambda (x)
|
'(lambda (x)
|
||||||
(unsafe-fxior (bitwise-and x 7) 1)))
|
(unsafe-fxior (bitwise-and x 7) 1)))
|
||||||
(test-comp '(lambda (x)
|
(test-comp '(lambda (x)
|
||||||
(bitwise-ior (bitwise-and x -7) 1))
|
(bitwise-ior (bitwise-and x -7) 1))
|
||||||
'(lambda (x)
|
'(lambda (x)
|
||||||
(unsafe-fxior (bitwise-and x -7) 1))
|
(unsafe-fxior (bitwise-and x -7) 1))
|
||||||
#f)
|
#f))
|
||||||
|
|
||||||
|
|
||||||
(test-comp `(lambda (x)
|
(test-comp `(lambda (x)
|
||||||
|
|
@ -3044,26 +3052,37 @@
|
||||||
(cdr x)))
|
(cdr x)))
|
||||||
#f)
|
#f)
|
||||||
|
|
||||||
;; + fold to fixnum overflow, fx+ doesn't
|
(let ([width (case (system-type 'vm)
|
||||||
(test-comp `(module m racket/base
|
[(chez-scheme)
|
||||||
(+ (sub1 (expt 2 30)) (sub1 (expt 2 30))))
|
;; Need machine-specific fixnum bound:
|
||||||
|
(case (system-type 'word)
|
||||||
|
[(32) 29]
|
||||||
|
[(64) 60])]
|
||||||
|
[else
|
||||||
|
;; Racket compiles independent of current machine:
|
||||||
|
30])])
|
||||||
|
;; + fold to fixnum overflow, fx+ doesn't
|
||||||
|
(test-comp `(module m racket/base
|
||||||
|
(+ (sub1 (expt 2 ,width)) (sub1 (expt 2 ,width))))
|
||||||
`(module m racket/base
|
`(module m racket/base
|
||||||
(- (expt 2 31) 2)))
|
(- (expt 2 ,(+ width 1)) 2)))
|
||||||
(test-comp `(module m racket/base
|
(test-comp `(module m racket/base
|
||||||
(require racket/fixnum)
|
(require racket/fixnum)
|
||||||
(fx+ (sub1 (expt 2 30)) (sub1 (expt 2 30))))
|
(fx+ (sub1 (expt 2 ,width)) (sub1 (expt 2 ,width))))
|
||||||
`(module m racket/base
|
`(module m racket/base
|
||||||
(require racket/fixnum)
|
(require racket/fixnum)
|
||||||
(- (expt 2 31) 2))
|
(- (expt 2 ,(+ width 1)) 2))
|
||||||
#f)
|
#f))
|
||||||
|
|
||||||
;; Propagate type implications from RHS:
|
;; Propagate type implications from RHS:
|
||||||
(test-comp '(lambda (x)
|
(test-comp '(lambda (x)
|
||||||
(let ([y (car x)])
|
(let ([y (car x)])
|
||||||
(list (cdr x) y (car x) y)))
|
(let ([a (cdr x)])
|
||||||
|
(list a y (car x) y))))
|
||||||
'(lambda (x)
|
'(lambda (x)
|
||||||
(let ([y (car x)])
|
(let ([y (car x)])
|
||||||
(list (unsafe-cdr x) y (unsafe-car x) y))))
|
(let ([a (unsafe-cdr x)])
|
||||||
|
(list a y (unsafe-car x) y)))))
|
||||||
|
|
||||||
;; don't duplicate an operation by moving it into a lambda':
|
;; don't duplicate an operation by moving it into a lambda':
|
||||||
(test-comp '(lambda (x)
|
(test-comp '(lambda (x)
|
||||||
|
|
@ -3103,7 +3122,8 @@
|
||||||
(f)
|
(f)
|
||||||
(list x))
|
(list x))
|
||||||
#f)
|
#f)
|
||||||
(test-comp '(lambda (f x)
|
(test-comp #:except 'chez-scheme
|
||||||
|
'(lambda (f x)
|
||||||
(let ([y (list x)])
|
(let ([y (list x)])
|
||||||
(random)
|
(random)
|
||||||
y))
|
y))
|
||||||
|
|
|
||||||
|
|
@ -31,7 +31,10 @@
|
||||||
(define (procedure? v)
|
(define (procedure? v)
|
||||||
(or (#%procedure? v)
|
(or (#%procedure? v)
|
||||||
(and (record? v)
|
(and (record? v)
|
||||||
(not (eq? (struct-property-ref prop:procedure (record-rtd v) none) none)))))
|
(#%$app/no-inline struct-procedure? v))))
|
||||||
|
|
||||||
|
(define (struct-procedure? v)
|
||||||
|
(not (eq? (struct-property-ref prop:procedure (record-rtd v) none) none)))
|
||||||
|
|
||||||
(define/who (procedure-specialize proc)
|
(define/who (procedure-specialize proc)
|
||||||
(check who procedure? proc)
|
(check who procedure? proc)
|
||||||
|
|
|
||||||
File diff suppressed because it is too large
Load Diff
|
|
@ -11,6 +11,7 @@
|
||||||
"mutated-state.rkt"
|
"mutated-state.rkt"
|
||||||
"optimize.rkt"
|
"optimize.rkt"
|
||||||
"single-valued.rkt"
|
"single-valued.rkt"
|
||||||
|
"lambda.rkt"
|
||||||
"aim.rkt")
|
"aim.rkt")
|
||||||
|
|
||||||
(provide infer-known
|
(provide infer-known
|
||||||
|
|
@ -105,68 +106,6 @@
|
||||||
|
|
||||||
;; ----------------------------------------
|
;; ----------------------------------------
|
||||||
|
|
||||||
;; Recognize forms that produce plain procedures; expression can be
|
|
||||||
;; pre- or post-schemify
|
|
||||||
(define (lambda? v #:simple? [simple? #f])
|
|
||||||
(match v
|
|
||||||
[`(lambda . ,_) #t]
|
|
||||||
[`(case-lambda . ,_) #t]
|
|
||||||
[`(let-values ([(,id) ,rhs]) ,body) (let-lambda? id rhs body #:simple? simple?)]
|
|
||||||
[`(letrec-values ([(,id) ,rhs]) ,body) (let-lambda? id rhs body #:simple? simple?)]
|
|
||||||
[`(let ([,id ,rhs]) ,body) (let-lambda? id rhs body #:simple? simple?)]
|
|
||||||
[`(letrec* ([,id ,rhs]) ,body) (let-lambda? id rhs body #:simple? simple?)]
|
|
||||||
[`(let-values ,_ ,body) (and (not simple?) (lambda? body))]
|
|
||||||
[`(letrec-values ,_ ,body) (and (not simple?) (lambda? body))]
|
|
||||||
[`(begin ,body) (lambda? body #:simple? simple?)]
|
|
||||||
[`(values ,body) (lambda? body #:simple? simple?)]
|
|
||||||
[`,_ #f]))
|
|
||||||
|
|
||||||
(define (let-lambda? id rhs body #:simple? simple?)
|
|
||||||
(or (and (wrap-eq? id body) (lambda? rhs #:simple? simple?))
|
|
||||||
(and (not simple?)
|
|
||||||
(lambda? body #:simple? simple?))))
|
|
||||||
|
|
||||||
;; Extract procedure from a form on which `lambda?` produces true
|
|
||||||
(define (extract-lambda v)
|
|
||||||
(match v
|
|
||||||
[`(lambda . ,_) (values v #t)]
|
|
||||||
[`(case-lambda . ,_) (values v #t)]
|
|
||||||
[`(let-values ([(,id) ,rhs]) ,body) (extract-let-lambda #f id rhs body)]
|
|
||||||
[`(letrec-values ([(,id) ,rhs]) ,body) (extract-let-lambda #t id rhs body)]
|
|
||||||
[`(let ([,id ,rhs]) ,body) (extract-let-lambda #f id rhs body)]
|
|
||||||
[`(letrec* ([,id ,rhs]) ,body) (extract-let-lambda #t id rhs body)]
|
|
||||||
[`(let-values ,_ ,body) (extract-lambda* body)]
|
|
||||||
[`(letrec-values ,_ ,body) (extract-lambda* body)]
|
|
||||||
[`(let ,_ ,body) (extract-lambda* body)]
|
|
||||||
[`(letrec* ,_ ,body) (extract-lambda* body)]
|
|
||||||
[`(begin ,body) (extract-lambda body)]
|
|
||||||
[`(values ,body) (extract-lambda body)]))
|
|
||||||
|
|
||||||
(define (extract-let-lambda rec? id rhs body)
|
|
||||||
(if (wrap-eq? id body)
|
|
||||||
(if rec?
|
|
||||||
(extract-lambda* rhs)
|
|
||||||
(extract-lambda rhs))
|
|
||||||
(extract-lambda* body)))
|
|
||||||
|
|
||||||
(define (extract-lambda* v)
|
|
||||||
(define-values (lam inlinable?) (extract-lambda v))
|
|
||||||
(values lam #f))
|
|
||||||
|
|
||||||
(define (lambda-arity-mask v)
|
|
||||||
(match v
|
|
||||||
[`(lambda ,args . ,_) (args-arity-mask args)]
|
|
||||||
[`(case-lambda [,argss . ,_] ...)
|
|
||||||
(for/fold ([mask 0]) ([args (in-list argss)])
|
|
||||||
(bitwise-ior mask (args-arity-mask args)))]))
|
|
||||||
|
|
||||||
(define (args-arity-mask args)
|
|
||||||
(cond
|
|
||||||
[(wrap-null? args) 1]
|
|
||||||
[(wrap-pair? args)
|
|
||||||
(arithmetic-shift (args-arity-mask (wrap-cdr args)) 1)]
|
|
||||||
[else -1]))
|
|
||||||
|
|
||||||
(define (add-begin-unsafe lam)
|
(define (add-begin-unsafe lam)
|
||||||
(reannotate
|
(reannotate
|
||||||
lam
|
lam
|
||||||
|
|
|
||||||
80
racket/src/schemify/lambda.rkt
Normal file
80
racket/src/schemify/lambda.rkt
Normal file
|
|
@ -0,0 +1,80 @@
|
||||||
|
#lang racket/base
|
||||||
|
(require "wrap.rkt"
|
||||||
|
"match.rkt")
|
||||||
|
|
||||||
|
(provide lambda?
|
||||||
|
extract-lambda
|
||||||
|
lambda-arity-mask)
|
||||||
|
|
||||||
|
;; ----------------------------------------
|
||||||
|
|
||||||
|
;; Recognize forms that produce plain procedures; expression can be
|
||||||
|
;; pre- or post-schemify
|
||||||
|
(define (lambda? v #:simple? [simple? #f])
|
||||||
|
(match v
|
||||||
|
[`(lambda . ,_) #t]
|
||||||
|
[`(case-lambda . ,_) #t]
|
||||||
|
[`(let-values ([(,id) ,rhs]) ,body) (let-lambda? id rhs body #:simple? simple?)]
|
||||||
|
[`(letrec-values ([(,id) ,rhs]) ,body) (let-lambda? id rhs body #:simple? simple?)]
|
||||||
|
[`(let ([,id ,rhs]) ,body) (let-lambda? id rhs body #:simple? simple?)]
|
||||||
|
[`(letrec* ([,id ,rhs]) ,body) (let-lambda? id rhs body #:simple? simple?)]
|
||||||
|
[`(let-values ,_ ,body) (and (not simple?) (lambda? body))]
|
||||||
|
[`(letrec-values ,_ ,body) (and (not simple?) (lambda? body))]
|
||||||
|
[`(begin ,body) (lambda? body #:simple? simple?)]
|
||||||
|
[`(begin . ,bodys) (and (not simple?)
|
||||||
|
(let loop ([bodys bodys])
|
||||||
|
(if (null? (cdr bodys))
|
||||||
|
(lambda? (car bodys) #:simple? simple?)
|
||||||
|
(loop (cdr bodys)))))]
|
||||||
|
[`(values ,body) (lambda? body #:simple? simple?)]
|
||||||
|
[`,_ #f]))
|
||||||
|
|
||||||
|
(define (let-lambda? id rhs body #:simple? simple?)
|
||||||
|
(or (and (wrap-eq? id body) (lambda? rhs #:simple? simple?))
|
||||||
|
(and (not simple?)
|
||||||
|
(lambda? body #:simple? simple?))))
|
||||||
|
|
||||||
|
;; Extract procedure from a form on which `lambda?` produces true
|
||||||
|
(define (extract-lambda v)
|
||||||
|
(match v
|
||||||
|
[`(lambda . ,_) (values v #t)]
|
||||||
|
[`(case-lambda . ,_) (values v #t)]
|
||||||
|
[`(let-values ([(,id) ,rhs]) ,body) (extract-let-lambda #f id rhs body)]
|
||||||
|
[`(letrec-values ([(,id) ,rhs]) ,body) (extract-let-lambda #t id rhs body)]
|
||||||
|
[`(let ([,id ,rhs]) ,body) (extract-let-lambda #f id rhs body)]
|
||||||
|
[`(letrec* ([,id ,rhs]) ,body) (extract-let-lambda #t id rhs body)]
|
||||||
|
[`(let-values ,_ ,body) (extract-lambda* body)]
|
||||||
|
[`(letrec-values ,_ ,body) (extract-lambda* body)]
|
||||||
|
[`(let ,_ ,body) (extract-lambda* body)]
|
||||||
|
[`(letrec* ,_ ,body) (extract-lambda* body)]
|
||||||
|
[`(begin ,body) (extract-lambda body)]
|
||||||
|
[`(begin . ,bodys) (let loop ([bodys bodys])
|
||||||
|
(if (null? (cdr bodys))
|
||||||
|
(extract-lambda* (car bodys))
|
||||||
|
(loop (cdr bodys))))]
|
||||||
|
[`(values ,body) (extract-lambda body)]))
|
||||||
|
|
||||||
|
(define (extract-let-lambda rec? id rhs body)
|
||||||
|
(if (wrap-eq? id body)
|
||||||
|
(if rec?
|
||||||
|
(extract-lambda* rhs)
|
||||||
|
(extract-lambda rhs))
|
||||||
|
(extract-lambda* body)))
|
||||||
|
|
||||||
|
(define (extract-lambda* v)
|
||||||
|
(define-values (lam inlinable?) (extract-lambda v))
|
||||||
|
(values lam #f))
|
||||||
|
|
||||||
|
(define (lambda-arity-mask v)
|
||||||
|
(match v
|
||||||
|
[`(lambda ,args . ,_) (args-arity-mask args)]
|
||||||
|
[`(case-lambda [,argss . ,_] ...)
|
||||||
|
(for/fold ([mask 0]) ([args (in-list argss)])
|
||||||
|
(bitwise-ior mask (args-arity-mask args)))]))
|
||||||
|
|
||||||
|
(define (args-arity-mask args)
|
||||||
|
(cond
|
||||||
|
[(wrap-null? args) 1]
|
||||||
|
[(wrap-pair? args)
|
||||||
|
(arithmetic-shift (args-arity-mask (wrap-cdr args)) 1)]
|
||||||
|
[else -1]))
|
||||||
|
|
@ -6,6 +6,8 @@
|
||||||
"find-known.rkt"
|
"find-known.rkt"
|
||||||
"mutated-state.rkt"
|
"mutated-state.rkt"
|
||||||
"literal.rkt"
|
"literal.rkt"
|
||||||
|
"lambda.rkt"
|
||||||
|
"simple.rkt"
|
||||||
"fold.rkt")
|
"fold.rkt")
|
||||||
|
|
||||||
(provide optimize
|
(provide optimize
|
||||||
|
|
@ -28,6 +30,13 @@
|
||||||
`,(not (unwrap t))
|
`,(not (unwrap t))
|
||||||
v)]
|
v)]
|
||||||
[`(procedure? ,e)
|
[`(procedure? ,e)
|
||||||
|
(cond
|
||||||
|
[(lambda? e)
|
||||||
|
(define-values (lam inlinable?) (extract-lambda e))
|
||||||
|
(if inlinable?
|
||||||
|
#t
|
||||||
|
`(begin ,e #t))]
|
||||||
|
[else
|
||||||
(define u (unwrap e))
|
(define u (unwrap e))
|
||||||
(cond
|
(cond
|
||||||
[(symbol? u)
|
[(symbol? u)
|
||||||
|
|
@ -35,19 +44,33 @@
|
||||||
(if (known-procedure? k)
|
(if (known-procedure? k)
|
||||||
'#t
|
'#t
|
||||||
v)]
|
v)]
|
||||||
[else v])]
|
[else v])])]
|
||||||
[`(procedure-arity-includes? ,e ,n)
|
[`(procedure-arity-includes? ,e ,n . ,opt)
|
||||||
(define u (unwrap e))
|
|
||||||
(define u-n (unwrap n))
|
(define u-n (unwrap n))
|
||||||
(cond
|
(cond
|
||||||
[(and (symbol? u)
|
[(and (exact-nonnegative-integer? n)
|
||||||
(exact-nonnegative-integer? n))
|
(or (null? opt)
|
||||||
|
(and (null? (cdr opt))
|
||||||
|
(literal? (car opt)))))
|
||||||
|
(cond
|
||||||
|
[(lambda? e)
|
||||||
|
(define-values (lam inlinable?) (extract-lambda e))
|
||||||
|
(define inc? (bitwise-bit-set? (lambda-arity-mask lam) n))
|
||||||
|
(if inlinable?
|
||||||
|
inc?
|
||||||
|
`(begin ,e ,inc?))]
|
||||||
|
[else
|
||||||
|
(define u (unwrap e))
|
||||||
|
(cond
|
||||||
|
[(symbol? u)
|
||||||
(define k (find-known u prim-knowns knowns imports mutated))
|
(define k (find-known u prim-knowns knowns imports mutated))
|
||||||
(if (and (known-procedure? k)
|
(if (known-procedure? k)
|
||||||
(bitwise-bit-set? (known-procedure-arity-mask k) u-n))
|
(bitwise-bit-set? (known-procedure-arity-mask k) u-n)
|
||||||
'#t
|
|
||||||
v)]
|
v)]
|
||||||
|
[else v])])]
|
||||||
[else v])]
|
[else v])]
|
||||||
|
[`(procedure-specialize ,e)
|
||||||
|
(if (lambda? e) e v)]
|
||||||
[`(,rator . ,rands)
|
[`(,rator . ,rands)
|
||||||
(define u-rator (unwrap rator))
|
(define u-rator (unwrap rator))
|
||||||
(define k (and (symbol? u-rator) (hash-ref prim-knowns u-rator #f)))
|
(define k (and (symbol? u-rator) (hash-ref prim-knowns u-rator #f)))
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user