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

cptypes: add fuel for simple? and single-valued?

Browse Source 
So they can recognize easy cases like the expansion of not

(not x) => (if x #f #t)

original commit: 83f43e4fd228c3df503f8ab972aec71efa4ba496
This commit is contained in:
Gustavo Massaccesi 2020-03-23 17:07:52 -03:00
parent a72817e69c
commit 6a964d7600
1 changed files with 59 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

90
s/cptypes.ss
View File

@ -89,38 +89,66 @@ Notes:
(define eof-rec `(quote #!eof)) (define eof-rec `(quote #!eof))
(define bwp-rec `(quote #!bwp)) (define bwp-rec `(quote #!bwp))
(define (simple? e) ; Simplified version copied from cp0. TODO: copy the rest. (module (simple?) ; Simplified version copied from cp0. TODO: copy the rest.
(nanopass-case (Lsrc Expr) e (define default-fuel 5)
[(quote ,d) #t] (define (simple? e)
[(ref ,maybe-src ,x) #t] (sp? e default-fuel))
[(case-lambda ,preinfo ,cl* ...) #t] (define (sp? e fuel)
[,pr #t] (and (fx> fuel 0)
[(moi) #t] (let ([fuel (fx- fuel 1)])
[(record-type ,rtd ,e) (simple? e)] (nanopass-case (Lsrc Expr) e
[else #f] [(quote ,d) #t]
#;[else ($oops who "unrecognized record ~s" e)])) [(if ,e1 ,e2 ,e3)
; useful to recognize the expansion of `not`
(and (sp? e1 fuel) (sp? e2 fuel) (sp? e3 fuel))]
[(ref ,maybe-src ,x) #t]
[(case-lambda ,preinfo ,cl* ...) #t]
[,pr #t]
[(moi) #t]
[(record-type ,rtd ,e) (sp? e fuel)]
[else #f]
#;[else ($oops who "unrecognized record ~s" e)])))))
(define (single-valued? e) (module (single-valued?)
(nanopass-case (Lsrc Expr) e (define default-fuel 5)
[(quote ,d) #t] (define (single-valued? e)
[(call ,preinfo ,pr ,e* ...) (sv? e default-fuel))
(all-set? (prim-mask single-valued) (primref-flags pr))] (define (sv? e fuel)
[(ref ,maybe-src ,x) #t] (and (fx> fuel 0)
[(case-lambda ,preinfo ,cl* ...) #t] (let ([fuel (fx- fuel 1)])
[(set! ,maybe-src ,x ,e) #t] (nanopass-case (Lsrc Expr) e
[(immutable-list (,e* ...) ,e) #t] [(quote ,d) #t]
[,pr #t] [(seq ,e1 ,e2)
[(record-cd ,rcd ,rtd-expr ,e) #t] (sv? e fuel)]
[(record-ref ,rtd ,type ,index ,e) #t] [(if ,e1 ,e2, e3)
[(record-set! ,rtd ,type ,index ,e1 ,e2) #t] (and (sv? e2 fuel)
[(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) #t] (sv? e3 fuel))]
[(record-type ,rtd ,e) #t] [(call ,preinfo ,pr ,e* ...)
[(record ,rtd ,rtd-expr ,e* ...) #t] (all-set? (prim-mask single-valued) (primref-flags pr))]
[(pariah) #t] [(call ,preinfo1 (case-lambda ,preinfo2 (clause (,x* ...) ,interface ,body)) ,e* ...) ; let-like expressions
[(profile ,src) #t] (guard (fx= interface (length e*)))
[(moi) #t] (sv? body fuel)]
[(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) #t] [(letrec ((,x* ,e*) ...) ,body)
[else #f])) (sv? body fuel)]
[(letrec* ((,x* ,e*) ...) ,body)
(sv? body fuel)]
[(ref ,maybe-src ,x) #t]
[(case-lambda ,preinfo ,cl* ...) #t]
[(set! ,maybe-src ,x ,e) #t]
[(immutable-list (,e* ...) ,e) #t]
[,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]
[(moi) #t]
[(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) #t]
[else #f]))))
)
; Reprocess expression when it is changed from a 'value or 'test context ; Reprocess expression when it is changed from a 'value or 'test context
; to a 'effect context, in a reduction like (pair? x) => (begin x #t) ; to a 'effect context, in a reduction like (pair? x) => (begin x #t)