From 7004f8d7a381fcd2f9c63ae04d99dc67161158f4 Mon Sep 17 00:00:00 2001 From: Rose Hogenson Date: Sat, 25 Jun 2022 16:14:47 -0700 Subject: Continue work on continuation passing style. --- csc/cps-test.csc | 71 ++++++++++++++++++++++++++++++---- csc/cps.csc | 67 ++++++++++++++++++++++++++++---- csc/ir1.csc | 20 ++++------ csc/ir2.csc | 108 ++++++++++++++++++++++++++++++++++++++++++++++------ csc/macros-test.csc | 1 - csc/macros.csc | 11 +++--- 6 files changed, 235 insertions(+), 43 deletions(-) diff --git a/csc/cps-test.csc b/csc/cps-test.csc index dd66078..5bd6c1a 100644 --- a/csc/cps-test.csc +++ b/csc/cps-test.csc @@ -1,18 +1,75 @@ (import (scheme base) + (only (csc hash-map) + map->alist) + (only (csc ir1) + make-constant + make-lexical-ref + make-lexical-set + make-library-ref) (only (csc ir2) ir2=? make-atom - make-tail - make-constant) + make-kargs + make-ktail + make-update) + (only (csc loop) + loop + return) + (only (csc sort) sort) (only (csc testing) assert-equal test) (csc cps)) +(define (soup->alist s) + (sort (lambda (x y) (< (car x) (car y))) (map->alist s))) + + +(define (soup=? x y) + (and (= (length x) (length y)) + (loop for x* in x + for y* in y + unless (and (= (car x*) (car y*)) + (ir2=? (cdr x*) (cdr y*))) + return #f + finally (return #t)))) + + (test atom-const - (assert-equal ir2=? - (make-atom - (make-constant 5) - (make-tail)) - (ir1->ir2 (make-constant 5)))) + (assert-equal soup=? + (list + (cons 0 (make-kargs '() + (make-atom (make-constant 5) 1))) + (cons 1 (make-ktail))) + (soup->alist (ir1->ir2 (make-constant 5))))) + + +(test atom-lexical-ref + (assert-equal soup=? + (list + (cons 0 (make-kargs '() + (make-atom (make-lexical-ref 'var #f) 1))) + (cons 1 (make-ktail))) + (soup->alist (ir1->ir2 (make-lexical-ref 'var #f))))) + + +(test atom-library-ref + (assert-equal soup=? + (list + (cons 0 (make-kargs '() + (make-atom (make-library-ref 'var '(csc builtins)) 1))) + (cons 1 (make-ktail))) + (soup->alist (ir1->ir2 (make-library-ref 'var '(csc builtins)))))) + + +(test lexical-set + (assert-equal soup=? + (list + (cons 0 (make-kargs '() + (make-atom (make-constant 5) 2))) + (cons 1 (make-ktail)) + (cons 2 (make-kargs (list (make-lexical-ref 'generated-symbol #f)) + (make-update (make-lexical-ref 'var #f) + (make-lexical-ref 'generated-symbol #f) 1)))) + (soup->alist (ir1->ir2 (make-lexical-set (make-lexical-ref 'var #f) (make-constant 5)))))) diff --git a/csc/cps.csc b/csc/cps.csc index bd4f088..26e0591 100644 --- a/csc/cps.csc +++ b/csc/cps.csc @@ -1,26 +1,79 @@ (define-library (csc cps) (export ir1->ir2) - (import (only (csc ir1) - make-constant + (import (only (csc gensym) gensym) + (only (csc hash-map) + alist->map + insert + merge) + (only (csc ir1) constant? lexical-ref? - library-ref?) + lexical-set-expression + lexical-set-ref + lexical-set? + library-define-expression + library-define-ref + library-define? + library-ref? + make-constant + make-lexical-ref) (only (csc ir2) make-atom - make-tail) + make-kargs + make-ktail + make-update) (scheme base)) (begin - (define (to-cps expr continuation) + (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) (cond ((or (constant? expr) (lexical-ref? expr) (library-ref? expr)) - (make-atom expr continuation)) + (values (make-atom expr continuation) (make-soup))) + ((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)))) + ((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)))) (else (error "unexpected type in to-cps" expr)))) + ; Returns a map from integers to CPS continuations. + ; By convention the continuation at key 0 is the entrypoint. (define (ir1->ir2 program) - (to-cps program (make-tail))))) + (define current-continuation-id 0) + (define (next-id) + (set! current-continuation-id (+ 1 current-continuation-id)) + 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))) diff --git a/csc/ir1.csc b/csc/ir1.csc index ab60fc9..76faef9 100644 --- a/csc/ir1.csc +++ b/csc/ir1.csc @@ -32,12 +32,10 @@ lexical-ref-name lexical-ref? lexical-set-expression - lexical-set-gensym - lexical-set-name + lexical-set-ref lexical-set? library-define-expression - library-define-library - library-define-name + library-define-ref library-define? library-ref-library library-ref-name @@ -97,21 +95,19 @@ ; name gensym expression ; Sets a lexically-bound variable. (define-record-type - (make-lexical-set name gensym expression) + (make-lexical-set ref expression) lexical-set? - (name lexical-set-name) - (gensym lexical-set-gensym) + (ref lexical-set-ref) (expression lexical-set-expression)) ; name expression ; Defines a new variable in the current library. (define-record-type - (make-library-define name expression library) + (make-library-define ref expression) library-define? - (name library-define-name) - (expression library-define-expression) - (library library-define-library)) + (ref library-define-ref) + (expression library-define-expression)) ; name transformer @@ -212,7 +208,7 @@ (equal? (library-ref-library x) (library-ref-library y))) ((and (lexical-set? x) (lexical-set? y)) (and - (symbol=? (lexical-set-name x) (lexical-set-name y)) + (ir1=? (lexical-set-ref x) (lexical-set-ref y)) (ir1=? (lexical-set-expression x) (lexical-set-expression y)))) ((and (library-define? x) (library-define? y)) (and diff --git a/csc/ir2.csc b/csc/ir2.csc index 708d7b1..6ab0705 100644 --- a/csc/ir2.csc +++ b/csc/ir2.csc @@ -4,28 +4,82 @@ atom-expression atom? ir2=? + kargs-expression + kargs-refs + kargs? + ktail? make-atom - make-tail - tail? + make-kargs + make-ktail + make-update + update-atom + update-continuation + update-ref ; Re-exports from IR1. constant-expression constant? - make-constant) + lexical-ref-gensym + lexical-ref-name + lexical-ref? + library-ref-library + library-ref-name + library-ref? + make-constant + make-lexical-ref + lexical-set-expression + lexical-set-ref + lexical-set? + make-lexical-set + make-library-ref) (import (scheme base) (only (csc ir1) constant? ir1=? - make-constant)) + lexical-ref-gensym + lexical-ref-name + lexical-ref? + lexical-set-expression + lexical-set-ref + lexical-set? + library-ref-library + library-ref-name + library-ref? + make-constant + make-lexical-ref + make-lexical-set + make-library-ref) + (only (csc loop) + loop + return)) (begin ; This library defines the intermediate representation IR2. ; It's CPS time bitch. + ; CPS atom: + ; An atom is a value that can be computed immediately without + ; any subexpressions. + ; Atoms consist of + ; - constant, + ; - lexical-ref, + ; - or library-ref + + ; CPS expressions: + ; CPS expressions are similar to IR1 expressions, + ; but constrained not to have any subexpressions except atoms. + ; And they take a continuation. + + ; CPS continuations + ; There are a few continuations. + ; Continuations are identified by an integer ID into the + ; continuation map. + ; Guile calls this map the "continuation soup". + ; CPS expressions. - ; An atom consists of an ir1 expression and a continuation. + ; An atom consists of an atom and a continuation. (define-record-type (make-atom expression continuation) atom? @@ -33,21 +87,53 @@ (continuation atom-continuation)) + ; Modifies a library or lexically bound variable to the given atom. + (define-record-type + (make-update ref atom continuation) + update? + (ref update-ref) + (atom update-atom) + (continuation update-continuation)) + + ; CPS continuations. - ; tail is the tail continuation. - (define-record-type - (make-tail) - tail?) + ; The tail continuation. + (define-record-type + (make-ktail) + ktail?) + + + ; Binds the incoming values to the given lexically-bound variables + ; and then evaluates expression. + (define-record-type + (make-kargs refs expression) + kargs? + (refs kargs-refs) + (expression kargs-expression)) (define (ir2=?-sametype x y) (cond ((and (atom? x) (atom? y)) (and (ir1=? (atom-expression x) (atom-expression y)) - (ir2=? (atom-continuation x) (atom-continuation y)))) - ((and (tail? x) (tail? y)) #t) + (= (atom-continuation x) (atom-continuation y)))) + ((and (update? x) (update? y)) + (and (ir1=? (update-ref x) (update-ref y)) + (ir1=? (update-atom x) (update-atom y)) + (= (update-continuation x) (update-continuation y)))) + ((and (ktail? x) (ktail? y)) #t) + ((and (kargs? x) (kargs? y)) + (let ((x-refs (kargs-refs x)) + (y-refs (kargs-refs y))) + (and (= (length x-refs) (length y-refs)) + (loop for x-ref in x-refs + for y-ref in y-refs + unless (ir1=? x-ref y-ref) + return #f + finally (return #t)) + (ir2=? (kargs-expression x) (kargs-expression y))))) (else #f))) diff --git a/csc/macros-test.csc b/csc/macros-test.csc index 92fda88..fd9d1ae 100644 --- a/csc/macros-test.csc +++ b/csc/macros-test.csc @@ -6,7 +6,6 @@ lexical-ref-name lexical-ref? lexical-set-expression - lexical-set-name lexical-set? make-constant make-lambda-case diff --git a/csc/macros.csc b/csc/macros.csc index dfcfa64..ff5b63a 100644 --- a/csc/macros.csc +++ b/csc/macros.csc @@ -27,7 +27,7 @@ lexical-ref-gensym lexical-ref? library-define-expression - library-define-name + library-define-ref library-define? library-ref-name library-ref? @@ -681,7 +681,7 @@ (define expanded-expr (expand-syntax-object expr)) (cond ((library-define? expanded-expr) - (let ((name (library-define-name expanded-expr)) + (let ((name (library-ref-name (library-define-ref expanded-expr))) (g (gensym))) (loop (with-binding name (make-lexical-ref name g) (syntax-map cdr body)) (cons name names) @@ -731,9 +731,10 @@ (syntax-case x ((_ symbol expression) (make-library-define - (identifier-name symbol) - (expand-syntax-object expression) - (environment-library (syntax-object-environment x)))) + (make-library-ref + (identifier-name symbol) + (environment-library (syntax-object-environment x))) + (expand-syntax-object expression))) (_ (raise-syntax-error "unexpected form in builtin-define" x)))))) -- cgit v1.3.1