From 1bc51a7ba468faf735d32ed8018f018fe78d2c92 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sun, 14 Jun 2020 16:51:39 -0600
Subject: [PATCH] cp0 loop adjustment for `letrec*`

original commit: b89cf40dcfd25c382bdb3190f46916ccc63a841e
---
 s/cp0.ss | 19 +++++++++++++------
 1 file changed, 13 insertions(+), 6 deletions(-)

diff --git a/s/cp0.ss b/s/cp0.ss
index 91d8dd9133..74825ca0ae 100644
--- a/s/cp0.ss
+++ b/s/cp0.ss
@@ -503,6 +503,12 @@
                      (loop e2 (if eprof `(seq ,eprof ,e1) e1))]
                     [else (values e eprof)]))
                 (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.
         ; lifting job is completed by cp0-call or letrec/letrec*
         (define (split-value e)
@@ -557,11 +563,7 @@
             [(letrec ([,x* ,e*] ...) ,body)
              (guard (and (or (ivory? body) (andmap ivory1? e*))
                          ;; don't break apart (potential) loops
-                         (not (and (fx= (length x*) 1)
-                                   (nanopass-case (Lsrc Expr) body
-                                     [(call ,preinfo (ref ,maybe-src ,x) ,e* ...)
-                                      (eq? x (car x*))]
-                                     [else #f])))))
+                         (not (possible-loop? x* body))))
              ; 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*)
              (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*)
                  (values (make-lifted #t x* e*) (build-ref x))))]
             [(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.
              (for-each (lambda (x e) (prelex-operand-set! x (build-cooked-opnd e))) x* e*)
              (values (make-lifted #t x* e*) body)]
@@ -1407,6 +1411,9 @@
                    [(letrec ([,x1 (case-lambda ,preinfo ,cl* ...)]) (ref ,maybe-src ,x2))
                     (and (eq? x1 x2)
                          (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]))]
               [(ref ,maybe-src ,x) #t]
               [(case-lambda ,preinfo ,cl* ...) #t]