diff options
| -rw-r--r-- | csc/cps-test.csc | 53 | ||||
| -rw-r--r-- | csc/cps.csc | 116 | ||||
| -rw-r--r-- | csc/ir2.csc | 44 |
3 files changed, 151 insertions, 62 deletions
diff --git a/csc/cps-test.csc b/csc/cps-test.csc index 0aead27..ea1d177 100644 --- a/csc/cps-test.csc +++ b/csc/cps-test.csc @@ -2,17 +2,21 @@ (only (csc hash-map) map->alist) (only (csc ir1) + make-call make-constant make-define-syntax make-if make-lexical-ref make-lexical-set - make-library-ref) + make-library-ref + make-sequence) (only (csc ir2) ir2=? make-atom make-branch + make-call-closure make-kargs + make-klabel make-ktail make-update) (only (csc loop) @@ -42,7 +46,7 @@ (test atom-const (assert-equal soup=? (list - (cons 0 (make-kargs '() + (cons 0 (make-klabel (make-atom (make-constant 5) 1))) (cons 1 (make-ktail))) (soup->alist (ir1->ir2 (make-constant 5))))) @@ -51,7 +55,7 @@ (test atom-lexical-ref (assert-equal soup=? (list - (cons 0 (make-kargs '() + (cons 0 (make-klabel (make-atom (make-lexical-ref 'var #f) 1))) (cons 1 (make-ktail))) (soup->alist (ir1->ir2 (make-lexical-ref 'var #f))))) @@ -60,7 +64,7 @@ (test atom-library-ref (assert-equal soup=? (list - (cons 0 (make-kargs '() + (cons 0 (make-klabel (make-atom (make-library-ref 'var '(csc builtins)) 1))) (cons 1 (make-ktail))) (soup->alist (ir1->ir2 (make-library-ref 'var '(csc builtins)))))) @@ -69,7 +73,7 @@ (test lexical-set (assert-equal soup=? (list - (cons 0 (make-kargs '() + (cons 0 (make-klabel (make-atom (make-constant 5) 2))) (cons 1 (make-ktail)) (cons 2 (make-kargs (list (make-lexical-ref 'generated-symbol #f)) @@ -81,7 +85,7 @@ (test no-op-define-syntax (assert-equal soup=? (list - (cons 0 (make-kargs '() (make-atom (make-constant #f) 1))) + (cons 0 (make-klabel (make-atom (make-constant #f) 1))) (cons 1 (make-ktail))) (soup->alist (ir1->ir2 (make-define-syntax 'name '(transformer)))))) @@ -89,13 +93,40 @@ (test branch (assert-equal soup=? (list - (cons 0 (make-kargs '() (make-atom (make-constant #t) 2))) + (cons 0 (make-klabel (make-atom (make-constant #t) 4))) (cons 1 (make-ktail)) - (cons 2 (make-kargs (list (make-lexical-ref 'generated-symbol #f)) + (cons 2 (make-klabel (make-atom (make-constant 1) 1))) + (cons 3 (make-klabel (make-atom (make-constant 2) 1))) + (cons 4 (make-kargs (list (make-lexical-ref 'generated-symbol #f)) (make-branch (make-lexical-ref 'generated-symbol #f) - 3 4))) - (cons 3 (make-kargs '() (make-atom (make-constant 1) 1))) - (cons 4 (make-kargs '() (make-atom (make-constant 2) 1)))) + 2 3)))) (soup->alist (ir1->ir2 (make-if (make-constant #t) (make-constant 1) (make-constant 2)))))) + + +(test call-closure + (assert-equal soup=? + (list + (cons 0 (make-klabel (make-atom (make-lexical-ref 'f #f) 4))) + (cons 1 (make-ktail)) + (cons 2 (make-kargs (list (make-lexical-ref 'generated-symbol #f)) + (make-call-closure (make-lexical-ref 'generated-symbol #f) + (list (make-lexical-ref 'generated-symbol #f) + (make-lexical-ref 'generated-symbol #f)) + 1))) + (cons 3 (make-kargs (list (make-lexical-ref 'generated-symbol #f)) + (make-atom (make-constant 2) 2))) + (cons 4 (make-kargs (list (make-lexical-ref 'generated-symbol #f)) + (make-atom (make-constant 1) 3)))) + (soup->alist (ir1->ir2 (make-call (make-lexical-ref 'f #f) (list (make-constant 1) (make-constant 2))))))) + + +(test sequence + (assert-equal soup=? + (list + (cons 0 (make-klabel (make-atom (make-constant 1) 2))) + (cons 1 (make-ktail)) + (cons 2 (make-klabel (make-atom (make-constant 2) 1)))) + (soup->alist (ir1->ir2 (make-sequence (make-constant 1) + (make-constant 2)))))) diff --git a/csc/cps.csc b/csc/cps.csc index e60e198..55e7e81 100644 --- a/csc/cps.csc +++ b/csc/cps.csc @@ -3,10 +3,13 @@ ir1->ir2) (import (only (csc gensym) gensym) (only (csc hash-map) - alist->map insert + make-map merge) (only (csc ir1) + call-arguments + call-procedure + call? constant? define-syntax? if-alternate @@ -22,69 +25,86 @@ library-define? library-ref? make-constant - make-lexical-ref) + make-lexical-ref + sequence-head + sequence-tail + sequence?) (only (csc ir2) make-atom make-branch + make-call-closure make-kargs + make-klabel make-ktail make-update) + (only (csc loop) + loop + return) (scheme base)) (begin - (define (make-soup . l) - (alist->map (lambda (x) x) < l)) - - (define (new-ref) (make-lexical-ref 'generated-symbol (gensym))) - (define-syntax cps-merge - (syntax-rules () - ((cps-merge new-continuations sub-cps) - (let-values (((expr soup) sub-cps)) - (values expr (merge soup new-continuations)))))) - - - (define (to-cps expr continuation next-id) + (define (to-cps expr continuation add-continuation) (cond ((or (constant? expr) (lexical-ref? expr) (library-ref? expr)) - (values (make-atom expr continuation) (make-soup))) + (make-atom expr continuation)) ((lexical-set? expr) - (let ((id (next-id)) - (ref (new-ref))) - (cps-merge - (make-soup (cons id (make-kargs (list ref) - (make-update (lexical-set-ref expr) ref continuation)))) - (to-cps (lexical-set-expression expr) id next-id)))) + (let ((ref (new-ref))) + (to-cps + (lexical-set-expression expr) + (add-continuation + (make-kargs (list ref) + (make-update (lexical-set-ref expr) ref continuation))) + add-continuation))) ((library-define? expr) - (let ((id (next-id)) - (ref (new-ref))) - (cps-merge - (make-soup (cons id (make-kargs (list ref) - (make-update (library-define-ref expr) ref continuation)))) - (to-cps (library-define-expression expr) id next-id)))) + (let ((ref (new-ref))) + (to-cps + (library-define-expression expr) + (add-continuation + (make-kargs (list ref) + (make-update (library-define-ref expr) ref continuation))) + add-continuation))) ((define-syntax? expr) ; no-op - (values (make-atom (make-constant #f) continuation) (make-soup))) + (make-atom (make-constant #f) continuation)) ((if? expr) - (let-values (((id) (next-id)) - ((test-ref) (new-ref)) - ((true-id) (next-id)) - ((false-id) (next-id)) - ((true-expr true-soup) (to-cps (if-consequent expr) continuation next-id)) - ((false-expr false-soup) (to-cps (if-alternate expr) continuation next-id))) - (cps-merge - (merge true-soup false-soup - (make-soup (cons id (make-kargs (list test-ref) - (make-branch test-ref true-id false-id))) - (cons true-id (make-kargs '() true-expr)) - (cons false-id (make-kargs '() false-expr)))) - (to-cps (if-test expr) id next-id)))) + (let* ((true-id (add-continuation + (make-klabel + (to-cps (if-consequent expr) continuation add-continuation)))) + (false-id (add-continuation + (make-klabel + (to-cps (if-alternate expr) continuation add-continuation)))) + (test-ref (new-ref)) + (branch-id (add-continuation + (make-kargs (list test-ref) + (make-branch test-ref true-id false-id))))) + (to-cps (if-test expr) branch-id add-continuation))) + ((call? expr) + ; Technically the order of evaluation is unspecified. We evaluate + ; expressions left to right. + (loop with terms = (cons (call-procedure expr) (call-arguments expr)) + with temps = (map (lambda (x) (new-ref)) terms) + with expr = (make-call-closure (car temps) (cdr temps) continuation) + for term in (reverse terms) + for temp in (reverse temps) + do (set! expr (to-cps term + (add-continuation + (make-kargs (list temp) expr)) + add-continuation)) + finally (return expr))) + ((sequence? expr) + (to-cps + (sequence-head expr) + (add-continuation + (make-klabel + (to-cps (sequence-tail expr) continuation add-continuation))) + add-continuation)) (else (error "unexpected type in to-cps" expr)))) @@ -92,11 +112,13 @@ ; By convention the continuation at key 0 is the entrypoint. (define (ir1->ir2 program) (define current-continuation-id 0) - (define (next-id) + (define soup (make-map (lambda (x) x) <)) + (define (add-continuation continuation) (set! current-continuation-id (+ 1 current-continuation-id)) + (set! soup (insert soup + current-continuation-id + continuation)) current-continuation-id) - (define ktail (next-id)) - (define-values (expr m) (to-cps program ktail next-id)) - (set! m (insert m ktail (make-ktail))) - (set! m (insert m 0 (make-kargs '() expr))) - m))) + (define ktail (add-continuation (make-ktail))) + (define entrypoint (to-cps program ktail add-continuation)) + (insert soup 0 (make-klabel entrypoint))))) diff --git a/csc/ir2.csc b/csc/ir2.csc index bd2c1b6..fc31ce3 100644 --- a/csc/ir2.csc +++ b/csc/ir2.csc @@ -7,14 +7,21 @@ branch-false branch-true branch? + call-closure-args + call-closure-closure + call-closure? ir2=? kargs-expression kargs-refs kargs? + klabel-expression + klabel? ktail? make-atom make-branch + make-call-closure make-kargs + make-klabel make-ktail make-update update-atom @@ -112,6 +119,15 @@ (false branch-false)) + ; Calls the given closure. Closure is an atom, and args is a list of atoms. + (define-record-type <call-closure> + (make-call-closure closure args continuation) + call-closure? + (closure call-closure-closure) + (args call-closure-args) + (continuation call-closure-continuation)) + + ; CPS continuations. @@ -130,6 +146,13 @@ (expression kargs-expression)) + ; Ignores any incoming values and evaluates the given expression. + (define-record-type <klabel> + (make-klabel expression) + klabel? + (expression klabel-expression)) + + (define (ir2=?-sametype x y) (cond ((and (atom? x) (atom? y)) @@ -139,6 +162,21 @@ (and (ir1=? (update-ref x) (update-ref y)) (ir1=? (update-atom x) (update-atom y)) (= (update-continuation x) (update-continuation y)))) + ((and (branch? x) (branch? y)) + (and (ir1=? (branch-atom x) (branch-atom y)) + (= (branch-true x) (branch-true y)) + (= (branch-false x) (branch-false y)))) + ((and (call-closure? x) (call-closure? y)) + (let ((x-args (call-closure-args x)) + (y-args (call-closure-args y))) + (and (ir1=? (call-closure-closure x) (call-closure-closure y)) + (= (length x-args) (length y-args)) + (loop for x-arg in (call-closure-args x) + for y-arg in (call-closure-args y) + unless (ir1=? x-arg y-arg) + return #f + finally (return #t)) + (= (call-closure-continuation x) (call-closure-continuation y))))) ((and (ktail? x) (ktail? y)) #t) ((and (kargs? x) (kargs? y)) (let ((x-refs (kargs-refs x)) @@ -150,10 +188,8 @@ return #f finally (return #t)) (ir2=? (kargs-expression x) (kargs-expression y))))) - ((and (branch? x) (branch? y)) - (and (ir1=? (branch-atom x) (branch-atom y)) - (= (branch-true x) (branch-true y)) - (= (branch-false x) (branch-false y)))) + ((and (klabel? x) (klabel? y)) + (ir2=? (klabel-expression x) (klabel-expression y))) (else #f))) |