Environment records for cps conversion, uniq identifiers avoid shadowing, desugar removes all defines

scmvm/language/scheme.scm

@@ -40,43 +40,65 @@
       (boolean? x)
       (and (pair? x) (eq? 'quote (car x)))))
 
-(define-syntax-rule (define-cps-loop name unit)
+ ;; Environment Records
-  (define (name v* k)
+;; The idea of an hierarchy of environments comes across often in lexical variable definition
-    (if (null? v*)
+(define-record-type <environment>
-	(k '())
+  (make-environment* next values)
-	(unit (car v*)
+  environment?
-	      (lambda (t)
+  (next environment-next)
-		(name (cdr v*)
+  (values environment-values))
-		      (lambda (t*)
+
-			(k (cons t t*)))))))))
+(define (make-environment)
+  (make-environment* #f '()))
+
+(define (environment-extend env values)
+  (make-environment* env values))
+
+(define (environment-lookup r n)
+  (let loop ([r r]
+             [j 0])
+    (cond
+     [(not r) #f]
+     [(list-index (lambda (n0) (eq? n n0)) (environment-values r)) => (lambda (i) (values i j))]
+     [else (loop (+ j 1) (environment-next r))])))
+
+(define (environment-assq r n)
+  (let loop ([r r])
+    (cond
+     [(not r) #f]
+     [(assq n (environment-values r)) => identity]
+     [else (loop (environment-next r))])))
+
+(define (environment-assq-set! r k v)
+  (set! (environment-values r) (assq-set! k v (environment-values r))))
+
 
 ;; Desugaring
 ;; Transforms to simplify the language
 ;; - lambdas and lets can only have 1 expression in body position
-;; - define is always simple binds, function defs bind a lambda
+;; - defines are decomposed to lets that bind their values and wrap their continuations
-;; <prgm> ::= <top> ...
+;; <prgm> ::= <exp> ...
-;; <top>  ::= <def> | <exp>
-;; <def>  ::= (define <var> <exp>)
 ;; <exp>  ::= (lambda (<var> ...) <exp>)
 ;;          | (if <exp> <exp> <exp>)
 ;;          | (<exp> <exp> ...)
 ;;          | (let ((<var> <exp>) ...) <exp>)
+;;          | (letrec ((<var> <exp>)) <exp> ...)
 ;;          | (begin <exp> ...)
 ;;          | <num> | <sym> | <var> | #t | #f
 
-(define (desugar-prgm prgm)
+(define (desugar-top prgm)
-  (map (lambda (top)
+  (match prgm
-	 (if (and (pair? top) (eq? (car top) 'define))
+    [() '()]
-	     (desugar-define top)
+    [(('define . _) cont ...) (desugar-define (car prgm) cont)]
-	     (desugar-exp top)))
+    [_ (cons (desugar-exp (car prgm))
-       prgm))
+             (desugar-top (cdr prgm)))]))
 
-(define (desugar-define def)
+(define (desugar-define def cont)
   (match def
     [`(define ,(name params ...) . ,e*)
-     `(define ,name ,(desugar-exp `(lambda ,params ,@e*)))]
+     `(letrec ([,name ,(desugar-exp `(lambda ,params ,@e*))]) ,@(desugar-top cont))]
     [`(define ,name ,exp)
-     `(define ,name ,(desugar-exp exp))]))
+     `(letrec ([,name ,(desugar-exp exp)]) ,@(desugar-top cont))]))
 
 (define (desugar-exp exp)
   (match exp
@@ -97,7 +119,6 @@
     ['() '()]
     [(e) (desugar-exp e)]
     [(e* ...) `(begin ,@(map desugar-exp e*))]))
-
 
 ;; CPS conversion
 ;; Re-structure the program into "Continuation Passing Style", where non-atomic
@@ -125,82 +146,119 @@
 
 (define undefined-value (make-symbol "undefined"))
 
-(define (M expr)
+(define (uniq-var n)
+  (cons n (gensym (string-append "%" (symbol->string n) "-"))))
+
+(define (extend-uniq r v*)
+  (environment-extend r (map uniq-var v*)))
+
+(define (ref-uniq r v*)
+  (map (lambda (n) (cdr (environment-assq r n))) v*))
+
+(define (M expr r)
   ;; M dispatches to the appropriate transformer
   ;; expr -> aexp
   (match expr
-    [('lambda (var ...) e)
+    [('lambda (v* ...) e)
-     (let ([$k (gensym "$k-")])
+     (let ([$k (gensym "$k-")]
-       `(lambda (,@var ,$k) ,(T-c e $k)))]
+           [r0 (extend-uniq r v*)])
+       `(lambda (,@(ref-uniq r0 v*) ,$k) ,(T-c e $k r0)))]
     [(? primitive?) `(cps-prim ,expr)]
+    [(? symbol?) (cdr (environment-assq r 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
-    [`(lambda . ,_) `(,c ,(M expr))]
+    [`(lambda . ,_) `(,c ,(M expr r))]
-    [ (? atomic?)   `(,c ,(M expr))]
+    [ (? atomic?)   `(,c ,(M expr r))]
-    [ ('define v e) (T-k e (lambda ($e) `(letrec ([,v ,$e]) ,c)))]
+    [ ('define v e)
-    [ ('begin e) (T-c e c)]
+      (let ([r0 (extend-uniq r (list v))])
+        (T-k e (lambda ($e) `(letrec ([,@(ref-uniq r0 (list v)) ,$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 ([r0 (extend-uniq r v*)])
+        (T-c `((lambda (,@(ref-uniq r0 v*)) ,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)
       (T-k expr (lambda ($expr)
-                  `(set-then! ,var ,$expr (,c ,undefined-value))))]
+                  `(set-then! ,var ,$expr (,c ,undefined-value))) r)]
     [ (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
-    [`(lambda . ,_) (k (M expr))]
+    [`(lambda . ,_) (k (M expr r))]
-    [ (? atomic?)   (k (M expr))]
+    [(? atomic?)   (k (M expr r))]
-    [ ('define v e) (T-k e (lambda ($e) `(letrec ([,v ,$e]) ,(k))))]
+    [('define v e)
-    [ ('begin e) (T-k e k)]
+     (let ([r0 (extend-uniq r (list v))])
+       (T-k e
+            (lambda ($e) `(letrec ([,@(ref-uniq r0 (list v)) ,$e]) ,(k)))
+            r0))]
+    [('begin e) (T-k e k r)]
     [('begin e e* ...)
-      (T-k e (lambda _
+     (T-k e
-               (T-k `(begin ,@e*) k)))]
+          (lambda _
+            (T-k `(begin ,@e*) k r))
+          r)]
     [('let ([v* e*] ...) body)
-      (T-k `((lambda (,@v*) ,body) ,@e*) k)]
+     (let ([r0 (extend-uniq r v*)])
+       (T-k `((lambda (,@(ref-uniq r0 v*)) ,body) ,@e*) k r0))]
     [('if exp1 exp2 exp3)
-      (T-k exp1 (lambda ($exp1)
+     (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)
      (T-k expr (lambda ($expr)
-                  `(set-then! ,var ,$expr ,(k undefined-value))))]
+                 `(set-then! ,var ,$expr ,(k undefined-value)))
+          r)]
     [(f e* ...)
      (let* ([$rv (gensym "$rv-")]
 	    [cont `(lambda (,$rv) ,(k $rv))])
-       (T-k f (lambda ($f)
+       (T-k f
-		(T*-k e* (lambda ($e*)
+            (lambda ($f)
-			   `(,$f ,@$e* ,cont))))))]))
+	      (T*-k e*
+                    (lambda ($e*)
+		      `(,$f ,@$e* ,cont))
+                    r))
+            r))]))
 
 ;; (expr* * (aexp* -> cexp) -> cexp)
-(define-cps-loop T*-k T-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*)))
+                             r))
+           r)))
+
 
 (define (cps-convert-prgm prgm tail)
-  (T-c `(begin ,@prgm) tail))
+  (let ([r (make-environment)])
+    (T-c `(begin ,@prgm) tail (environment-extend r (list (cons tail tail))))))
 
 (define* (ir-convert prgm #:optional (tail 'ktail))
-  (cps-convert-prgm (desugar-prgm prgm) tail))
+  (cps-convert-prgm (desugar-top prgm) tail))
 
 ;; For testing
 (define (cps-prim x)