dane/scm-to-vm
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Dane Johnson
2026-01-20 11:53:53 -06:00
parent 43642ca025
commit f9d30db271
1 changed files with 120 additions and 62 deletions
Download Patch File Download Diff File Expand all files Collapse all files

178
scmvm/language/scheme.scm
View File

@@ -40,43 +40,65 @@
(boolean? x) (boolean? x)
(and (pair? x) (eq? 'quote (car 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 ;; Desugaring
;; Transforms to simplify the language ;; Transforms to simplify the language
;; - lambdas and lets can only have 1 expression in body position ;; - 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>) ;; <exp> ::= (lambda (<var> ...) <exp>)
;; | (if <exp> <exp> <exp>) ;; | (if <exp> <exp> <exp>)
;; | (<exp> <exp> ...) ;; | (<exp> <exp> ...)
;; | (let ((<var> <exp>) ...) <exp>) ;; | (let ((<var> <exp>) ...) <exp>)
;; | (letrec ((<var> <exp>)) <exp> ...)
;; | (begin <exp> ...) ;; | (begin <exp> ...)
;; | <num> | <sym> | <var> | #t | #f ;; | <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 (match def
[`(define ,(name params ...) . ,e*) [`(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 ,exp)
`(define ,name ,(desugar-exp exp))])) `(letrec ([,name ,(desugar-exp exp)]) ,@(desugar-top cont))]))
(define (desugar-exp exp) (define (desugar-exp exp)
(match exp (match exp
@@ -97,7 +119,6 @@
['() '()] ['() '()]
[(e) (desugar-exp e)] [(e) (desugar-exp e)]
[(e* ...) `(begin ,@(map desugar-exp e*))])) [(e* ...) `(begin ,@(map desugar-exp e*))]))
;; CPS conversion ;; CPS conversion
;; Re-structure the program into "Continuation Passing Style", where non-atomic ;; Re-structure the program into "Continuation Passing Style", where non-atomic
@@ -125,82 +146,119 @@
(define undefined-value (make-symbol "undefined")) (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 ;; M dispatches to the appropriate transformer
;; expr -> aexp ;; expr -> aexp
(match expr (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)] [(? primitive?) `(cps-prim ,expr)]
[(? symbol?) (cdr (environment-assq r expr))]
[(? atomic?) 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 ;; T-c takes a symbolic continuation, and uses it to construct CPS
;; (expr * aexp) -> cexp ;; (expr * aexp) -> cexp
(match expr (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* ...) [ ('begin e e* ...)
(T-k e (lambda _ (T-k e (lambda _
(T-c `(begin ,@e*) c)))] (T-c `(begin ,@e*) c r)) r)]
[ ('let ([v* e*] ...) body) [ ('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) [ ('if exp1 exp2 exp3)
(let ([$k (gensym "$k-")]) ;; Bind cont to avoid blow up (let ([$k (gensym "$k-")]) ;; Bind cont to avoid blow up
`((lambda (,$k) `((lambda (,$k)
,(T-k exp1 (lambda (aexp) ,(T-k exp1 (lambda (aexp)
`(if ,aexp `(if ,aexp
,(T-c exp2 $k) ,(T-c exp2 $k r)
,(T-c exp3 $k))))) ,(T-c exp3 $k r))) r))
,c))] ,c))]
[ ('set! var expr) [ ('set! var expr)
(T-k expr (lambda ($expr) (T-k expr (lambda ($expr)
`(set-then! ,var ,$expr (,c ,undefined-value))))] `(set-then! ,var ,$expr (,c ,undefined-value))) r)]
[ (f e* ...) [ (f e* ...)
(T-k f (lambda ($f) (T-k f (lambda ($f)
(T*-k e* (lambda ($e*) (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 ;; T-k takes an explicit continuation and calls it when done
;; As an invariant, T-k cannot nest a T-c call directly ;; As an invariant, T-k cannot nest a T-c call directly
;; (expr * (aexp -> cexp) -> cexp) ;; (expr * (aexp -> cexp) -> cexp)
(match expr (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))])
[ ('begin e e* ...) (T-k e
(T-k e (lambda _ (lambda ($e) `(letrec ([,@(ref-uniq r0 (list v)) ,$e]) ,(k)))
(T-k `(begin ,@e*) k)))] r0))]
[ ('let ([v* e*] ...) body) [('begin e) (T-k e k r)]
(T-k `((lambda (,@v*) ,body) ,@e*) k)] [('begin e e* ...)
[ ('if exp1 exp2 exp3) (T-k e
(T-k exp1 (lambda ($exp1) (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 `(if ,$exp1
,(T-k exp2 k) ,(T-k exp2 k r)
,(T-k exp3 k))))] ,(T-k exp3 k r)))
[ ('set! var expr) r)]
[('set! var expr)
(T-k expr (lambda ($expr) (T-k expr (lambda ($expr)
`(set-then! ,var ,$expr ,(k undefined-value))))] `(set-then! ,var ,$expr ,(k undefined-value)))
r)]
[(f e* ...) [(f e* ...)
(let* ([$rv (gensym "$rv-")] (let* ([$rv (gensym "$rv-")]
[cont `(lambda (,$rv) ,(k $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) ;; (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) (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)) (define* (ir-convert prgm #:optional (tail 'ktail))
(cps-convert-prgm (desugar-prgm prgm) tail)) (cps-convert-prgm (desugar-top prgm) tail))
;; For testing ;; For testing
(define (cps-prim x) (define (cps-prim x)