mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-18 10:10:23 +02:00
Code Activity

Replace ($var sym) with ($values (sym)).

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2013-11-13 19:58:55 +01:00
parent 4c906ad5a5
commit 13085a828f
8 changed files with 49 additions and 41 deletions
Download patch file Download diff file Expand all files Collapse all files

10
module/language/cps.scm
View file

@ -122,7 +122,7 @@
$kif $ktrunc $kargs $kentry $ktail $kclause $kif $ktrunc $kargs $kentry $ktail $kclause
;; Expressions. ;; Expressions.
$var $void $const $prim $fun $call $primcall $values $prompt $void $const $prim $fun $call $primcall $values $prompt
;; Building macros. ;; Building macros.
let-gensyms let-gensyms
@ -178,7 +178,6 @@
(define-cps-type $kclause arity cont) (define-cps-type $kclause arity cont)
;; Expressions. ;; Expressions.
(define-cps-type $var sym)
(define-cps-type $void) (define-cps-type $void)
(define-cps-type $const val) (define-cps-type $const val)
(define-cps-type $prim name) (define-cps-type $prim name)
@ -228,9 +227,8 @@
(define-syntax build-cps-exp (define-syntax build-cps-exp
(syntax-rules (unquote (syntax-rules (unquote
$var $void $const $prim $fun $call $primcall $values $prompt) $void $const $prim $fun $call $primcall $values $prompt)
((_ (unquote exp)) exp) ((_ (unquote exp)) exp)
((_ ($var sym)) (make-$var sym))
((_ ($void)) (make-$void)) ((_ ($void)) (make-$void))
((_ ($const val)) (make-$const val)) ((_ ($const val)) (make-$const val))
((_ ($prim name)) (make-$prim name)) ((_ ($prim name)) (make-$prim name))
@ -326,8 +324,6 @@
;; Calls. ;; Calls.
(('continue k exp) (('continue k exp)
(build-cps-term ($continue k (src exp) ,(parse-cps exp)))) (build-cps-term ($continue k (src exp) ,(parse-cps exp))))
(('var sym)
(build-cps-exp ($var sym)))
(('void) (('void)
(build-cps-exp ($void))) (build-cps-exp ($void)))
(('const exp) (('const exp)
@ -382,8 +378,6 @@
;; Calls. ;; Calls.
(($ $continue k src exp) (($ $continue k src exp)
`(continue ,k ,(unparse-cps exp))) `(continue ,k ,(unparse-cps exp)))
(($ $var sym)
`(var ,sym))
(($ $void) (($ $void)
`(void)) `(void))
(($ $const val) (($ $const val)

8
module/language/cps/arities.scm
View file

@ -83,7 +83,7 @@
(rewrite-cps-term (lookup-cont k conts) (rewrite-cps-term (lookup-cont k conts)
(($ $ktail) (($ $ktail)
,(rewrite-cps-term exp ,(rewrite-cps-term exp
(($var sym) (($values (sym))
($continue ktail src ($primcall 'return (sym)))) ($continue ktail src ($primcall 'return (sym))))
(_ (_
,(let-gensyms (k* v) ,(let-gensyms (k* v)
@ -117,7 +117,7 @@
((or ($ $void) ((or ($ $void)
($ $const) ($ $const)
($ $prim) ($ $prim)
($ $var)) ($ $values (_)))
,(adapt-exp 1 k src exp)) ,(adapt-exp 1 k src exp))
(($ $fun) (($ $fun)
,(adapt-exp 1 k src (fix-arities exp))) ,(adapt-exp 1 k src (fix-arities exp)))
@ -149,8 +149,8 @@
($continue k src ($call p* args))))) ($continue k src ($call p* args)))))
($continue k* src ($prim name))))))))) ($continue k* src ($prim name)))))))))
(($ $values) (($ $values)
;; Values nodes are inserted by CPS optimization passes, so ;; Non-unary values nodes are inserted by CPS optimization
;; we assume they are correct. ;; passes, so we assume they are correct.
($continue k src ,exp)) ($continue k src ,exp))
(($ $prompt) (($ $prompt)
($continue k src ,exp)))) ($continue k src ,exp))))

13
module/language/cps/closure-conversion.scm
View file

@ -165,12 +165,6 @@ convert functions to flat closures."
(init-closure src sym fun-free self bound body) (init-closure src sym fun-free self bound body)
(union free (difference fun-free bound)))))))))) (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 (($ $continue k src
(or ($ $void) (or ($ $void)
($ $const) ($ $const)
@ -189,9 +183,10 @@ convert functions to flat closures."
(let-gensyms (kinit v) (let-gensyms (kinit v)
(build-cps-term (build-cps-term
($letk ((kinit ($kargs (v) (v) ($letk ((kinit ($kargs (v) (v)
,(init-closure src v free self bound ,(init-closure
(build-cps-term src v free self bound
($continue k src ($var v))))))) (build-cps-term
($continue k src ($values (v))))))))
($continue kinit src ($fun src* meta free ,body))))) ($continue kinit src ($fun src* meta free ,body)))))
(difference free bound)))))) (difference free bound))))))

17
module/language/cps/compile-rtl.scm
View file

@ -215,11 +215,17 @@
(let ((tail-slots (cdr (iota (1+ (length args)))))) (let ((tail-slots (cdr (iota (1+ (length args))))))
(for-each maybe-load-constant tail-slots args)) (for-each maybe-load-constant tail-slots args))
(emit-tail-call asm (1+ (length 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) (($ $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)))))) (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)) (for-each maybe-load-constant tail-slots args))
(emit-reset-frame asm (1+ (length args))) (emit-reset-frame asm (1+ (length args)))
(emit-return-values asm)) (emit-return-values asm))
@ -228,9 +234,6 @@
(define (compile-value label exp dst nlocals) (define (compile-value label exp dst nlocals)
(match exp (match exp
(($ $var sym)
(maybe-mov dst (slot sym)))
;; FIXME: Remove ($var sym), replace with ($values (sym))
(($ $values (arg)) (($ $values (arg))
(or (maybe-load-constant dst arg) (or (maybe-load-constant dst arg)
(maybe-mov dst (slot arg)))) (maybe-mov dst (slot arg))))
@ -397,7 +400,7 @@
(unless (eq? kf next-label) (unless (eq? kf next-label)
(emit-br asm kf))))) (emit-br asm kf)))))
(match exp (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 'null? (a)) (unary emit-br-if-null a))
(($ $primcall 'nil? (a)) (unary emit-br-if-nil a)) (($ $primcall 'nil? (a)) (unary emit-br-if-nil a))
(($ $primcall 'pair? (a)) (unary emit-br-if-pair a)) (($ $primcall 'pair? (a)) (unary emit-br-if-pair a))

5
module/language/cps/dfg.scm
View file

@ -691,9 +691,6 @@
(($ $continue k src exp) (($ $continue k src exp)
(use-k! k) (use-k! k)
(match exp (match exp
(($ $var sym)
(use! sym))
(($ $call proc args) (($ $call proc args)
(use! proc) (use! proc)
(for-each use! args)) (for-each use! args))
@ -849,7 +846,7 @@
(lambda (use) (lambda (use)
(match (find-expression (lookup-cont use conts)) (match (find-expression (lookup-cont use conts))
(($ $call) #f) (($ $call) #f)
(($ $values) #f) (($ $values (_ _ . _)) #f)
(($ $primcall 'free-ref (closure slot)) (($ $primcall 'free-ref (closure slot))
(not (eq? sym slot))) (not (eq? sym slot)))
(($ $primcall 'free-set! (closure slot value)) (($ $primcall 'free-set! (closure slot value))

26
module/language/cps/slot-allocation.scm
View file

@ -346,9 +346,6 @@ are comparable with eqv?. A tmp slot may be used."
live-slots))) live-slots)))
(match exp (match exp
(($ $var sym)
(use sym live-slots))
(($ $call proc args) (($ $call proc args)
(match (lookup-cont k (dfg-cont-table dfg)) (match (lookup-cont k (dfg-cont-table dfg))
(($ $ktail) (($ $ktail)
@ -382,6 +379,29 @@ are comparable with eqv?. A tmp slot may be used."
(($ $primcall name args) (($ $primcall name args)
(fold use live-slots 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) (($ $values args)
(let ((live-slots* (fold use live-slots args))) (let ((live-slots* (fold use live-slots args)))
(define (compute-dst-slots) (define (compute-dst-slots)

2
module/language/cps/verify.scm
View file

@ -113,8 +113,6 @@
(define (visit-expression exp k-env v-env) (define (visit-expression exp k-env v-env)
(match exp (match exp
(($ $var sym)
(check-var sym v-env))
(($ $void) (($ $void)
#t) #t)
(($ $const val) (($ $const val)

9
module/language/tree-il/compile-cps.scm
View file

@ -185,7 +185,8 @@
knext knext
(lambda (k) (lambda (k)
(build-cps-term (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)))) (kunbound ($kargs () () ,(convert init k subst))))
,(unbound? src sym kunbound kbound)))))))))))) ,(unbound? src sym kunbound kbound))))))))))))
@ -231,8 +232,8 @@
(($ <lexical-ref> src name sym) (($ <lexical-ref> src name sym)
(match (assq-ref subst sym) (match (assq-ref subst sym)
((box #t) (build-cps-term ($continue k src ($primcall 'box-ref (box))))) ((box #t) (build-cps-term ($continue k src ($primcall 'box-ref (box)))))
((subst #f) (build-cps-term ($continue k src ($var subst)))) ((subst #f) (build-cps-term ($continue k src ($values (subst)))))
(#f (build-cps-term ($continue k src ($var sym)))))) (#f (build-cps-term ($continue k src ($values (sym)))))))
(($ <void> src) (($ <void> src)
(build-cps-term ($continue k src ($void)))) (build-cps-term ($continue k src ($void))))
@ -522,7 +523,7 @@
(_ (convert-arg test (_ (convert-arg test
(lambda (test) (lambda (test)
(build-cps-term (build-cps-term
($continue kif src ($var test))))))))))) ($continue kif src ($values (test))))))))))))
(($ <lexical-set> src name gensym exp) (($ <lexical-set> src name gensym exp)
(convert-arg exp (convert-arg exp