Unique rename strategy for cps

scmvm/language/scheme.scm

@@ -2,6 +2,7 @@
   #:use-module (scmvm assembler)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
   #:use-module ((rnrs base)
@@ -147,103 +148,123 @@
 (define undefined-value (make-symbol "undefined"))
 
 (define (uniq-var n)
-  (cons n (gensym (string-append "%" (symbol->string n) "-"))))
+  (gensym (string-append "%" (symbol->string n) "-")))
 
-(define (extend-uniq r v*)
+(define (uniq-names r v*)
-  (environment-extend r (map uniq-var v*)))
+  (let ([v*0 (map uniq-var v*)])
+    (values (environment-extend r (map cons v* v*0)) v*0)))
 
-(define (ref-uniq r v*)
+(define (uniq-name r v)
-  (map (lambda (n) (cdr (environment-assq r n))) v*))
+  (let ([v0 (uniq-var v)])
+    (values (environment-extend r (list (cons v v0))) v0)))
 
-(define (M expr)
+(define (M expr r)
   ;; M dispatches to the appropriate transformer
   ;; expr -> aexp
   (match expr
     [('lambda (v* ...) e)
-     (let ([$k (gensym "$k-")])
+     (let-values
-       `(lambda (,@v* ,$k) ,(T-c e $k)))]
+         ([($k) (gensym "$k-")]
+          [(r0 v*0) (uniq-names r v*)])
+       `(lambda (,@v*0 ,$k) ,(T-c e $k r0)))]
     [(? primitive?) `(cps-prim ,expr)]
-    [(? symbol?) expr]
+    [(? symbol?)
+     (let ([kons (environment-assq r expr)])
+       (if kons (cdr kons) (signal-exception "Undefined variable:" expr)))]
     [(? atomic?) expr]))
 
-(define (T-c expr c)
+(define (T-c expr c r)
   ;; T-c takes a symbolic continuation, and uses it to construct CPS
   ;; (expr * aexp) -> cexp
   (match expr
     [ ('quote e) `(,c ,expr)]
-    [`(lambda . ,_) `(,c ,(M expr))]
+    [`(lambda . ,_) `(,c ,(M expr r))]
-    [ (? atomic?)   `(,c ,(M expr))]
+    [ (? atomic?)   `(,c ,(M expr r))]
     [ ('letrec ([v e]) body)
+      (let-values ([(r0 v0) (uniq-name r v)])
         (T-k e (lambda ($e)
-               (T-k body (lambda ($body) `(letrec ([,v ,$e]) (,c ,$body))))))]
+                 (T-k body (lambda ($body) `(letrec ([,v0 ,$e]) (,c ,$body))) r0))
-    [ ('begin e) (T-c e c)]
+             r0))]
+    [ ('begin e) (T-c e c r)]
     [ ('begin e e* ...)
       (T-k e (lambda _
-               (T-c `(begin ,@e*) c)))]
+               (T-c `(begin ,@e*) c r)) r)]
     [ ('let ([v* e*] ...) body)
-      (T-c `((lambda (,@v*) ,body) ,@e*) c)]
+      (let-values ([(r0 v*0) (uniq-names r v*)])
+        (T-c `((lambda (,@v*0) ,body) ,@e*) c r0))]
     [ ('if exp1 exp2 exp3)
       (let ([$k (gensym "$k-")]) ;; Bind cont to avoid blow up
         `((lambda (,$k)
             ,(T-k exp1 (lambda (aexp)
                          `(if ,aexp
-                              ,(T-c exp2 $k)
+                              ,(T-c exp2 $k r)
-                              ,(T-c exp3 $k)))))
+                              ,(T-c exp3 $k r))) r))
           ,c))]
-    [ ('set! var expr)
+    [ ('set! v e)
-      (T-k expr (lambda ($expr)
+      (let-values ([(r0 v0) (uniq-name r v)])
-                  `(set-then! ,var ,$expr (,c ,undefined-value))))]
+        (T-k e (lambda ($e)
+                 `(set-then! ,v0 ,$e (,c ,undefined-value))) r0))]
     [ (f e* ...)
       (T-k f (lambda ($f)
 	       (T*-k e* (lambda ($e*)
-			  `(,$f ,@$e* ,c)))))]))
+			  `(,$f ,@$e* ,c)) r)) r)]))
 
-(define (T-k expr k)
+(define (T-k expr k r)
   ;; T-k takes an explicit continuation and calls it when done
   ;; As an invariant, T-k cannot nest a T-c call directly
   ;; (expr * (aexp -> cexp) -> cexp)
   (match expr
     [ ('quote e) (k expr)]
-    [`(lambda . ,_) (k (M expr))]
+    [`(lambda . ,_) (k (M expr r))]
-    [(? atomic?)   (k (M expr))]
+    [(? atomic?)   (k (M expr r))]
     [('letrec ([v e]) body)
+     (let-values ([(r0 v0) (uniq-name r v)])
        (T-k e
             (lambda ($e)
               (T-k body
-                 (lambda ($body) `(letrec ([,v ,$e]) ,(k $body))))))]
+                   (lambda ($body) `(letrec ([,v ,$e]) ,(k $body)))
-    [('begin e) (T-k e k)]
+                   r0))
+            r0))]
+    [('begin e) (T-k e k r)]
     [('begin e e* ...)
      (T-k e
           (lambda _
-            (T-k `(begin ,@e*) k)))]
+            (T-k `(begin ,@e*) k r))
+          r)]
     [('let ([v* e*] ...) body)
-     (T-k `((lambda (,@v*) ,body) ,@e*) k)]
+     (let-values ([(r0 v*0) (uniq-names r v*)])
+       (T-k `((lambda (,@v*0) ,body) ,@e*) k r0))]
     [('if exp1 exp2 exp3)
      (T-k exp1
           (lambda ($exp1)
             `(if ,$exp1
-                 ,(T-k exp2 k)
+                 ,(T-k exp2 k r)
-                 ,(T-k exp3 k))))]
+                 ,(T-k exp3 k r))) r)]
-    [('set! var expr)
+    [('set! v e)
-     (T-k expr (lambda ($expr)
+     (let-values ([(r0 v0) (uniq-name r v)])
-                 `(set-then! ,var ,$expr ,(k undefined-value))))]
+       (T-k e (lambda ($e)
+                `(set-then! ,v0 ,$e ,(k undefined-value))) r))]
     [(f e* ...)
      (let* ([$rv (gensym "$rv-")]
             [$k  (gensym "$k-")])
-       (T-k f (lambda ($f)
+       (T-k f
-	        (T*-k e* (lambda ($e*)
+            (lambda ($f)
-                           (k `((lambda (,$k) (,$f ,@$e* ,$k)) (lambda (,$rv) ,$rv))))))))]))
+	      (T*-k e*
+                    (lambda ($e*)
+                      (k `((lambda (,$k) (,$f ,@$e* ,$k)) (lambda (,$rv) ,$rv))))
+                    r))
+            r))]))
 
 ;; (expr* * (aexp* -> cexp) -> cexp)
-(define (T*-k v* k)
+(define (T*-k v* k r)
   (if (null? v*)
       (k '())
       (T-k (car v*)
            (lambda (t) (T*-k (cdr v*)
-                             (lambda (t*) (k (cons t t*))))))))
+                             (lambda (t*) (k (cons t t*))) r)) r)))
 
 (define (cps-convert-prgm prgm tail)
-  (T-c prgm tail))
+  (T-c prgm tail (make-environment)))
 
 (define* (ir-convert prgm #:optional (tail 'ktail))
   (cps-convert-prgm (desugar-top prgm) tail))