From 13085a828f6d31c6aaf1e0c403dbe4d1b9dd1449 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 13 Nov 2013 19:58:55 +0100 Subject: [PATCH] Replace ($var sym) with ($values (sym)). * module/language/cps.scm: Remove $var. Replaced by $values with one value. * module/language/cps/arities.scm: * module/language/cps/closure-conversion.scm: * module/language/cps/compile-rtl.scm: * module/language/cps/dfg.scm: * module/language/cps/slot-allocation.scm: * module/language/cps/verify.scm: * module/language/tree-il/compile-cps.scm: Adapt all the world. --- module/language/cps.scm | 10 ++------- module/language/cps/arities.scm | 8 +++---- module/language/cps/closure-conversion.scm | 13 ++++------- module/language/cps/compile-rtl.scm | 17 ++++++++------ module/language/cps/dfg.scm | 5 +---- module/language/cps/slot-allocation.scm | 26 +++++++++++++++++++--- module/language/cps/verify.scm | 2 -- module/language/tree-il/compile-cps.scm | 9 ++++---- 8 files changed, 49 insertions(+), 41 deletions(-) diff --git a/module/language/cps.scm b/module/language/cps.scm index 4dc88eb2f..57d95d410 100644 --- a/module/language/cps.scm +++ b/module/language/cps.scm @@ -122,7 +122,7 @@ $kif $ktrunc $kargs $kentry $ktail $kclause ;; Expressions. - $var $void $const $prim $fun $call $primcall $values $prompt + $void $const $prim $fun $call $primcall $values $prompt ;; Building macros. let-gensyms @@ -178,7 +178,6 @@ (define-cps-type $kclause arity cont) ;; Expressions. -(define-cps-type $var sym) (define-cps-type $void) (define-cps-type $const val) (define-cps-type $prim name) @@ -228,9 +227,8 @@ (define-syntax build-cps-exp (syntax-rules (unquote - $var $void $const $prim $fun $call $primcall $values $prompt) + $void $const $prim $fun $call $primcall $values $prompt) ((_ (unquote exp)) exp) - ((_ ($var sym)) (make-$var sym)) ((_ ($void)) (make-$void)) ((_ ($const val)) (make-$const val)) ((_ ($prim name)) (make-$prim name)) @@ -326,8 +324,6 @@ ;; Calls. (('continue k exp) (build-cps-term ($continue k (src exp) ,(parse-cps exp)))) - (('var sym) - (build-cps-exp ($var sym))) (('void) (build-cps-exp ($void))) (('const exp) @@ -382,8 +378,6 @@ ;; Calls. (($ $continue k src exp) `(continue ,k ,(unparse-cps exp))) - (($ $var sym) - `(var ,sym)) (($ $void) `(void)) (($ $const val) diff --git a/module/language/cps/arities.scm b/module/language/cps/arities.scm index 387187ccf..10056831c 100644 --- a/module/language/cps/arities.scm +++ b/module/language/cps/arities.scm @@ -83,7 +83,7 @@ (rewrite-cps-term (lookup-cont k conts) (($ $ktail) ,(rewrite-cps-term exp - (($var sym) + (($values (sym)) ($continue ktail src ($primcall 'return (sym)))) (_ ,(let-gensyms (k* v) @@ -117,7 +117,7 @@ ((or ($ $void) ($ $const) ($ $prim) - ($ $var)) + ($ $values (_))) ,(adapt-exp 1 k src exp)) (($ $fun) ,(adapt-exp 1 k src (fix-arities exp))) @@ -149,8 +149,8 @@ ($continue k src ($call p* args))))) ($continue k* src ($prim name))))))))) (($ $values) - ;; Values nodes are inserted by CPS optimization passes, so - ;; we assume they are correct. + ;; Non-unary values nodes are inserted by CPS optimization + ;; passes, so we assume they are correct. ($continue k src ,exp)) (($ $prompt) ($continue k src ,exp)))) diff --git a/module/language/cps/closure-conversion.scm b/module/language/cps/closure-conversion.scm index 3cea53aa9..11d388b4e 100644 --- a/module/language/cps/closure-conversion.scm +++ b/module/language/cps/closure-conversion.scm @@ -165,12 +165,6 @@ convert functions to flat closures." (init-closure src sym fun-free self bound body) (union free (difference fun-free bound)))))))))) - (($ $continue k src ($ $var sym)) - (convert-free-var sym self bound - (lambda (sym) - (values (build-cps-term ($continue k src ($var sym))) - '())))) - (($ $continue k src (or ($ $void) ($ $const) @@ -189,9 +183,10 @@ convert functions to flat closures." (let-gensyms (kinit v) (build-cps-term ($letk ((kinit ($kargs (v) (v) - ,(init-closure src v free self bound - (build-cps-term - ($continue k src ($var v))))))) + ,(init-closure + src v free self bound + (build-cps-term + ($continue k src ($values (v)))))))) ($continue kinit src ($fun src* meta free ,body))))) (difference free bound)))))) diff --git a/module/language/cps/compile-rtl.scm b/module/language/cps/compile-rtl.scm index e45773f48..e23441493 100644 --- a/module/language/cps/compile-rtl.scm +++ b/module/language/cps/compile-rtl.scm @@ -215,11 +215,17 @@ (let ((tail-slots (cdr (iota (1+ (length args)))))) (for-each maybe-load-constant tail-slots args)) (emit-tail-call asm (1+ (length args)))) + (($ $values (arg)) + (if (slot arg) + (emit-return asm (slot arg)) + (begin + (emit-load-constant asm 1 (constant arg)) + (emit-return asm 1)))) (($ $values args) + (for-each (match-lambda + ((src . dst) (emit-mov asm dst src))) + (lookup-parallel-moves label allocation)) (let ((tail-slots (cdr (iota (1+ (length args)))))) - (for-each (match-lambda - ((src . dst) (emit-mov asm dst src))) - (lookup-parallel-moves label allocation)) (for-each maybe-load-constant tail-slots args)) (emit-reset-frame asm (1+ (length args))) (emit-return-values asm)) @@ -228,9 +234,6 @@ (define (compile-value label exp dst nlocals) (match exp - (($ $var sym) - (maybe-mov dst (slot sym))) - ;; FIXME: Remove ($var sym), replace with ($values (sym)) (($ $values (arg)) (or (maybe-load-constant dst arg) (maybe-mov dst (slot arg)))) @@ -397,7 +400,7 @@ (unless (eq? kf next-label) (emit-br asm kf))))) (match exp - (($ $var sym) (unary emit-br-if-true sym)) + (($ $values (sym)) (unary emit-br-if-true sym)) (($ $primcall 'null? (a)) (unary emit-br-if-null a)) (($ $primcall 'nil? (a)) (unary emit-br-if-nil a)) (($ $primcall 'pair? (a)) (unary emit-br-if-pair a)) diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm index 365f45525..d6cfcf38c 100644 --- a/module/language/cps/dfg.scm +++ b/module/language/cps/dfg.scm @@ -691,9 +691,6 @@ (($ $continue k src exp) (use-k! k) (match exp - (($ $var sym) - (use! sym)) - (($ $call proc args) (use! proc) (for-each use! args)) @@ -849,7 +846,7 @@ (lambda (use) (match (find-expression (lookup-cont use conts)) (($ $call) #f) - (($ $values) #f) + (($ $values (_ _ . _)) #f) (($ $primcall 'free-ref (closure slot)) (not (eq? sym slot))) (($ $primcall 'free-set! (closure slot value)) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index 580d0f97e..f3c3f1c78 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -346,9 +346,6 @@ are comparable with eqv?. A tmp slot may be used." live-slots))) (match exp - (($ $var sym) - (use sym live-slots)) - (($ $call proc args) (match (lookup-cont k (dfg-cont-table dfg)) (($ $ktail) @@ -382,6 +379,29 @@ are comparable with eqv?. A tmp slot may be used." (($ $primcall name args) (fold use live-slots args)) + (($ $values (arg)) + (use arg live-slots)) + + (($ $values args) + (let ((live-slots* (fold use live-slots args))) + (define (compute-dst-slots) + (match (lookup-cont k (dfg-cont-table dfg)) + (($ $ktail) + (let ((tail-nlocals (1+ (length args)))) + (set! nlocals (max nlocals tail-nlocals)) + (cdr (iota tail-nlocals)))) + (_ + (let* ((src-slots (map (cut lookup-slot <> allocation) args)) + (dst-syms (lookup-bound-syms k dfg)) + (dst-live-slots (fold (cut allocate! <> k <> <>) + live-slots* dst-syms src-slots))) + (map (cut lookup-slot <> allocation) dst-syms))))) + + (parallel-move! label + (map (cut lookup-slot <> allocation) args) + live-slots live-slots* + (compute-dst-slots)))) + (($ $values args) (let ((live-slots* (fold use live-slots args))) (define (compute-dst-slots) diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm index 3772f21d2..ff23aa317 100644 --- a/module/language/cps/verify.scm +++ b/module/language/cps/verify.scm @@ -113,8 +113,6 @@ (define (visit-expression exp k-env v-env) (match exp - (($ $var sym) - (check-var sym v-env)) (($ $void) #t) (($ $const val) diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index c705694ab..637511817 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -185,7 +185,8 @@ knext (lambda (k) (build-cps-term - ($letk ((kbound ($kargs () () ($continue k src ($var sym)))) + ($letk ((kbound ($kargs () () ($continue k src + ($values (sym))))) (kunbound ($kargs () () ,(convert init k subst)))) ,(unbound? src sym kunbound kbound)))))))))))) @@ -231,8 +232,8 @@ (($ src name sym) (match (assq-ref subst sym) ((box #t) (build-cps-term ($continue k src ($primcall 'box-ref (box))))) - ((subst #f) (build-cps-term ($continue k src ($var subst)))) - (#f (build-cps-term ($continue k src ($var sym)))))) + ((subst #f) (build-cps-term ($continue k src ($values (subst))))) + (#f (build-cps-term ($continue k src ($values (sym))))))) (($ src) (build-cps-term ($continue k src ($void)))) @@ -522,7 +523,7 @@ (_ (convert-arg test (lambda (test) (build-cps-term - ($continue kif src ($var test))))))))))) + ($continue kif src ($values (test)))))))))))) (($ src name gensym exp) (convert-arg exp