mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-18 09:40:25 +02:00
Code Activity

lookup-cont takes a DFG as its argument

Browse source 
* 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 2014-03-30 10:41:31 +02:00
parent a6f823bd02
commit fbdb69b21c
9 changed files with 113 additions and 121 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -32,7 +32,7 @@
#:use-module (language cps primitives) #:use-module (language cps primitives)
#:export (fix-arities)) #:export (fix-arities))
(define (fix-clause-arities clause conts) (define (fix-clause-arities clause dfg)
(let ((ktail (match clause (let ((ktail (match clause
(($ $cont _ ($ $kentry _ ($ $cont ktail) _)) ktail)))) (($ $cont _ ($ $kentry _ ($ $cont ktail) _)) ktail))))
(define (visit-term term) (define (visit-term term)
@ -40,14 +40,15 @@
(($ $letk conts body) (($ $letk conts body)
($letk ,(map visit-cont conts) ,(visit-term body))) ($letk ,(map visit-cont conts) ,(visit-term body)))
(($ $letrec names syms funs 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) (($ $continue k src exp)
,(visit-exp k src exp)))) ,(visit-exp k src exp))))
(define (adapt-exp nvals k src exp) (define (adapt-exp nvals k src exp)
(match nvals (match nvals
(0 (0
(rewrite-cps-term (lookup-cont k conts) (rewrite-cps-term (lookup-cont k dfg)
(($ $ktail) (($ $ktail)
,(let-fresh (kvoid kunspec) (unspec) ,(let-fresh (kvoid kunspec) (unspec)
(build-cps-term (build-cps-term
@ -86,7 +87,7 @@
($letk ((k* ($kargs () () ($continue k src ($void))))) ($letk ((k* ($kargs () () ($continue k src ($void)))))
($continue k* src ,exp))))))) ($continue k* src ,exp)))))))
(1 (1
(rewrite-cps-term (lookup-cont k conts) (rewrite-cps-term (lookup-cont k dfg)
(($ $ktail) (($ $ktail)
,(rewrite-cps-term exp ,(rewrite-cps-term exp
(($values (sym)) (($values (sym))
@ -134,7 +135,7 @@
($ $values (_))) ($ $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 dfg)))
((or ($ $call) ($ $callk)) ((or ($ $call) ($ $callk))
;; In general, calls have unknown return arity. For that ;; In general, calls have unknown return arity. For that
;; reason every non-tail call has a $kreceive continuation to ;; reason every non-tail call has a $kreceive continuation to
@ -182,12 +183,11 @@
(($ $cont sym ($ $kentry self tail clauses)) (($ $cont sym ($ $kentry self tail clauses))
(sym ($kentry self ,tail ,(map visit-cont clauses))))))) (sym ($kentry self ,tail ,(map visit-cont clauses)))))))
(define (fix-arities* fun) (define (fix-arities* fun dfg)
(let ((conts (build-local-cont-table fun))) (rewrite-cps-exp fun
(rewrite-cps-exp fun (($ $fun src meta free body)
(($ $fun src meta free body) ($fun src meta free ,(fix-clause-arities body dfg)))))
($fun src meta free ,(fix-clause-arities body conts))))))
(define (fix-arities fun) (define (fix-arities fun)
(with-fresh-name-state fun (with-fresh-name-state fun
(fix-arities* fun))) (fix-arities* fun (compute-dfg fun))))

11
module/language/cps/contification.scm
View file

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -40,7 +40,6 @@
(define (compute-contification fun) (define (compute-contification fun)
(let* ((dfg (compute-dfg fun)) (let* ((dfg (compute-dfg fun))
(cont-table (dfg-cont-table dfg))
(scope-table (make-hash-table)) (scope-table (make-hash-table))
(call-substs '()) (call-substs '())
(cont-substs '()) (cont-substs '())
@ -67,7 +66,7 @@
;; If K is a continuation that binds one variable, and it has only ;; If K is a continuation that binds one variable, and it has only
;; one predecessor, return that variable. ;; one predecessor, return that variable.
(define (bound-symbol k) (define (bound-symbol k)
(match (lookup-cont k cont-table) (match (lookup-cont k dfg)
(($ $kargs (_) (sym)) (($ $kargs (_) (sym))
(match (lookup-predecessors k dfg) (match (lookup-predecessors k dfg)
((_) ((_)
@ -107,7 +106,7 @@
;; is compatible with one of the procedure's arities, return the ;; is compatible with one of the procedure's arities, return the
;; target continuation. Otherwise return #f. ;; target continuation. Otherwise return #f.
(define (call-target use proc) (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)) (($ $continue k src ($ $call proc* args))
(and (eq? proc proc*) (not (memq proc args)) (applicable? proc args) (and (eq? proc proc*) (not (memq proc args)) (applicable? proc args)
;; Converge more quickly by resolving already-contified ;; Converge more quickly by resolving already-contified
@ -176,7 +175,7 @@
(let ((k-scope (continuation-scope k))) (let ((k-scope (continuation-scope k)))
(if (scope-contains? k-scope term-k) (if (scope-contains? k-scope term-k)
term-k term-k
(match (lookup-cont k-scope cont-table) (match (lookup-cont k-scope dfg)
(($ $kentry self tail clauses) (($ $kentry self tail clauses)
;; K is the tail of some function. If that function ;; K is the tail of some function. If that function
;; has just one clause, return that clause. Otherwise ;; has just one clause, return that clause. Otherwise
@ -273,7 +272,7 @@
(lambda (sym) (lambda (sym)
(contify-fun term-k sym self tail-k arity body))) (contify-fun term-k sym self tail-k arity body)))
(begin (begin
(elide-function! k (lookup-cont k cont-table)) (elide-function! k (lookup-cont k dfg))
(for-each visit-cont body)) (for-each visit-cont body))
(visit-fun exp))) (visit-fun exp)))
(_ #t))))) (_ #t)))))

6
module/language/cps/dce.scm
View file

@ -50,11 +50,11 @@
(live-conts fun-data-live-conts) (live-conts fun-data-live-conts)
(defs fun-data-defs)) (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 ((v (make-vector (cfa-k-count cfa) #f)))
(let lp ((n 0)) (let lp ((n 0))
(when (< n (vector-length v)) (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)))) (lp (1+ n))))
v)) v))
@ -98,7 +98,7 @@
(or (hashq-ref fun-data-table fun) (or (hashq-ref fun-data-table fun)
(let* ((cfa (analyze-control-flow fun dfg)) (let* ((cfa (analyze-control-flow fun dfg))
(effects (compute-effects cfa 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)) (live-conts (make-bitvector (cfa-k-count cfa) #f))
(defs (compute-defs cfa contv)) (defs (compute-defs cfa contv))
(fun-data (make-fun-data cfa effects contv live-conts defs))) (fun-data (make-fun-data cfa effects contv live-conts defs)))

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

@ -41,7 +41,6 @@
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (language cps) #:use-module (language cps)
#:export (build-cont-table #:export (build-cont-table
build-local-cont-table
lookup-cont lookup-cont
compute-dfg compute-dfg
@ -92,24 +91,21 @@
(for-each2 (cdr l1) (cdr l2))))) (for-each2 (cdr l1) (cdr l2)))))
(define (build-cont-table fun) (define (build-cont-table fun)
(fold-conts (lambda (k cont table) (let ((max-k (fold-conts (lambda (k cont max-k) (max k max-k))
(hashq-set! table k cont) -1 fun)))
table) (fold-conts (lambda (k cont table)
(make-hash-table) (vector-set! table k cont)
fun)) table)
(make-vector (1+ max-k) #f)
fun)))
(define (build-local-cont-table cont) (define (lookup-cont label dfg)
(fold-local-conts (lambda (k cont table) (match dfg
(hashq-set! table k cont) (($ $dfg conts blocks use-maps)
table) (let ((res (hashq-ref conts label)))
(make-hash-table) (unless res
cont)) (error "Unknown continuation!" label conts))
res))))
(define (lookup-cont sym conts)
(let ((res (hashq-ref conts sym)))
(unless res
(error "Unknown continuation!" sym (hash-fold acons '() conts)))
res))
;; Data-flow graph for CPS: both for values and continuations. ;; Data-flow graph for CPS: both for values and continuations.
(define-record-type $dfg (define-record-type $dfg
@ -272,7 +268,7 @@ HANDLER-INDEX pairs."
((= n (cfa-k-count cfa)) ((= n (cfa-k-count cfa))
(reverse prompts)) (reverse prompts))
(else (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) (($ $kargs names syms body)
(match (find-expression body) (match (find-expression body)
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
@ -952,7 +948,7 @@ BODY for each body continuation in the prompt."
(define (find-defining-term sym dfg) (define (find-defining-term sym dfg)
(match (lookup-predecessors (lookup-def sym dfg) dfg) (match (lookup-predecessors (lookup-def sym dfg) dfg)
((def-exp-k) ((def-exp-k)
(lookup-cont def-exp-k (dfg-cont-table dfg))) (lookup-cont def-exp-k dfg))
(else #f))) (else #f)))
(define (find-call term) (define (find-call term)
@ -1000,7 +996,7 @@ BODY for each body continuation in the prompt."
(($ $use-map _ _ def uses) (($ $use-map _ _ def uses)
(or-map (or-map
(lambda (use) (lambda (use)
(match (find-expression (lookup-cont use conts)) (match (find-expression (lookup-cont use dfg))
(($ $call) #f) (($ $call) #f)
(($ $callk) #f) (($ $callk) #f)
(($ $values) #f) (($ $values) #f)
@ -1069,8 +1065,6 @@ BODY for each body continuation in the prompt."
(_ #t))) (_ #t)))
(define (lookup-bound-syms k dfg) (define (lookup-bound-syms k dfg)
(match dfg (match (lookup-cont k dfg)
(($ $dfg conts blocks use-maps) (($ $kargs names syms body)
(match (lookup-cont k conts) syms)))
(($ $kargs names syms body)
syms)))))

2
module/language/cps/effects-analysis.scm
View file

@ -467,7 +467,7 @@
(vector-set! (vector-set!
effects effects
n 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) (($ $kargs names syms body)
(expression-effects (find-expression body) dfg)) (expression-effects (find-expression body) dfg))
(($ $kreceive arity kargs) (($ $kreceive arity kargs)

132
module/language/cps/elide-values.scm
View file

@ -35,73 +35,73 @@
#:use-module (language cps dfg) #:use-module (language cps dfg)
#:export (elide-values)) #:export (elide-values))
(define (elide-values* fun) (define (elide-values* fun conts)
(let ((conts (build-local-cont-table fun))) (define (visit-cont cont)
(define (visit-cont cont) (rewrite-cps-cont cont
(rewrite-cps-cont cont (($ $cont sym ($ $kargs names syms body))
(($ $cont sym ($ $kargs names syms body)) (sym ($kargs names syms ,(visit-term body))))
(sym ($kargs names syms ,(visit-term body)))) (($ $cont sym ($ $kentry self tail clauses))
(($ $cont sym ($ $kentry self tail clauses)) (sym ($kentry self ,tail ,(map visit-cont clauses))))
(sym ($kentry self ,tail ,(map visit-cont clauses)))) (($ $cont sym ($ $kclause arity body))
(($ $cont sym ($ $kclause arity body)) (sym ($kclause ,arity ,(visit-cont body))))
(sym ($kclause ,arity ,(visit-cont body)))) (($ $cont)
(($ $cont) ,cont)))
,cont))) (define (visit-term term)
(define (visit-term term) (rewrite-cps-term term
(rewrite-cps-term term (($ $letk conts body)
(($ $letk conts body) ($letk ,(map visit-cont conts)
($letk ,(map visit-cont conts) ,(visit-term body)))
,(visit-term body))) (($ $letrec names syms funs body)
(($ $letrec names syms funs body) ($letrec names syms (map (cut elide-values* <> conts) funs)
($letrec names syms (map elide-values* funs) ,(visit-term body)))
,(visit-term body))) (($ $continue k src ($ $primcall 'values vals))
(($ $continue k src ($ $primcall 'values vals)) ,(rewrite-cps-term (vector-ref conts k)
,(rewrite-cps-term (lookup-cont k conts) (($ $ktail)
(($ $ktail) ($continue k src ($values vals)))
($continue k src ($values vals))) (($ $kreceive ($ $arity req () rest () #f) kargs)
(($ $kreceive ($ $arity req () rest () #f) kargs) ,(cond
,(cond ((and (not rest) (= (length vals) (length req)))
((and (not rest) (= (length vals) (length req))) (build-cps-term
(build-cps-term ($continue kargs src ($values vals))))
($continue kargs src ($values vals)))) ((and rest (>= (length vals) (length req)))
((and rest (>= (length vals) (length req))) (let-fresh (krest) (rest)
(let-fresh (krest) (rest) (let ((vals* (append (list-head vals (length req))
(let ((vals* (append (list-head vals (length req)) (list rest))))
(list rest)))) (build-cps-term
(build-cps-term ($letk ((krest ($kargs ('rest) (rest)
($letk ((krest ($kargs ('rest) (rest) ($continue kargs src
($continue kargs src ($values vals*)))))
($values vals*))))) ,(let lp ((tail (list-tail vals (length req)))
,(let lp ((tail (list-tail vals (length req))) (k krest))
(k krest)) (match tail
(match tail (()
(() (build-cps-term ($continue k src
(build-cps-term ($continue k src ($const '()))))
($const '())))) ((v . tail)
((v . tail) (let-fresh (krest) (rest)
(let-fresh (krest) (rest) (build-cps-term
(build-cps-term ($letk ((krest ($kargs ('rest) (rest)
($letk ((krest ($kargs ('rest) (rest) ($continue k src
($continue k src ($primcall 'cons
($primcall 'cons (v rest))))))
(v rest)))))) ,(lp tail krest))))))))))))
,(lp tail krest)))))))))))) (else term)))
(else term))) (($ $kargs args)
(($ $kargs args) ,(if (< (length vals) (length args))
,(if (< (length vals) (length args)) term
term (let ((vals (list-head vals (length args))))
(let ((vals (list-head vals (length args)))) (build-cps-term
(build-cps-term ($continue k src ($values vals))))))))
($continue k src ($values vals)))))))) (($ $continue k src (and fun ($ $fun)))
(($ $continue k src (and fun ($ $fun))) ($continue k src ,(elide-values* fun conts)))
($continue k src ,(elide-values* fun))) (($ $continue)
(($ $continue) ,term)))
,term)))
(rewrite-cps-exp fun (rewrite-cps-exp fun
(($ $fun src meta free body) (($ $fun src meta free body)
($fun src meta free ,(visit-cont body)))))) ($fun src meta free ,(visit-cont body)))))
(define (elide-values fun) (define (elide-values fun)
(with-fresh-name-state fun (with-fresh-name-state fun
(elide-values* fun))) (let ((conts (build-cont-table fun)))
(elide-values* fun conts))))

2
module/language/cps/reify-primitives.scm
View file

@ -132,7 +132,7 @@
(($ $continue k src exp) (($ $continue k src exp)
,(match exp ,(match exp
(($ $prim name) (($ $prim name)
(match (lookup-cont k conts) (match (vector-ref conts k)
(($ $kargs (_)) (($ $kargs (_))
(cond (cond
((builtin-name->index name) ((builtin-name->index name)

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

@ -123,7 +123,7 @@
(k* (k*
(if (and (continuation-bound-in? k* scope dfg) (if (and (continuation-bound-in? k* scope dfg)
(or values? (or values?
(match (lookup-cont k* (dfg-cont-table dfg)) (match (lookup-cont k* dfg)
(($ $kargs) #t) (($ $kargs) #t)
(_ #f)))) (_ #f))))
(reduce* k* scope values?) (reduce* k* scope values?)
@ -190,7 +190,7 @@
(for-each visit-fun funs) (for-each visit-fun funs)
(visit-term body)) (visit-term body))
(($ $continue k src ($ $values args)) (($ $continue k src ($ $values args))
(match (lookup-cont k (dfg-cont-table dfg)) (match (lookup-cont k dfg)
(($ $kargs names syms body) (($ $kargs names syms body)
(match (lookup-predecessors k dfg) (match (lookup-predecessors k dfg)
((_) ((_)

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

@ -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 ;; Transform the DFG's continuation table to a vector, for easy
;; access. ;; access.
(define (compute-conts!) (define (compute-conts!)
(let ((cont-table (dfg-cont-table dfg))) (let lp ((n 0))
(let lp ((n 0)) (when (< n (vector-length contv))
(when (< n (vector-length contv)) (vector-set! contv n (lookup-cont (cfa-k-sym cfa n) dfg))
(vector-set! contv n (lookup-cont (cfa-k-sym cfa n) cont-table)) (lp (1+ n)))))
(lp (1+ n))))))
;; Record uses and defs, as lists of variable indexes, indexed by ;; Record uses and defs, as lists of variable indexes, indexed by
;; CFA continuation index. ;; CFA continuation index.