From f9d30db271b66f2f8120197fc907b19d0c3dc5fc Mon Sep 17 00:00:00 2001 From: Dane Johnson Date: Tue, 20 Jan 2026 11:53:53 -0600 Subject: [PATCH] Environment records for cps conversion, uniq identifiers avoid shadowing, desugar removes all defines --- scmvm/language/scheme.scm | 182 +++++++++++++++++++++++++------------- 1 file changed, 120 insertions(+), 62 deletions(-) diff --git a/scmvm/language/scheme.scm b/scmvm/language/scheme.scm index 96be20d..128f32a 100644 --- a/scmvm/language/scheme.scm +++ b/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) - (define (name v* k) - (if (null? v*) - (k '()) - (unit (car v*) - (lambda (t) - (name (cdr v*) - (lambda (t*) - (k (cons t t*))))))))) + ;; Environment Records +;; The idea of an hierarchy of environments comes across often in lexical variable definition +(define-record-type + (make-environment* next values) + environment? + (next environment-next) + (values environment-values)) + +(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 -;; ::= ... -;; ::= | -;; ::= (define ) +;; - defines are decomposed to lets that bind their values and wrap their continuations +;; ::= ... ;; ::= (lambda ( ...) ) ;; | (if ) ;; | ( ...) ;; | (let (( ) ...) ) +;; | (letrec (( )) ...) ;; | (begin ...) ;; | | | | #t | #f -(define (desugar-prgm prgm) - (map (lambda (top) - (if (and (pair? top) (eq? (car top) 'define)) - (desugar-define top) - (desugar-exp top))) - prgm)) +(define (desugar-top prgm) + (match prgm + [() '()] + [(('define . _) cont ...) (desugar-define (car prgm) cont)] + [_ (cons (desugar-exp (car 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) - (let ([$k (gensym "$k-")]) - `(lambda (,@var ,$k) ,(T-c e $k)))] + [('lambda (v* ...) e) + (let ([$k (gensym "$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))] - [ (? atomic?) `(,c ,(M expr))] - [ ('define v e) (T-k e (lambda ($e) `(letrec ([,v ,$e]) ,c)))] - [ ('begin e) (T-c e c)] + [`(lambda . ,_) `(,c ,(M expr r))] + [ (? atomic?) `(,c ,(M expr r))] + [ ('define v e) + (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 exp3 $k))))) + ,(T-c exp2 $k r) + ,(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))] - [ (? atomic?) (k (M expr))] - [ ('define v e) (T-k e (lambda ($e) `(letrec ([,v ,$e]) ,(k))))] - [ ('begin e) (T-k e k)] - [ ('begin e e* ...) - (T-k e (lambda _ - (T-k `(begin ,@e*) k)))] - [ ('let ([v* e*] ...) body) - (T-k `((lambda (,@v*) ,body) ,@e*) k)] - [ ('if exp1 exp2 exp3) - (T-k exp1 (lambda ($exp1) - `(if ,$exp1 - ,(T-k exp2 k) - ,(T-k exp3 k))))] - [ ('set! var expr) - (T-k expr (lambda ($expr) - `(set-then! ,var ,$expr ,(k undefined-value))))] + [`(lambda . ,_) (k (M expr r))] + [(? atomic?) (k (M expr r))] + [('define v e) + (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 `(begin ,@e*) k r)) + r)] + [('let ([v* e*] ...) body) + (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) + `(if ,$exp1 + ,(T-k exp2 k r) + ,(T-k exp3 k r))) + r)] + [('set! var expr) + (T-k expr (lambda ($expr) + `(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 e* (lambda ($e*) - `(,$f ,@$e* ,cont))))))])) + (T-k f + (lambda ($f) + (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)