mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-18 09:40:25 +02:00
lookup-cont takes a DFG as its argument
* module/language/cps/dfg.scm (lookup-cont): Change to take a DFG instead of a cont table. (build-cont-table): Change to return a vector. * module/language/cps/arities.scm: * module/language/cps/contification.scm: * module/language/cps/dce.scm: * module/language/cps/effects-analysis.scm: * module/language/cps/elide-values.scm: * module/language/cps/reify-primitives.scm: * module/language/cps/simplify.scm: * module/language/cps/slot-allocation.scm: Adapt to lookup-cont and build-cont-table changes.
This commit is contained in:
Andy Wingo
parent
a6f823bd02
commit
fbdb69b21c
9 changed files with 113 additions and 121 deletions
|
|
@ -32,7 +32,7 @@
|
|||
#:use-module (language cps primitives)
|
||||
#:export (fix-arities))
|
||||
|
||||
(define (fix-clause-arities clause conts)
|
||||
(define (fix-clause-arities clause dfg)
|
||||
(let ((ktail (match clause
|
||||
(($ $cont _ ($ $kentry _ ($ $cont ktail) _)) ktail))))
|
||||
(define (visit-term term)
|
||||
|
|
@ -40,14 +40,15 @@
|
|||
(($ $letk conts body)
|
||||
($letk ,(map visit-cont conts) ,(visit-term body)))
|
||||
(($ $letrec names syms funs body)
|
||||
($letrec names syms (map fix-arities* funs) ,(visit-term body)))
|
||||
($letrec names syms (map (cut fix-arities* <> dfg) funs)
|
||||
,(visit-term body)))
|
||||
(($ $continue k src exp)
|
||||
,(visit-exp k src exp))))
|
||||
|
||||
(define (adapt-exp nvals k src exp)
|
||||
(match nvals
|
||||
(0
|
||||
(rewrite-cps-term (lookup-cont k conts)
|
||||
(rewrite-cps-term (lookup-cont k dfg)
|
||||
(($ $ktail)
|
||||
,(let-fresh (kvoid kunspec) (unspec)
|
||||
(build-cps-term
|
||||
|
|
@ -86,7 +87,7 @@
|
|||
($letk ((k* ($kargs () () ($continue k src ($void)))))
|
||||
($continue k* src ,exp)))))))
|
||||
(1
|
||||
(rewrite-cps-term (lookup-cont k conts)
|
||||
(rewrite-cps-term (lookup-cont k dfg)
|
||||
(($ $ktail)
|
||||
,(rewrite-cps-term exp
|
||||
(($values (sym))
|
||||
|
|
@ -134,7 +135,7 @@
|
|||
($ $values (_)))
|
||||
,(adapt-exp 1 k src exp))
|
||||
(($ $fun)
|
||||
,(adapt-exp 1 k src (fix-arities* exp)))
|
||||
,(adapt-exp 1 k src (fix-arities* exp dfg)))
|
||||
((or ($ $call) ($ $callk))
|
||||
;; In general, calls have unknown return arity. For that
|
||||
;; reason every non-tail call has a $kreceive continuation to
|
||||
|
|
@ -182,12 +183,11 @@
|
|||
(($ $cont sym ($ $kentry self tail clauses))
|
||||
(sym ($kentry self ,tail ,(map visit-cont clauses)))))))
|
||||
|
||||
(define (fix-arities* fun)
|
||||
(let ((conts (build-local-cont-table fun)))
|
||||
(define (fix-arities* fun dfg)
|
||||
(rewrite-cps-exp fun
|
||||
(($ $fun src meta free body)
|
||||
($fun src meta free ,(fix-clause-arities body conts))))))
|
||||
($fun src meta free ,(fix-clause-arities body dfg)))))
|
||||
|
||||
(define (fix-arities fun)
|
||||
(with-fresh-name-state fun
|
||||
(fix-arities* fun)))
|
||||
(fix-arities* fun (compute-dfg fun))))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; Continuation-passing style (CPS) intermediate language (IL)
|
||||
|
||||
;; Copyright (C) 2013 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2013, 2014 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
|
||||
|
|
@ -40,7 +40,6 @@
|
|||
|
||||
(define (compute-contification fun)
|
||||
(let* ((dfg (compute-dfg fun))
|
||||
(cont-table (dfg-cont-table dfg))
|
||||
(scope-table (make-hash-table))
|
||||
(call-substs '())
|
||||
(cont-substs '())
|
||||
|
|
@ -67,7 +66,7 @@
|
|||
;; 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)
|
||||
(match (lookup-cont k dfg)
|
||||
(($ $kargs (_) (sym))
|
||||
(match (lookup-predecessors k dfg)
|
||||
((_)
|
||||
|
|
@ -107,7 +106,7 @@
|
|||
;; 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))
|
||||
(match (find-call (lookup-cont use dfg))
|
||||
(($ $continue k src ($ $call proc* args))
|
||||
(and (eq? proc proc*) (not (memq proc args)) (applicable? proc args)
|
||||
;; Converge more quickly by resolving already-contified
|
||||
|
|
@ -176,7 +175,7 @@
|
|||
(let ((k-scope (continuation-scope k)))
|
||||
(if (scope-contains? k-scope term-k)
|
||||
term-k
|
||||
(match (lookup-cont k-scope cont-table)
|
||||
(match (lookup-cont k-scope dfg)
|
||||
(($ $kentry self tail clauses)
|
||||
;; K is the tail of some function. If that function
|
||||
;; has just one clause, return that clause. Otherwise
|
||||
|
|
@ -273,7 +272,7 @@
|
|||
(lambda (sym)
|
||||
(contify-fun term-k sym self tail-k arity body)))
|
||||
(begin
|
||||
(elide-function! k (lookup-cont k cont-table))
|
||||
(elide-function! k (lookup-cont k dfg))
|
||||
(for-each visit-cont body))
|
||||
(visit-fun exp)))
|
||||
(_ #t)))))
|
||||
|
|
|
|||
|
|
@ -50,11 +50,11 @@
|
|||
(live-conts fun-data-live-conts)
|
||||
(defs fun-data-defs))
|
||||
|
||||
(define (compute-cont-vector cfa cont-table)
|
||||
(define (compute-cont-vector cfa dfg)
|
||||
(let ((v (make-vector (cfa-k-count cfa) #f)))
|
||||
(let lp ((n 0))
|
||||
(when (< n (vector-length v))
|
||||
(vector-set! v n (lookup-cont (cfa-k-sym cfa n) cont-table))
|
||||
(vector-set! v n (lookup-cont (cfa-k-sym cfa n) dfg))
|
||||
(lp (1+ n))))
|
||||
v))
|
||||
|
||||
|
|
@ -98,7 +98,7 @@
|
|||
(or (hashq-ref fun-data-table fun)
|
||||
(let* ((cfa (analyze-control-flow fun dfg))
|
||||
(effects (compute-effects cfa dfg))
|
||||
(contv (compute-cont-vector cfa (dfg-cont-table dfg)))
|
||||
(contv (compute-cont-vector cfa dfg))
|
||||
(live-conts (make-bitvector (cfa-k-count cfa) #f))
|
||||
(defs (compute-defs cfa contv))
|
||||
(fun-data (make-fun-data cfa effects contv live-conts defs)))
|
||||
|
|
|
|||
|
|
@ -41,7 +41,6 @@
|
|||
#:use-module (srfi srfi-26)
|
||||
#:use-module (language cps)
|
||||
#:export (build-cont-table
|
||||
build-local-cont-table
|
||||
lookup-cont
|
||||
|
||||
compute-dfg
|
||||
|
|
@ -92,24 +91,21 @@
|
|||
(for-each2 (cdr l1) (cdr l2)))))
|
||||
|
||||
(define (build-cont-table fun)
|
||||
(let ((max-k (fold-conts (lambda (k cont max-k) (max k max-k))
|
||||
-1 fun)))
|
||||
(fold-conts (lambda (k cont table)
|
||||
(hashq-set! table k cont)
|
||||
(vector-set! table k cont)
|
||||
table)
|
||||
(make-hash-table)
|
||||
fun))
|
||||
(make-vector (1+ max-k) #f)
|
||||
fun)))
|
||||
|
||||
(define (build-local-cont-table cont)
|
||||
(fold-local-conts (lambda (k cont table)
|
||||
(hashq-set! table k cont)
|
||||
table)
|
||||
(make-hash-table)
|
||||
cont))
|
||||
|
||||
(define (lookup-cont sym conts)
|
||||
(let ((res (hashq-ref conts sym)))
|
||||
(define (lookup-cont label dfg)
|
||||
(match dfg
|
||||
(($ $dfg conts blocks use-maps)
|
||||
(let ((res (hashq-ref conts label)))
|
||||
(unless res
|
||||
(error "Unknown continuation!" sym (hash-fold acons '() conts)))
|
||||
res))
|
||||
(error "Unknown continuation!" label conts))
|
||||
res))))
|
||||
|
||||
;; Data-flow graph for CPS: both for values and continuations.
|
||||
(define-record-type $dfg
|
||||
|
|
@ -272,7 +268,7 @@ HANDLER-INDEX pairs."
|
|||
((= n (cfa-k-count cfa))
|
||||
(reverse prompts))
|
||||
(else
|
||||
(match (lookup-cont (cfa-k-sym cfa n) (dfg-cont-table dfg))
|
||||
(match (lookup-cont (cfa-k-sym cfa n) dfg)
|
||||
(($ $kargs names syms body)
|
||||
(match (find-expression body)
|
||||
(($ $prompt escape? tag handler)
|
||||
|
|
@ -952,7 +948,7 @@ BODY for each body continuation in the prompt."
|
|||
(define (find-defining-term sym dfg)
|
||||
(match (lookup-predecessors (lookup-def sym dfg) dfg)
|
||||
((def-exp-k)
|
||||
(lookup-cont def-exp-k (dfg-cont-table dfg)))
|
||||
(lookup-cont def-exp-k dfg))
|
||||
(else #f)))
|
||||
|
||||
(define (find-call term)
|
||||
|
|
@ -1000,7 +996,7 @@ BODY for each body continuation in the prompt."
|
|||
(($ $use-map _ _ def uses)
|
||||
(or-map
|
||||
(lambda (use)
|
||||
(match (find-expression (lookup-cont use conts))
|
||||
(match (find-expression (lookup-cont use dfg))
|
||||
(($ $call) #f)
|
||||
(($ $callk) #f)
|
||||
(($ $values) #f)
|
||||
|
|
@ -1069,8 +1065,6 @@ BODY for each body continuation in the prompt."
|
|||
(_ #t)))
|
||||
|
||||
(define (lookup-bound-syms k dfg)
|
||||
(match dfg
|
||||
(($ $dfg conts blocks use-maps)
|
||||
(match (lookup-cont k conts)
|
||||
(match (lookup-cont k dfg)
|
||||
(($ $kargs names syms body)
|
||||
syms)))))
|
||||
syms)))
|
||||
|
|
|
|||
|
|
@ -467,7 +467,7 @@
|
|||
(vector-set!
|
||||
effects
|
||||
n
|
||||
(match (lookup-cont (cfa-k-sym cfa n) (dfg-cont-table dfg))
|
||||
(match (lookup-cont (cfa-k-sym cfa n) dfg)
|
||||
(($ $kargs names syms body)
|
||||
(expression-effects (find-expression body) dfg))
|
||||
(($ $kreceive arity kargs)
|
||||
|
|
|
|||
|
|
@ -35,8 +35,7 @@
|
|||
#:use-module (language cps dfg)
|
||||
#:export (elide-values))
|
||||
|
||||
(define (elide-values* fun)
|
||||
(let ((conts (build-local-cont-table fun)))
|
||||
(define (elide-values* fun conts)
|
||||
(define (visit-cont cont)
|
||||
(rewrite-cps-cont cont
|
||||
(($ $cont sym ($ $kargs names syms body))
|
||||
|
|
@ -53,10 +52,10 @@
|
|||
($letk ,(map visit-cont conts)
|
||||
,(visit-term body)))
|
||||
(($ $letrec names syms funs body)
|
||||
($letrec names syms (map elide-values* funs)
|
||||
($letrec names syms (map (cut elide-values* <> conts) funs)
|
||||
,(visit-term body)))
|
||||
(($ $continue k src ($ $primcall 'values vals))
|
||||
,(rewrite-cps-term (lookup-cont k conts)
|
||||
,(rewrite-cps-term (vector-ref conts k)
|
||||
(($ $ktail)
|
||||
($continue k src ($values vals)))
|
||||
(($ $kreceive ($ $arity req () rest () #f) kargs)
|
||||
|
|
@ -94,14 +93,15 @@
|
|||
(build-cps-term
|
||||
($continue k src ($values vals))))))))
|
||||
(($ $continue k src (and fun ($ $fun)))
|
||||
($continue k src ,(elide-values* fun)))
|
||||
($continue k src ,(elide-values* fun conts)))
|
||||
(($ $continue)
|
||||
,term)))
|
||||
|
||||
(rewrite-cps-exp fun
|
||||
(($ $fun src meta free body)
|
||||
($fun src meta free ,(visit-cont body))))))
|
||||
($fun src meta free ,(visit-cont body)))))
|
||||
|
||||
(define (elide-values fun)
|
||||
(with-fresh-name-state fun
|
||||
(elide-values* fun)))
|
||||
(let ((conts (build-cont-table fun)))
|
||||
(elide-values* fun conts))))
|
||||
|
|
|
|||
|
|
@ -132,7 +132,7 @@
|
|||
(($ $continue k src exp)
|
||||
,(match exp
|
||||
(($ $prim name)
|
||||
(match (lookup-cont k conts)
|
||||
(match (vector-ref conts k)
|
||||
(($ $kargs (_))
|
||||
(cond
|
||||
((builtin-name->index name)
|
||||
|
|
|
|||
|
|
@ -123,7 +123,7 @@
|
|||
(k*
|
||||
(if (and (continuation-bound-in? k* scope dfg)
|
||||
(or values?
|
||||
(match (lookup-cont k* (dfg-cont-table dfg))
|
||||
(match (lookup-cont k* dfg)
|
||||
(($ $kargs) #t)
|
||||
(_ #f))))
|
||||
(reduce* k* scope values?)
|
||||
|
|
@ -190,7 +190,7 @@
|
|||
(for-each visit-fun funs)
|
||||
(visit-term body))
|
||||
(($ $continue k src ($ $values args))
|
||||
(match (lookup-cont k (dfg-cont-table dfg))
|
||||
(match (lookup-cont k dfg)
|
||||
(($ $kargs names syms body)
|
||||
(match (lookup-predecessors k dfg)
|
||||
((_)
|
||||
|
|
|
|||
|
|
@ -331,11 +331,10 @@ are comparable with eqv?. A tmp slot may be used."
|
|||
;; Transform the DFG's continuation table to a vector, for easy
|
||||
;; access.
|
||||
(define (compute-conts!)
|
||||
(let ((cont-table (dfg-cont-table dfg)))
|
||||
(let lp ((n 0))
|
||||
(when (< n (vector-length contv))
|
||||
(vector-set! contv n (lookup-cont (cfa-k-sym cfa n) cont-table))
|
||||
(lp (1+ n))))))
|
||||
(vector-set! contv n (lookup-cont (cfa-k-sym cfa n) dfg))
|
||||
(lp (1+ n)))))
|
||||
|
||||
;; Record uses and defs, as lists of variable indexes, indexed by
|
||||
;; CFA continuation index.
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue