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

Cleaner cps interface

Browse Source
This commit is contained in:
Dane Johnson
2025-12-11 10:17:19 -06:00
parent 3ad9159969
commit e2f4e3d746
1 changed files with 85 additions and 65 deletions
Download Patch File Download Diff File Expand all files Collapse all files

42
scmvm/language/scheme.scm
View File

@@ -23,6 +23,9 @@
(symbol? x) (symbol? x)
(boolean? x))) (boolean? x)))
(define (primitive? x)
(memq x '(+ - * / = < > <= >=)))
(define-syntax-rule (define-cps-loop name unit) (define-syntax-rule (define-cps-loop name unit)
(define (name v* k) (define (name v* k)
(if (null? v*) (if (null? v*)
@@ -104,11 +107,7 @@
(define undefined-value (make-symbol "undefined")) (define undefined-value (make-symbol "undefined"))
(define (cps-convert-prgm prgm ktail) (define (M expr)
;; M : expr -> aexp
;; T-k : expr, (aexp -> cexp) -> cexp
;; T-c : expr, aexp -> cexp
(define (M expr)
;; M dispatches to the appropriate transformer ;; M dispatches to the appropriate transformer
(match expr (match expr
[('lambda (var ...) e) [('lambda (var ...) e)
@@ -116,12 +115,13 @@
`(lambda (,@var ,$k) ,(T-c e $k)))] `(lambda (,@var ,$k) ,(T-c e $k)))]
[(? atomic?) expr])) [(? atomic?) expr]))
(define (T-k expr k) (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
(match expr (match expr
[`(lambda . ,_) (k (M expr))] [`(lambda . ,_) (k (M expr))]
[ (? atomic?) (k (M expr))] [ (? atomic?) (k (M expr))]
[ ('define v e) (T-k `(define-then! ,v ,e) k)]
[ ('begin e) (T-k e k)] [ ('begin e) (T-k e k)]
[ ('begin e e* ...) [ ('begin e e* ...)
(T-k e (lambda _ (T-k `(begin ,@e*) k)))] (T-k e (lambda _ (T-k `(begin ,@e*) k)))]
@@ -135,6 +135,11 @@
[ ('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))))]
[((? primitive? f) e* ...)
(let* ([$rv (gensym "$rv")]
[cont `(lambda (,$rv) ,(k $rv))])
(T*-k e* (lambda ($e*)
`((cps ,f) ,@$e* ,cont))))]
[(f e* ...) [(f e* ...)
(let* ([$rv (gensym "$rv")] (let* ([$rv (gensym "$rv")]
[cont `(lambda (,$rv) ,(k $rv))]) [cont `(lambda (,$rv) ,(k $rv))])
@@ -142,11 +147,12 @@
(T*-k e* (lambda ($e*) (T*-k e* (lambda ($e*)
`(,$f ,@$e* ,cont))))))])) `(,$f ,@$e* ,cont))))))]))
(define (T-c expr c) (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
(match expr (match expr
[`(lambda . ,_) `(,c ,(M expr))] [`(lambda . ,_) `(,c ,(M expr))]
[ (? atomic?) `(,c ,(M expr))] [ (? atomic?) `(,c ,(M expr))]
[ ('define v e) (T-c `(define-then! ,v ,e) c)]
[ ('begin e) (T-c e c)] [ ('begin e) (T-c e c)]
[ ('begin e e* ...) [ ('begin e e* ...)
(T-k e (lambda _ (T-c `(begin ,@e*) c)))] (T-k e (lambda _ (T-c `(begin ,@e*) c)))]
@@ -163,12 +169,26 @@
[ ('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))))]
[ ((? primitive? f) e* ...)
(T*-k e* (lambda ($e*)
`((cps ,f) ,@$e* ,c)))]
[ (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)))))]))
(define-cps-loop T*-k T-k)
(T-c prgm ktail))
(define* (ir-convert prgm #:key (ktail 'ktail)) (define (cps-convert-prgm prgm)
(cps-convert-prgm (desugar-prgm prgm) ktail)) (T-c `(begin ,@prgm) 'ktail))
(define-cps-loop T*-k T-k)
(define (ir-convert prgm)
(cps-convert-prgm (desugar-prgm prgm)))
;; Useful for testing
;; (define (cps prim)
;; (lambda vars
;; (let* ([rev (reverse vars)]
;; [k (car rev)]
;; [args (reverse (cdr rev))])
;; (k (apply prim args)))))