[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, wip-cps-bis, updated. v2.1.0-208-g3f72
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, wip-cps-bis, updated. v2.1.0-208-g3f72a53 |
|
Date: |
Sat, 17 Aug 2013 20:03:38 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=3f72a53948b536a61203d03d8de7a5eaa71a7f79
The branch, wip-cps-bis has been updated
via 3f72a53948b536a61203d03d8de7a5eaa71a7f79 (commit)
from 8499f0a37dbdf3d8f2eb7526fc2bb9fd4eab9098 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 3f72a53948b536a61203d03d8de7a5eaa71a7f79
Author: Andy Wingo <address@hidden>
Date: Sat Aug 17 22:00:14 2013 +0200
Add contification pass
* module/Makefile.am (CPS_LANG_SOURCES):
* module/language/cps/contification.scm: New pass.
* module/language/cps/compile-rtl.scm (optimize): Run contification.
(emit-rtl-sequence): Fix $values with one value.
* module/language/cps/dfg.scm (dfg-cont-table): Rename from
dfg-local-cont-table. It's local if the DFG is local, and global
otherwise.
(visit-entry, compute-local-dfg, compute-dfg): Factor compute-dfg into
interfaces that compute local or global dfgs.
(lookup-def, lookup-uses, find-call, call-expression)
(find-expression): New public interfaces.
(find-defining-term, find-constant-value, constant-needs-allocation?):
Reimplement in terms of the new interfaces.
(continuation-scope-contains?): New helper.
(variable-used-in?): New public interface.
(conservatively-dominates?): Alias continuation-scope-contains?.
* module/language/cps/slot-allocation.scm (allocate-slots): Adapt to DFG
changes.
* module/language/cps/reify-primitives.scm: Tighten imports.
-----------------------------------------------------------------------
Summary of changes:
module/Makefile.am | 1 +
module/language/cps/compile-rtl.scm | 60 +++---
module/language/cps/contification.scm | 210 +++++++++++++++++++++
module/language/cps/dfg.scm | 297 ++++++++++++++++++-----------
module/language/cps/reify-primitives.scm | 2 -
module/language/cps/slot-allocation.scm | 6 +-
6 files changed, 429 insertions(+), 147 deletions(-)
create mode 100644 module/language/cps/contification.scm
diff --git a/module/Makefile.am b/module/Makefile.am
index 5a0ff69..0e6fdf6 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -123,6 +123,7 @@ CPS_LANG_SOURCES =
\
language/cps/arities.scm \
language/cps/closure-conversion.scm \
language/cps/compile-rtl.scm \
+ language/cps/contification.scm \
language/cps/dfg.scm \
language/cps/primitives.scm \
language/cps/reify-primitives.scm \
diff --git a/module/language/cps/compile-rtl.scm
b/module/language/cps/compile-rtl.scm
index c4d4d17..a693692 100644
--- a/module/language/cps/compile-rtl.scm
+++ b/module/language/cps/compile-rtl.scm
@@ -27,6 +27,7 @@
#:use-module (language cps)
#:use-module (language cps arities)
#:use-module (language cps closure-conversion)
+ #:use-module (language cps contification)
#:use-module (language cps dfg)
#:use-module (language cps primitives)
#:use-module (language cps reify-primitives)
@@ -36,36 +37,37 @@
;; TODO: Source info, local var names. Needs work in the linker and the
;; debugger.
+(define (kw-arg-ref args kw default)
+ (match (memq kw args)
+ ((_ val . _) val)
+ (_ default)))
+
(define (optimize exp opts)
- ;; Calls to source-to-source optimization passes go here.
+ (define (run-pass exp pass kw default)
+ (if (kw-arg-ref opts kw default)
+ (pass exp)
+ exp))
- ;; Passes that are needed:
- ;;
- ;; * Contification: turn a $fun into a $cont if all calls to the $fun
- ;; return to the same continuation. This is a more rigorous
- ;; variant of our old "fixpoint labels allocation" optimization.
- ;;
- ;; * Test inlining, to inline some tests, turning:
- ;;
- ;; (let ((tmp (eq? x y))) (if tmp (kt) (kf))
- ;; => (if (eq? x y) (kt) (kf))
- ;;
- ;; * Abort contification: turning abort primcalls into continuation
- ;; calls, and eliding prompts if possible.
- ;;
- ;; * Common subexpression elimination. Desperately needed. Requires
- ;; effects analysis.
- ;;
- ;; * Loop peeling. Unrolls the first round through a loop if the
- ;; loop has effects that CSE can work on. Requires effects
- ;; analysis. When run before CSE, loop peeling is the equivalent
- ;; of loop-invariant code motion (LICM).
- ;;
- ;; * Generic simplification pass, to be run as needed. Used to
- ;; "clean up", both on the original raw input and after specific
- ;; optimization passes.
-
- exp)
+ ;; Calls to source-to-source optimization passes go here.
+ (let* ((exp (run-pass exp contify #:contify? #t)))
+ ;; Passes that are needed:
+ ;;
+ ;; * Abort contification: turning abort primcalls into continuation
+ ;; calls, and eliding prompts if possible.
+ ;;
+ ;; * Common subexpression elimination. Desperately needed. Requires
+ ;; effects analysis.
+ ;;
+ ;; * Loop peeling. Unrolls the first round through a loop if the
+ ;; loop has effects that CSE can work on. Requires effects
+ ;; analysis. When run before CSE, loop peeling is the equivalent
+ ;; of loop-invariant code motion (LICM).
+ ;;
+ ;; * Generic simplification pass, to be run as needed. Used to
+ ;; "clean up", both on the original raw input and after specific
+ ;; optimization passes.
+
+ exp))
(define (visit-funs proc exp)
(match exp
@@ -184,7 +186,7 @@
(let ((inst (prim-rtl-instruction name)))
(emit `(,inst ,dst ,@(map slot args)))))
(($ $values (arg))
- (or (maybe-load-constant (slot dst) arg)
+ (or (maybe-load-constant dst arg)
(maybe-mov dst (slot arg))))
(($ $prompt escape? tag handler)
(emit `(prompt ,escape? ,tag ,handler))))
diff --git a/module/language/cps/contification.scm
b/module/language/cps/contification.scm
new file mode 100644
index 0000000..61fc455
--- /dev/null
+++ b/module/language/cps/contification.scm
@@ -0,0 +1,210 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+;;; Commentary:
+;;;
+;;; Contification is a pass that turns $fun instances into $cont
+;;; instances if all calls to the $fun return to the same continuation.
+;;; This is a more rigorous variant of our old "fixpoint labels
+;;; allocation" optimization.
+;;;
+;;; See Kennedy's "Compiling with Continuations, Continued", and Fluet
+;;; and Weeks's "Contification using Dominators".
+;;;
+;;; Code:
+
+(define-module (language cps contification)
+ #:use-module (ice-9 match)
+ #:use-module ((srfi srfi-1) #:select (partition))
+ #:use-module (srfi srfi-26)
+ #:use-module (language cps)
+ #:use-module (language cps dfg)
+ #:use-module (language cps primitives)
+ #:use-module (language rtl)
+ #:export (contify))
+
+(define (contify fun)
+ (let* ((dfg (compute-dfg fun))
+ (cont-table (dfg-cont-table dfg))
+ (call-substs '())
+ (cont-substs '()))
+ (define (subst-call! sym arities body-ks)
+ (set! call-substs (acons sym (map cons arities body-ks) call-substs)))
+ (define (subst-return! old-tail new-tail)
+ (set! cont-substs (acons old-tail new-tail cont-substs)))
+ (define (lookup-return-cont k)
+ (or (assq-ref cont-substs k) k))
+
+ (define (contify-call proc args)
+ (and=> (assq-ref call-substs proc)
+ (lambda (entries)
+ (let lp ((entries entries))
+ (match entries
+ (() (error "invalid contification"))
+ (((($ $arity req () #f () #f) . k) . entries)
+ (if (= (length req) (length args))
+ (build-cps-term
+ ($continue k ($values args)))
+ (lp entries)))
+ ((_ . entries) (lp entries)))))))
+
+ ;; If K is a continuation that binds one variable, and it has only
+ ;; one predecessor, return that variable.
+ (define (bound-symbol k)
+ (match (lookup-cont k cont-table)
+ (($ $kargs (_) (sym))
+ (match (lookup-uses k dfg)
+ ((_)
+ ;; K has one predecessor, the one that defined SYM.
+ sym)
+ (_ #f)))
+ (_ #f)))
+
+ (define (contify-fun sym self arities tails bodies)
+ ;; Are the given args compatible with any of the arities?
+ (define (applicable? args)
+ (or-map (match-lambda
+ (($ $arity req () #f () #f)
+ (= (length args) (length req)))
+ (_ #f))
+ arities))
+
+ ;; If the use of PROC in continuation USE is a call to PROC that
+ ;; is compatible with one of the procedure's arities, return the
+ ;; target continuation. Otherwise return #f.
+ (define (call-target use proc)
+ (match (find-call (lookup-cont use cont-table))
+ (($ $continue k ($ $call proc* args))
+ (and (eq? proc proc*) (not (memq proc args)) (applicable? args)
+ k))
+ (_ #f)))
+
+ (and
+ (null? (lookup-uses self dfg))
+ (match (lookup-uses sym dfg)
+ ((use . uses)
+ ;; Is the first use a contifiable call to SYM?
+ (cond
+ ((call-target use sym)
+ => (lambda (k)
+ ;; Are all the other uses contifiable calls to SYM
+ ;; with the same target continuation?
+ (cond
+ ((and-map (lambda (use)
+ (eq? (call-target use sym) k))
+ uses)
+ ;; If so, contify: mark SYM for replacement in
+ ;; calls, and mark the tail continuations for
+ ;; replacement by K.
+ (subst-call! sym arities bodies)
+ (for-each (cut subst-return! <> k) tails)
+ k)
+ (else #f))))
+ (else #f)))
+ (_ #f))))
+
+ ;; This is a first cut at a contification algorithm. It contifies
+ ;; non-recursive functions that only have positional arguments.
+ (define (visit-fun term)
+ (rewrite-cps-call term
+ (($ $fun meta self free entries)
+ ($fun meta self free ,(map visit-cont entries)))))
+ (define (visit-cont cont)
+ (rewrite-cps-cont cont
+ (($ $cont sym src ($ $kargs names syms body))
+ (sym src ($kargs names syms ,(visit-term body))))
+ (($ $cont sym src ($ $kentry arity tail body))
+ (sym src ($kentry ,arity ,tail ,(visit-cont body))))
+ (($ $cont)
+ ,cont)))
+ (define (visit-term term)
+ (match term
+ (($ $letk conts body)
+ ;; Visit the body first, so we visit depth-first.
+ (let ((body (visit-term body)))
+ (build-cps-term
+ ($letk ,(map visit-cont conts) ,body))))
+ (($ $letrec names syms funs body)
+ (let ((nsf (map list names syms funs)))
+ (define recursive?
+ (match-lambda
+ ((n s ($ $fun meta self free (($ $cont entry) ...)))
+ (and-map (lambda (k)
+ (or-map (cut variable-used-in? <> k dfg) syms))
+ entry))))
+ (call-with-values (lambda () (partition recursive? nsf))
+ (lambda (rec nonrec)
+ (let lp ((nonrec nonrec))
+ (match nonrec
+ (()
+ (if (null? rec)
+ (visit-term body)
+ ;; FIXME: Here contify mutually recursive sets
+ ;; of functions.
+ (rewrite-cps-term rec
+ (((name sym fun) ...)
+ ($letrec name sym (map visit-fun fun)
+ ,(visit-term body))))))
+ (((name sym fun) . nonrec)
+ (match fun
+ (($ $fun meta self free
+ (($ $cont _ _ ($ $kentry arity
+ ($ $cont tail-k _ ($ $ktail))
+ (and body ($ $cont body-k))))
+ ...))
+ (if (contify-fun sym self arity tail-k body-k)
+ (visit-term
+ (build-cps-term
+ ($letk ,body
+ ,(lp nonrec))))
+ (let-gensyms (k)
+ (build-cps-term
+ ($letk ((k #f ($kargs (name) (sym)
+ ,(lp nonrec))))
+ ($continue k ,(visit-fun fun)))))))))))))))
+ (($ $continue k exp)
+ (let ((k (lookup-return-cont k)))
+ (define (default)
+ (rewrite-cps-term exp
+ (($ $fun) ($continue k ,(visit-fun exp)))
+ (_ ($continue k ,exp))))
+ (match exp
+ (($ $fun meta self free
+ (($ $cont _ _ ($ $kentry arity
+ ($ $cont tail-k _ ($ $ktail))
+ (and body ($ $cont body-k))))
+ ...))
+ (if (and=> (bound-symbol k)
+ (lambda (sym)
+ (contify-fun sym self arity tail-k body-k)))
+ (visit-term (build-cps-term
+ ($letk ,body
+ ,(match (lookup-cont k cont-table)
+ (($ $kargs (_) (_) body)
+ body)))))
+ (default)))
+ (($ $call proc args)
+ (or (contify-call proc args)
+ (default)))
+ (_ (default)))))))
+
+ (let ((fun (visit-fun fun)))
+ (if (null? call-substs)
+ fun
+ ;; Iterate to fixed point.
+ (contify fun)))))
diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
index 4c15b8e..97c12aa 100644
--- a/module/language/cps/dfg.scm
+++ b/module/language/cps/dfg.scm
@@ -31,9 +31,17 @@
build-local-cont-table
lookup-cont
+ compute-local-dfg
compute-dfg
- dfg-local-cont-table
+ dfg-cont-table
+ lookup-def
+ lookup-uses
+ find-call
+ call-expression
+ find-expression
+ find-defining-expression
find-constant-value
+ variable-used-in?
constant-needs-allocation?
dead-after-def?
dead-after-use?
@@ -66,8 +74,8 @@
(define-record-type $dfg
(make-dfg conts use-maps uplinks)
dfg?
- ;; hash table of sym -> $cont
- (conts dfg-local-cont-table)
+ ;; hash table of sym -> $kargs, $kif, etc
+ (conts dfg-cont-table)
;; hash table of sym -> $use-map
(use-maps dfg-use-maps)
;; hash table of sym -> $parent-link
@@ -86,90 +94,118 @@
(parent uplink-parent)
(level uplink-level))
-(define (compute-dfg self exp)
+(define (visit-entry self entry conts use-maps uplinks global?)
+ (define (add-def! sym def-k)
+ (unless def-k
+ (error "Term outside labelled continuation?"))
+ (hashq-set! use-maps sym (make-use-map sym def-k '())))
+
+ (define (add-use! sym use-k)
+ (match (hashq-ref use-maps sym)
+ (#f (error "Symbol out of scope?" sym))
+ ((and use-map ($ $use-map sym def uses))
+ (set-use-map-uses! use-map (cons use-k uses)))))
+
+ (define (link-parent! k parent)
+ (match (hashq-ref uplinks parent)
+ (($ $uplink _ level)
+ (hashq-set! uplinks k (make-uplink parent (1+ level))))))
+
+ (define (visit exp exp-k)
+ (define (def! sym)
+ (add-def! sym exp-k))
+ (define (use! sym)
+ (add-use! sym exp-k))
+ (define (recur exp)
+ (visit exp exp-k))
+ (match exp
+ (($ $letk conts body)
+ (for-each recur conts)
+ (recur body))
+
+ (($ $cont k src cont)
+ (def! k)
+ (hashq-set! conts k cont)
+ (link-parent! k exp-k)
+ (visit cont k))
+
+ (($ $kargs names syms body)
+ (for-each def! syms)
+ (recur body))
+
+ (($ $kif kt kf)
+ (use! kt)
+ (use! kf))
+
+ (($ $ktrunc arity k)
+ (use! k))
+
+ (($ $ktail)
+ #f)
+
+ (($ $fun meta self free entries)
+ (unless global?
+ (error "pass a $cont when building a local DFG"))
+ (for-each (cut visit-entry self <> conts use-maps uplinks global?)
+ entries))
+
+ (($ $letrec names syms funs body)
+ (unless global?
+ (error "$letrec should not be present when building a local DFG"))
+ (for-each def! syms)
+ (for-each (cut visit <> #f) funs)
+ (visit body exp-k))
+
+ (($ $continue k exp)
+ (use! k)
+ (match exp
+ (($ $var sym)
+ (use! sym))
+
+ (($ $call proc args)
+ (use! proc)
+ (for-each use! args))
+
+ (($ $primcall name args)
+ (for-each use! args))
+
+ (($ $values args)
+ (for-each use! args))
+
+ (($ $prompt escape? tag handler)
+ (use! tag)
+ (use! handler))
+
+ (($ $fun)
+ (when global? (visit exp #f)))
+
+ (_ #f)))))
+
+ (match entry
+ ;; Treat the entry continuation as its own parent.
+ (($ $cont k src ($ $kentry arity tail body))
+ (add-def! k k)
+ ;; FIXME: Define self in one place, not in each entry
+ (add-def! self k)
+ (hashq-set! uplinks k (make-uplink #f 0))
+ (visit tail k)
+ (visit body k))))
+
+(define* (compute-local-dfg self exp)
(let* ((conts (make-hash-table))
(use-maps (make-hash-table))
(uplinks (make-hash-table)))
- (define (add-def! sym def-k)
- (unless def-k
- (error "Term outside labelled continuation?"))
- (hashq-set! use-maps sym (make-use-map sym def-k '())))
-
- (define (add-use! sym use-k)
- (match (hashq-ref use-maps sym)
- (#f (error "Symbol out of scope?" sym))
- ((and use-map ($ $use-map sym def uses))
- (set-use-map-uses! use-map (cons use-k uses)))))
-
- (define (link-parent! k parent)
- (match (hashq-ref uplinks parent)
- (($ $uplink _ level)
- (hashq-set! uplinks k (make-uplink parent (1+ level))))))
-
- (let visit ((exp exp) (exp-k #f))
- (define (def! sym)
- (add-def! sym exp-k))
- (define (use! sym)
- (add-use! sym exp-k))
- (define (recur exp)
- (visit exp exp-k))
- (match exp
- (($ $letk conts body)
- (for-each recur conts)
- (recur body))
-
- ;; Treat the entry continuation as its own parent.
- (($ $cont k src ($ $kentry arity tail body))
- (when exp-k
- (error "$kentry not at top level?"))
- (add-def! k k)
- (add-def! self k)
- (hashq-set! uplinks k (make-uplink #f 0))
- (visit tail k)
- (visit body k))
-
- (($ $cont k src cont)
- (def! k)
- (hashq-set! conts k cont)
- (link-parent! k exp-k)
- (visit cont k))
-
- (($ $kargs names syms body)
- (for-each def! syms)
- (recur body))
-
- (($ $kif kt kf)
- (use! kt)
- (use! kf))
-
- (($ $ktrunc arity k)
- (use! k))
-
- (($ $ktail)
- #f)
-
- (($ $continue k exp)
- (use! k)
- (match exp
- (($ $var sym)
- (use! sym))
-
- (($ $call proc args)
- (use! proc)
- (for-each use! args))
-
- (($ $primcall name args)
- (for-each use! args))
-
- (($ $values args)
- (for-each use! args))
-
- (($ $prompt escape? tag handler)
- (use! tag)
- (use! handler))
-
- (_ #f)))))
+ (visit-entry self exp conts use-maps uplinks #f)
+ (make-dfg conts use-maps uplinks)))
+(define* (compute-dfg fun)
+ (let* ((conts (make-hash-table))
+ (use-maps (make-hash-table))
+ (uplinks (make-hash-table)))
+ (match fun
+ (($ $fun meta self free entries)
+ (for-each (cut visit-entry self <> conts use-maps uplinks #t)
+ entries)))
(make-dfg conts use-maps uplinks)))
(define (lookup-uplink k uplinks)
@@ -184,24 +220,47 @@
(error "Unknown lexical!" sym (hash-fold acons '() use-maps)))
res))
-(define (find-defining-term sym dfg)
+(define (lookup-def sym dfg)
+ (match dfg
+ (($ $dfg conts use-maps uplinks)
+ (match (lookup-use-map sym use-maps)
+ (($ $use-map sym def uses)
+ def)))))
+
+(define (lookup-uses sym dfg)
(match dfg
(($ $dfg conts use-maps uplinks)
(match (lookup-use-map sym use-maps)
(($ $use-map sym def uses)
- (match (lookup-use-map def use-maps)
- (($ $use-map _ _ (def-exp-k))
- (lookup-cont def-exp-k conts))
- (else #f)))))))
+ uses)))))
+
+(define (find-defining-term sym dfg)
+ (match (lookup-uses (lookup-def sym dfg) dfg)
+ ((def-exp-k)
+ (lookup-cont def-exp-k (dfg-cont-table dfg)))
+ (else #f)))
+
+(define (find-call term)
+ (match term
+ (($ $kargs names syms body) (find-call body))
+ (($ $letk conts body) (find-call body))
+ (($ $letrec names syms funs body) (find-call body))
+ (($ $continue) term)))
+
+(define (call-expression call)
+ (match call
+ (($ $continue k exp) exp)))
+
+(define (find-expression term)
+ (call-expression (find-call term)))
+
+(define (find-defining-expression sym dfg)
+ (and=> (find-defining-term sym dfg)
+ find-expression))
(define (find-constant-value sym dfg)
- (define (find-exp term)
- (match term
- (($ $kargs names syms body) (find-exp body))
- (($ $letk conts body) (find-exp body))
- (else term)))
- (match (find-exp (find-defining-term sym dfg))
- (($ $continue k ($ $const val))
+ (match (find-defining-expression sym dfg)
+ (($ $const val)
(values #t val))
(($ $continue k ($ $void))
(values #t *unspecified*))
@@ -220,24 +279,43 @@
(($ $use-map _ def uses)
(or-map
(lambda (use)
- (match (find-exp (lookup-cont use conts))
- (($ $continue _ ($ $call)) #f)
- (($ $continue _ ($ $values)) #f)
- (($ $continue _ ($ $primcall 'free-ref (closure slot)))
+ (match (find-expression (lookup-cont use conts))
+ (($ $call) #f)
+ (($ $values) #f)
+ (($ $primcall 'free-ref (closure slot))
(not (eq? sym slot)))
- (($ $continue _ ($ $primcall 'free-set! (closure slot value)))
+ (($ $primcall 'free-set! (closure slot value))
(not (eq? sym slot)))
- (($ $continue _ ($ $primcall 'cache-current-module! (mod . _)))
+ (($ $primcall 'cache-current-module! (mod . _))
(eq? sym mod))
- (($ $continue _ ($ $primcall 'cached-toplevel-box _))
+ (($ $primcall 'cached-toplevel-box _)
#f)
- (($ $continue _ ($ $primcall 'cached-module-box _))
+ (($ $primcall 'cached-module-box _)
#f)
- (($ $continue _ ($ $primcall 'resolve (name bound?)))
+ (($ $primcall 'resolve (name bound?))
(eq? sym name))
- (else #t)))
+ (_ #t)))
uses))))))
+(define (continuation-scope-contains? parent-k k uplinks)
+ (match (lookup-uplink parent-k uplinks)
+ (($ $uplink _ parent-level)
+ (let lp ((k k))
+ (or (eq? parent-k k)
+ (match (lookup-uplink k uplinks)
+ (($ $uplink parent level)
+ (and (< parent-level level)
+ (lp parent)))))))))
+
+(define (variable-used-in? var parent-k dfg)
+ (match dfg
+ (($ $dfg conts use-maps uplinks)
+ (or-map (lambda (use)
+ (continuation-scope-contains? parent-k use uplinks))
+ (match (lookup-use-map var use-maps)
+ (($ $use-map sym def uses)
+ uses))))))
+
;; Does k1 dominate k2?
;;
;; Note that this is a conservative predicate: a false return value does
@@ -247,14 +325,7 @@
;; http://mlton.org/pipermail/mlton/2003-January/023054.html for a
;; deeper discussion.
(define (conservatively-dominates? k1 k2 uplinks)
- (match (lookup-uplink k1 uplinks)
- (($ $uplink _ k1-level)
- (let lp ((k2 k2))
- (or (eq? k1 k2)
- (match (lookup-uplink k2 uplinks)
- (($ $uplink k2-parent k2-level)
- (and (< k1-level k2-level)
- (lp k2-parent)))))))))
+ (continuation-scope-contains? k1 k2 uplinks))
(define (dead-after-def? sym dfg)
(match dfg
diff --git a/module/language/cps/reify-primitives.scm
b/module/language/cps/reify-primitives.scm
index 0327020..bf5b5ec 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -26,8 +26,6 @@
(define-module (language cps reify-primitives)
#:use-module (ice-9 match)
- #:use-module (ice-9 vlist)
- #:use-module ((srfi srfi-1) #:select (fold))
#:use-module (language cps)
#:use-module (language cps dfg)
#:use-module (language cps primitives)
diff --git a/module/language/cps/slot-allocation.scm
b/module/language/cps/slot-allocation.scm
index d071bd2..535fef8 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -208,7 +208,7 @@ are comparable with eqv?. A tmp slot may be used."
(define (compute-call-proc-slot live-set nlocals)
(+ 3 (find-first-trailing-zero (car live-set) nlocals)))
- (let ((dfg (compute-dfg self exp))
+ (let ((dfg (compute-local-dfg self exp))
(nlocals 0)
(nargs (match exp
(($ $cont _ _
@@ -312,7 +312,7 @@ are comparable with eqv?. A tmp slot may be used."
(use sym live-set))
(($ $continue k ($ $call proc args))
- (match (lookup-cont k (dfg-local-cont-table dfg))
+ (match (lookup-cont k (dfg-cont-table dfg))
(($ $ktail)
(let ((tail-nlocals (1+ (length args))))
(set! nlocals (max nlocals tail-nlocals))
@@ -347,7 +347,7 @@ are comparable with eqv?. A tmp slot may be used."
(($ $continue k ($ $values args))
(let ((live-set* (fold use live-set args)))
(define (compute-dst-slots)
- (match (lookup-cont k (dfg-local-cont-table dfg))
+ (match (lookup-cont k (dfg-cont-table dfg))
(($ $ktail)
(let ((tail-nlocals (1+ (length args))))
(set! nlocals (max nlocals tail-nlocals))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, wip-cps-bis, updated. v2.1.0-208-g3f72a53,
Andy Wingo <=