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

Struggling here a bit, removing env from cps until scope issues are fixed

Browse Source
This commit is contained in:
Dane Johnson
2026-01-23 09:10:50 -06:00
parent f9d30db271
commit 05fd5f5db2
1 changed files with 39 additions and 51 deletions
Download Patch File Download Diff File Expand all files Collapse all files

90
scmvm/language/scheme.scm
View File

@@ -75,8 +75,8 @@
;; Desugaring ;; Desugaring
;; Transforms to simplify the language ;; Transforms to simplify the language
;; - lambdas and lets can only have 1 expression in body position ;; - lambdas, lets and letrecs can only have 1 expression in body position
;; - defines are decomposed to lets that bind their values and wrap their continuations ;; - defines are decomposed to letrecs that bind their values and wrap their continuations
;; <prgm> ::= <exp> ... ;; <prgm> ::= <exp> ...
;; <exp> ::= (lambda (<var> ...) <exp>) ;; <exp> ::= (lambda (<var> ...) <exp>)
;; | (if <exp> <exp> <exp>) ;; | (if <exp> <exp> <exp>)
@@ -96,9 +96,9 @@
(define (desugar-define def cont) (define (desugar-define def cont)
(match def (match def
[`(define ,(name params ...) . ,e*) [`(define ,(name params ...) . ,e*)
`(letrec ([,name ,(desugar-exp `(lambda ,params ,@e*))]) ,@(desugar-top cont))] `(letrec ([,name ,(desugar-exp `(lambda ,params ,@e*))]) (begin ,@(desugar-top cont)))]
[`(define ,name ,exp) [`(define ,name ,exp)
`(letrec ([,name ,(desugar-exp exp)]) ,@(desugar-top cont))])) `(letrec ([,name ,(desugar-exp exp)]) (begin ,@(desugar-top cont)))]))
(define (desugar-exp exp) (define (desugar-exp exp)
(match exp (match exp
@@ -155,82 +155,76 @@
(define (ref-uniq r v*) (define (ref-uniq r v*)
(map (lambda (n) (cdr (environment-assq r n))) v*)) (map (lambda (n) (cdr (environment-assq r n))) v*))
(define (M expr r) (define (M expr)
;; M dispatches to the appropriate transformer ;; M dispatches to the appropriate transformer
;; expr -> aexp ;; expr -> aexp
(match expr (match expr
[('lambda (v* ...) e) [('lambda (v* ...) e)
(let ([$k (gensym "$k-")] (let ([$k (gensym "$k-")])
[r0 (extend-uniq r v*)]) `(lambda (,@v* ,$k) ,(T-c e $k)))]
`(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))] [(? symbol?) expr]
[(? atomic?) expr])) [(? atomic?) expr]))
(define (T-c expr c r) (define (T-c expr c)
;; 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 r))] [`(lambda . ,_) `(,c ,(M expr))]
[ (? atomic?) `(,c ,(M expr r))] [ (? atomic?) `(,c ,(M expr))]
[ ('define v e) [ ('letrec ([v e]) body)
(let ([r0 (extend-uniq r (list v))]) (T-k e (lambda ($e)
(T-k e (lambda ($e) `(letrec ([,@(ref-uniq r0 (list v)) ,$e]) ,c)) r0))] (T-k body (lambda ($body) `(letrec ([,v ,$e]) (,c ,$body))))))]
[ ('begin e) (T-c e c r)] [ ('begin e) (T-c e c)]
[ ('begin e e* ...) [ ('begin e e* ...)
(T-k e (lambda _ (T-k e (lambda _
(T-c `(begin ,@e*) c r)) r)] (T-c `(begin ,@e*) c)))]
[ ('let ([v* e*] ...) body) [ ('let ([v* e*] ...) body)
(let ([r0 (extend-uniq r v*)]) (T-c `((lambda (,@v*) ,body) ,@e*) c)]
(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 r) ,(T-c exp2 $k)
,(T-c exp3 $k r))) r)) ,(T-c exp3 $k)))))
,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))) r)] `(set-then! ,var ,$expr (,c ,undefined-value))))]
[ (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)) r)) r)])) `(,$f ,@$e* ,c)))))]))
(define (T-k expr k r) (define (T-k expr k)
;; 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 r))] [`(lambda . ,_) (k (M expr))]
[(? atomic?) (k (M expr r))] [(? atomic?) (k (M expr))]
[('define v e) [('letrec ([v e]) body)
(let ([r0 (extend-uniq r (list v))]) (T-k e
(T-k e (lambda ($e)
(lambda ($e) `(letrec ([,@(ref-uniq r0 (list v)) ,$e]) ,(k))) (T-k body
r0))] (lambda ($body) `(letrec ([,v ,$e]) ,(k $body))))))]
[('begin e) (T-k e k r)] [('begin e) (T-k e k)]
[('begin e e* ...) [('begin e e* ...)
(T-k e (T-k e
(lambda _ (lambda _
(T-k `(begin ,@e*) k r)) (T-k `(begin ,@e*) k)))]
r)]
[('let ([v* e*] ...) body) [('let ([v* e*] ...) body)
(let ([r0 (extend-uniq r v*)]) (T-k `((lambda (,@v*) ,body) ,@e*) k)]
(T-k `((lambda (,@(ref-uniq r0 v*)) ,body) ,@e*) k r0))]
[('if exp1 exp2 exp3) [('if exp1 exp2 exp3)
(T-k exp1 (T-k exp1
(lambda ($exp1) (lambda ($exp1)
`(if ,$exp1 `(if ,$exp1
,(T-k exp2 k r) ,(T-k exp2 k)
,(T-k exp3 k r))) ,(T-k exp3 k))))]
r)]
[('set! var expr) [('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))])
@@ -238,24 +232,18 @@
(lambda ($f) (lambda ($f)
(T*-k e* (T*-k e*
(lambda ($e*) (lambda ($e*)
`(,$f ,@$e* ,cont)) `(,$f ,@$e* ,cont))))))]))
r))
r))]))
;; (expr* * (aexp* -> cexp) -> cexp) ;; (expr* * (aexp* -> cexp) -> cexp)
(define (T*-k v* k r) (define (T*-k v* k)
(if (null? v*) (if (null? v*)
(k '()) (k '())
(T-k (car v*) (T-k (car v*)
(lambda (t) (T*-k (cdr 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) (define (cps-convert-prgm prgm tail)
(let ([r (make-environment)]) (T-c prgm tail))
(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-top prgm) tail)) (cps-convert-prgm (desugar-top prgm) tail))