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

Prepare for decoupling of var/label name uniqueness

Browse source 
* module/language/cps/simplify.scm (compute-beta-reductions):
  (beta-reduce): Separate state into two tables, so we can relax current
  guarantee that vars and labels are mutually unique.
This commit is contained in:
Andy Wingo 2014-03-28 21:55:46 +01:00
parent eb60b4136b
commit b9e601d20d
1 changed files with 10 additions and 8 deletions
Download patch file Download diff file Expand all files Collapse all files

18
module/language/cps/simplify.scm
View file

@ -26,6 +26,7 @@
(define-module (language cps simplify) (define-module (language cps simplify)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (language cps) #:use-module (language cps)
#:use-module (language cps dfg) #:use-module (language cps dfg)
@ -167,7 +168,8 @@
;; A continuation's body can be inlined in place of a $values ;; A continuation's body can be inlined in place of a $values
;; expression if the continuation is a $kargs. It should only be ;; expression if the continuation is a $kargs. It should only be
;; inlined if it is used only once, and not recursively. ;; inlined if it is used only once, and not recursively.
(let ((table (make-hash-table)) (let ((var-table (make-hash-table))
(k-table (make-hash-table))
(dfg (compute-dfg fun))) (dfg (compute-dfg fun)))
(define (visit-cont cont) (define (visit-cont cont)
(match cont (match cont
@ -198,8 +200,8 @@
;; -> body mapping in the table. Also store the ;; -> body mapping in the table. Also store the
;; substitutions for the variables bound by the inlined ;; substitutions for the variables bound by the inlined
;; continuation. ;; continuation.
(for-each (cut hashq-set! table <> <>) syms args) (for-each (cut hashq-set! var-table <> <>) syms args)
(hashq-set! table k body)) (hashq-set! k-table k body))
(_ #f))) (_ #f)))
(_ #f))) (_ #f)))
(($ $continue k src (and fun ($ $fun))) (($ $continue k src (and fun ($ $fun)))
@ -211,12 +213,12 @@
(($ $fun src meta free body) (($ $fun src meta free body)
(visit-cont body)))) (visit-cont body))))
(visit-fun fun) (visit-fun fun)
table)) (values var-table k-table)))
(define (beta-reduce fun) (define (beta-reduce fun)
(let ((table (compute-beta-reductions fun))) (let-values (((var-table k-table) (compute-beta-reductions fun)))
(define (subst var) (define (subst var)
(cond ((hashq-ref table var) => subst) (cond ((hashq-ref var-table var) => subst)
(else var))) (else var)))
(define (must-visit-cont cont) (define (must-visit-cont cont)
(or (visit-cont cont) (or (visit-cont cont)
@ -224,7 +226,7 @@
(define (visit-cont cont) (define (visit-cont cont)
(match cont (match cont
(($ $cont sym cont) (($ $cont sym cont)
(and (not (hashq-ref table sym)) (and (not (hashq-ref k-table sym))
(rewrite-cps-cont cont (rewrite-cps-cont cont
(($ $kargs names syms body) (($ $kargs names syms body)
(sym ($kargs names syms ,(visit-term body)))) (sym ($kargs names syms ,(visit-term body))))
@ -247,7 +249,7 @@
,(visit-term body)))) ,(visit-term body))))
(($ $continue k src exp) (($ $continue k src exp)
(cond (cond
((hashq-ref table k) => visit-term) ((hashq-ref k-table k) => visit-term)
(else (else
(build-cps-term (build-cps-term
($continue k src ($continue k src