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

Fix call case with rest argument in cptypes

Browse Source 
And add special case for list to reduce
  (pair? (list x y ...)) ==> (begin x y ... #t)

original commit: 196bb8c18b604cd599e154c63f95a9d0117d4d6e
This commit is contained in:
Gustavo Massaccesi 2018-05-24 00:23:52 -03:00
parent 1a9cb566a5
commit 6ff9e9ecd5
2 changed files with 80 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

66
mats/cptypes.ms
View File

@ -26,6 +26,36 @@
#;[optimize-level (max (optimize-level) 2)]) #;[optimize-level (max (optimize-level) 2)])
(expand/optimize y)))])) (expand/optimize y)))]))
(define-syntax cptypes/nocp0-equivalent-expansion?
(syntax-rules ()
[(_ x y)
(equivalent-expansion?
(parameterize ([enable-cp0 #f]
[#%$suppress-primitive-inlining #f]
#;[optimize-level (max (optimize-level) 2)])
(expand/optimize x))
(parameterize ([enable-cp0 #f]
[#%$suppress-primitive-inlining #f]
#;[optimize-level (max (optimize-level) 2)])
(expand/optimize y)))]))
(define-syntax cptypes/nocp0/alternative-equivalent-expansion?
(syntax-rules ()
[(_ x y)
(equivalent-expansion?
(parameterize ([enable-cp0 #f]
[enable-type-recovery #f]
[run-cp0 (lambda (cp0 c) (#3%$cptypes c))]
[#%$suppress-primitive-inlining #f]
#;[optimize-level (max (optimize-level) 2)])
(expand/optimize x))
(parameterize ([enable-cp0 #f]
[enable-type-recovery #f]
[run-cp0 (lambda (cp0 c) (#3%$cptypes c))]
[#%$suppress-primitive-inlining #f]
#;[optimize-level (max (optimize-level) 2)])
(expand/optimize y)))]))
(mat cptypes-handcoded (mat cptypes-handcoded
(cptypes-equivalent-expansion? (cptypes-equivalent-expansion?
'(vector? (vector)) ;actually reduced by folding, not cptypes '(vector? (vector)) ;actually reduced by folding, not cptypes
@ -45,6 +75,12 @@
(cptypes-equivalent-expansion? (cptypes-equivalent-expansion?
'(pair? (cons 1 2)) '(pair? (cons 1 2))
#t) #t)
(cptypes-equivalent-expansion?
'(pair? (list 1 2))
#t)
(cptypes-equivalent-expansion?
'(pair? (list))
#f)
(cptypes-equivalent-expansion? (cptypes-equivalent-expansion?
'(lambda (x) (vector-set! x 0 0) (vector? x)) '(lambda (x) (vector-set! x 0 0) (vector? x))
'(lambda (x) (vector-set! x 0 0) #t)) '(lambda (x) (vector-set! x 0 0) #t))
@ -629,3 +665,33 @@
'(lambda (x) (when (number? x) (#2%odd? x))) '(lambda (x) (when (number? x) (#2%odd? x)))
'(lambda (x) (when (number? x) (#3%odd? x))))) '(lambda (x) (when (number? x) (#3%odd? x)))))
) )
(mat cptypes-rest-argument
(cptypes/nocp0-equivalent-expansion?
'((lambda (x . r) (pair? r)) 1)
'((lambda (x . r) #f) 1))
(cptypes/nocp0-equivalent-expansion?
'((lambda (x . r) (null? r)) 1)
'((lambda (x . r) #t) 1))
(cptypes/nocp0-equivalent-expansion?
'((lambda (x . r) (pair? r)) 1 2)
'((lambda (x . r) #t) 1 2))
(cptypes/nocp0-equivalent-expansion?
'((lambda (x . r) (null? r)) 1 2)
'((lambda (x . r) #f) 1 2))
)
(mat cptypes-rest-argument/alternative
(cptypes/nocp0/alternative-equivalent-expansion?
'((lambda (x . r) (pair? r)) 1)
'((lambda (x . r) #f) 1))
(cptypes/nocp0/alternative-equivalent-expansion?
'((lambda (x . r) (null? r)) 1)
'((lambda (x . r) #t) 1))
(cptypes/nocp0/alternative-equivalent-expansion?
'((lambda (x . r) (pair? r)) 1 2)
'((lambda (x . r) #t) 1 2))
(cptypes/nocp0/alternative-equivalent-expansion?
'((lambda (x . r) (null? r)) 1 2)
'((lambda (x . r) #f) 1 2))
)

18
s/cptypes.ss
View File

@ -195,7 +195,8 @@ Notes:
(set! ret (pred-env-add/key ret key (pred-intersect x z))))) (set! ret (pred-env-add/key ret key (pred-intersect x z)))))
(lambda (key x) (lambda (key x)
(set! ret (pred-env-add/key ret key x))) (set! ret (pred-env-add/key ret key x)))
(lambda (key x) (error 'pred-env-intersect/base "") (void)) (lambda (key x)
($impoops 'pred-env-intersect/base "unexpected value ~s in base environment ~s" x base))
from from
base) base)
ret)])) ret)]))
@ -233,7 +234,8 @@ Notes:
;x-> from ;x-> from
;z-> types ;z-> types
(set! ret (pred-env-add/key ret key (pred-union x z))))) (set! ret (pred-env-add/key ret key (pred-union x z)))))
(lambda (key x) (error 'pred-env-union/base "") (void)) (lambda (key x)
($impoops 'pred-env-union/from "unexpected value ~s in base environment ~s" x base))
from from
base) base)
ret)) ret))
@ -288,7 +290,8 @@ Notes:
(if (eq? x z) (if (eq? x z)
(set! ret (fxmap-reset/base ret key new-base)) (set! ret (fxmap-reset/base ret key new-base))
(set! ret (fxmap-advance/base ret key new-base))))) (set! ret (fxmap-advance/base ret key new-base)))))
(lambda (key x) (error 'pred-env-rebase "") (void)) (lambda (key x)
($impoops 'pred-env-rebase "unexpected value ~s in base environment ~s" x base))
new-base new-base
base) base)
ret)) ret))
@ -843,6 +846,13 @@ Notes:
(pred-env-add/ref types (car e*) pred)) (pred-env-add/ref types (car e*) pred))
#f)]))] #f)]))]
; TODO: special case for call-with-values. ; TODO: special case for call-with-values.
[(eq? (primref-name pr) 'list)
(cond
[(null? e*)
;should have be reduced by cp0
(values null-rec null-rec t #f #f)]
[else
(values `(call ,preinfo ,pr ,e* ...) 'pair t #f #f)])]
[(and (fx= (length e*) 1) [(and (fx= (length e*) 1)
(eq? (primref-name pr) 'exact?)) (eq? (primref-name pr) 'exact?))
(cond (cond
@ -940,7 +950,7 @@ Notes:
(fold-left pred-env-add t x* (fold-left pred-env-add t x*
(let f ([i nfixed] [r* r*]) (let f ([i nfixed] [r* r*])
(if (fx= i 0) (if (fx= i 0)
(list (if (null? r*) 'null 'pair)) (list (if (null? r*) null-rec 'pair))
(cons (car r*) (f (fx- i 1) (cdr r*)))))))) (cons (car r*) (f (fx- i 1) (cdr r*))))))))
(lambda () (values ir 'bottom types #f #f))))] (lambda () (values ir 'bottom types #f #f))))]
[(call ,preinfo ,[e0 'value types -> e0 ret0 types0 t-types0 f-types0] [(call ,preinfo ,[e0 'value types -> e0 ret0 types0 t-types0 f-types0]