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

cp0 loop adjustment for letrec*

Browse Source 
original commit: b89cf40dcfd25c382bdb3190f46916ccc63a841e
This commit is contained in:
Matthew Flatt 2020-06-14 16:51:39 -06:00
parent af04af5aa3
commit 1bc51a7ba4
1 changed files with 13 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
s/cp0.ss
View File

@ -503,6 +503,12 @@
(loop e2 (if eprof `(seq ,eprof ,e1) e1))] (loop e2 (if eprof `(seq ,eprof ,e1) e1))]
[else (values e eprof)])) [else (values e eprof)]))
(values e #f)))) (values e #f))))
(define (possible-loop? x* body)
(and (fx= (length x*) 1)
(nanopass-case (Lsrc Expr) body
[(call ,preinfo (ref ,maybe-src ,x) ,e* ...)
(eq? x (car x*))]
[else #f])))
; set up to assimilate nested let/letrec/letrec* bindings. ; set up to assimilate nested let/letrec/letrec* bindings.
; lifting job is completed by cp0-call or letrec/letrec* ; lifting job is completed by cp0-call or letrec/letrec*
(define (split-value e) (define (split-value e)
@ -557,11 +563,7 @@
[(letrec ([,x* ,e*] ...) ,body) [(letrec ([,x* ,e*] ...) ,body)
(guard (and (or (ivory? body) (andmap ivory1? e*)) (guard (and (or (ivory? body) (andmap ivory1? e*))
;; don't break apart (potential) loops ;; don't break apart (potential) loops
(not (and (fx= (length x*) 1) (not (possible-loop? x* body))))
(nanopass-case (Lsrc Expr) body
[(call ,preinfo (ref ,maybe-src ,x) ,e* ...)
(eq? x (car x*))]
[else #f])))))
; assocate each lhs with cooked operand for corresponding rhs. see note above. ; assocate each lhs with cooked operand for corresponding rhs. see note above.
(for-each (lambda (x e) (prelex-operand-set! x (build-cooked-opnd e))) x* e*) (for-each (lambda (x e) (prelex-operand-set! x (build-cooked-opnd e))) x* e*)
(values (make-lifted #f x* e*) body)] (values (make-lifted #f x* e*) body)]
@ -575,7 +577,9 @@
(for-each (lambda (x e) (prelex-operand-set! x (build-cooked-opnd e))) x* e*) (for-each (lambda (x e) (prelex-operand-set! x (build-cooked-opnd e))) x* e*)
(values (make-lifted #t x* e*) (build-ref x))))] (values (make-lifted #t x* e*) (build-ref x))))]
[(letrec* ([,x* ,e*] ...) ,body) [(letrec* ([,x* ,e*] ...) ,body)
(guard (or (ivory? body) (andmap ivory1? e*))) (guard (and (or (ivory? body) (andmap ivory1? e*))
;; don't break apart (potential) loops
(not (possible-loop? x* body))))
; assocate each lhs with cooked operand for corresponding rhs. see note above. ; assocate each lhs with cooked operand for corresponding rhs. see note above.
(for-each (lambda (x e) (prelex-operand-set! x (build-cooked-opnd e))) x* e*) (for-each (lambda (x e) (prelex-operand-set! x (build-cooked-opnd e))) x* e*)
(values (make-lifted #t x* e*) body)] (values (make-lifted #t x* e*) body)]
@ -1407,6 +1411,9 @@
[(letrec ([,x1 (case-lambda ,preinfo ,cl* ...)]) (ref ,maybe-src ,x2)) [(letrec ([,x1 (case-lambda ,preinfo ,cl* ...)]) (ref ,maybe-src ,x2))
(and (eq? x1 x2) (and (eq? x1 x2)
(preinfo->single-valued preinfo x1))] (preinfo->single-valued preinfo x1))]
[(letrec* ([,x1 (case-lambda ,preinfo ,cl* ...)]) (ref ,maybe-src ,x2))
(and (eq? x1 x2)
(preinfo->single-valued preinfo x1))]
[else #f]))] [else #f]))]
[(ref ,maybe-src ,x) #t] [(ref ,maybe-src ,x) #t]
[(case-lambda ,preinfo ,cl* ...) #t] [(case-lambda ,preinfo ,cl* ...) #t]