From e37199cd7a3c8421a192cf1cab95d7c56fd4a024 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sat, 29 Dec 2018 17:20:20 -0600
Subject: [PATCH] cs: fix letrec

Report source name when accessing a variable too early, and allow
multiple returns (based on continuation capture) for the right-hand
side of a `letrec`.

The repair directly implements `letrec` as needed in terms of `let`
and `set!`, instead of relying on Chez Scheme's `letrec`, unless
right-hand sides are simple enough. Implementing `letrec` that way
risks losing Chez Scheme optimizations, but schemify takes care
of many improvements already.
---
 racket/src/cs/Makefile              |  1 +
 racket/src/cs/linklet/annotation.ss | 26 +++++++++++++---
 racket/src/cs/rumble.sls            |  3 ++
 racket/src/cs/rumble/letrec.ss      | 47 +++++++++++++++++++++++++++++
 4 files changed, 72 insertions(+), 5 deletions(-)
 create mode 100644 racket/src/cs/rumble/letrec.ss

diff --git a/racket/src/cs/Makefile b/racket/src/cs/Makefile
index 841e47e770..caecca02f3 100644
--- a/racket/src/cs/Makefile
+++ b/racket/src/cs/Makefile
@@ -226,6 +226,7 @@ RUMBLE_SRCS = rumble/define.ss \
               rumble/virtual-register.ss \
               rumble/check.ss \
 	      rumble/syntax-rule.ss \
+	      rumble/letrec.ss \
               rumble/constant.ss \
               rumble/hash-code.ss \
               rumble/struct.ss \
diff --git a/racket/src/cs/linklet/annotation.ss b/racket/src/cs/linklet/annotation.ss
index a5484dcdbc..fb7e489558 100644
--- a/racket/src/cs/linklet/annotation.ss
+++ b/racket/src/cs/linklet/annotation.ss
@@ -6,11 +6,27 @@
   (cond
    [(pair? v) (let-values ([(a stripped-a) (correlated->annotation* (car v))]
                            [(d stripped-d) (correlated->annotation* (cdr v))])
-                (if (and (eq? a (car v))
-                         (eq? d (cdr v)))
-                    (values v v)
-                    (values (cons a d)
-                            (cons stripped-a stripped-d))))]
+                (cond
+                 [(and (eq? a (car v))
+                       (eq? d (cdr v)))
+                  (values v v)]
+                 [(and (eq? stripped-a 'letrec*)
+                       (pair? (cdr v)))
+                  (let ([names (let loop ([clauses (cadr v)])
+                                 (cond
+                                  [(null? clauses) '()]
+                                  [else
+                                   (let ([id (caar clauses)])
+                                     (cons (or (and (correlated? id)
+                                                    (correlated-property id 'undefined-error-name))
+                                               (if (correlated? id)
+                                                   (correlated-e id)
+                                                   id))
+                                           (loop (cdr clauses))))]))])
+                    (values (list* 'letrec*/names names d)
+                            (list* 'letrec*/names names stripped-d)))]
+                 [else (values (cons a d)
+                               (cons stripped-a stripped-d))]))]
    [(correlated? v) (let-values ([(e stripped-e) (correlated->annotation* (correlated-e v))])
                       (let ([name (correlated-property v 'inferred-name)])
                         (define (add-name e)
diff --git a/racket/src/cs/rumble.sls b/racket/src/cs/rumble.sls
index b2f6d8812a..fdbc021627 100644
--- a/racket/src/cs/rumble.sls
+++ b/racket/src/cs/rumble.sls
@@ -6,6 +6,8 @@
 
           begin0
 
+          letrec*/names
+
           dynamic-wind
           call-with-current-continuation
           call-with-composable-continuation
@@ -693,6 +695,7 @@
   (include "rumble/define.ss")
   (include "rumble/virtual-register.ss")
   (include "rumble/begin0.ss")
+  (include "rumble/letrec.ss")
   (include "rumble/syntax-rule.ss")
   (include "rumble/lock.ss")
   (include "rumble/thread-local.ss")
diff --git a/racket/src/cs/rumble/letrec.ss b/racket/src/cs/rumble/letrec.ss
new file mode 100644
index 0000000000..a83b8c7961
--- /dev/null
+++ b/racket/src/cs/rumble/letrec.ss
@@ -0,0 +1,47 @@
+(meta define no-early-reference?
+      (lambda (stx ids)
+        (cond
+         [(#%identifier? stx)
+          (not (#%ormap (lambda (id) (free-identifier=? id stx)) ids))]
+         [(let ([d (syntax->datum stx)])
+            (or (number? d) (boolean? d) (string? d) (bytevector? d)))
+          #t]
+         [else
+          (syntax-case stx (quote |#%name| lambda case-lambda)
+            [(quote _) #t]
+            [(|#%name| _ exp) (no-early-reference? #'exp ids)]
+            [(lambda . _) #t]
+            [(case-lambda . _) #t]
+            [_ #f])])))
+
+(meta define no-early-references?
+      (lambda (rhss ids)
+        (cond
+         [(null? rhss) #t]
+         [else (and (no-early-reference? (car rhss) ids)
+                    (no-early-references? (cdr rhss) (cdr ids)))])))
+
+;; Like `letrec*`, but makes use-before-definition checks explicit so
+;; that a source name is included in the error messages. Also, the
+;; expansion allows `call/cc`-based capture and multiple return on the
+;; right-hand side.
+(define-syntax (letrec*/names stx)
+  (syntax-case stx ()
+    [(_ (name ...) ([id rhs] ...) body ...)
+     (cond
+      [(no-early-references? #'(rhs ...) #'(id ...))
+       #'(letrec* ([id rhs] ...) body ...)]
+      [else
+       (with-syntax ([(tmp-id ...) (generate-temporaries #'(id ...))])
+         #'(let ([tmp-id unsafe-undefined] ...)
+             (let-syntax ([id (identifier-syntax
+                               [id (check-not-unsafe-undefined tmp-id 'name)]
+                               [(set! id exp)
+                                (let ([id exp])
+                                  (check-not-unsafe-undefined/assign tmp-id 'name)
+                                  (set! tmp-id id))])]
+                          ...)
+               (set! tmp-id rhs)
+               ...
+               (let ()
+                 body ...))))])]))