[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-891-gd03c3c7
From: |
Andy Wingo |
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-891-gd03c3c7 |
Date: |
Sun, 06 Apr 2014 08:46:05 +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=d03c3c77950dafddec69e87c5f75bec4a4197a60
The branch, master has been updated
via d03c3c77950dafddec69e87c5f75bec4a4197a60 (commit)
via e84cdfb6d4e77344cae031c3a79828062818a27b (commit)
via df1bdc1ea79b3bde822775486955bd329d696bea (commit)
from 9e94cd9bf504b99adbf4f6825ab09efcbf02656f (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 d03c3c77950dafddec69e87c5f75bec4a4197a60
Author: Andy Wingo <address@hidden>
Date: Sat Apr 5 21:08:09 2014 +0200
Flow-sensitive analysis of truth values
* module/language/cps/cse.scm (compute-truthy-expressions):
(compute-equivalent-subexpressions, apply-cse): Arrange to infer
truthiness of expressions, and use that information to elide redundant
tests.
commit e84cdfb6d4e77344cae031c3a79828062818a27b
Author: Andy Wingo <address@hidden>
Date: Sat Apr 5 21:06:35 2014 +0200
Add effects for specialized primitives
* module/language/cps/effects-analysis.scm (make-vector)
(make-vector/immediate, vector-ref/immediate, vector-set!/immediate)
(struct-ref/immediate, struct-set!/immediate): Add effects.
commit df1bdc1ea79b3bde822775486955bd329d696bea
Author: Andy Wingo <address@hidden>
Date: Sat Apr 5 14:38:37 2014 +0200
Minor cleanup/optimization in CSE
* module/language/cps/cse.scm (compute-available-expressions): Remove
needless for-each definition.
(compute-equivalent-subexpressions): Optimize for-each/2.
-----------------------------------------------------------------------
Summary of changes:
module/language/cps/cse.scm | 182 ++++++++++++++++++++++--------
module/language/cps/effects-analysis.scm | 30 +++++-
2 files changed, 165 insertions(+), 47 deletions(-)
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index 4f99483..a0dea1a 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -58,12 +58,6 @@ index corresponds to MIN-LABEL, and so on."
(define (label->idx label) (- label min-label))
(define (idx->label idx) (+ idx min-label))
- (define (for-each f l)
- (let lp ((l l))
- (when (pair? l)
- (f (car l))
- (lp (cdr l)))))
-
(let lp ((n 0))
(when (< n label-count)
(let ((in (make-bitvector label-count #f))
@@ -138,6 +132,75 @@ index corresponds to MIN-LABEL, and so on."
(lp 0 #f #f)
avail-in)))))))
+(define (compute-truthy-expressions dfg min-label label-count)
+ "Compute a \"truth map\", indicating which expressions can be shown to
+be true and/or false at each of LABEL-COUNT expressions in DFG, starting
+from MIN-LABEL. Returns a vector of bitvectors, each bitvector twice as
+long as LABEL-COUNT. The first half of the bitvector indicates labels
+that may be true, and the second half those that may be false. It could
+be that both true and false proofs are available."
+ (let ((boolv (make-vector label-count #f)))
+ (define (label->idx label) (- label min-label))
+ (define (idx->label idx) (+ idx min-label))
+ (define (true-idx idx) idx)
+ (define (false-idx idx) (+ idx label-count))
+
+ (let lp ((n 0))
+ (when (< n label-count)
+ (let ((bool (make-bitvector (* label-count 2) #f)))
+ (vector-set! boolv n bool)
+ (lp (1+ n)))))
+
+ (let ((tmp (make-bitvector (* label-count 2) #f)))
+ (define (bitvector-copy! dst src)
+ (bitvector-fill! dst #f)
+ (bit-set*! dst src #t))
+ (define (intersect! dst src)
+ (bitvector-copy! tmp src)
+ (bit-invert! tmp)
+ (bit-set*! dst tmp #f))
+ (let lp ((n 0) (first? #t) (changed? #f))
+ (cond
+ ((< n label-count)
+ (let* ((label (idx->label n))
+ (bool (vector-ref boolv n))
+ (prev-count (bit-count #t bool)))
+ ;; Intersect truthiness from all predecessors.
+ (let lp ((preds (lookup-predecessors label dfg))
+ (initialized? #f))
+ (match preds
+ (() #t)
+ ((pred . preds)
+ (let ((pidx (label->idx pred)))
+ (cond
+ ((and first? (<= n pidx))
+ ;; Avoid intersecting back-edges and cross-edges on
+ ;; the first iteration.
+ (lp preds initialized?))
+ (else
+ (if initialized?
+ (intersect! bool (vector-ref boolv pidx))
+ (bitvector-copy! bool (vector-ref boolv pidx)))
+ (match (lookup-predecessors pred dfg)
+ ((test)
+ (let ((tidx (label->idx test)))
+ (match (lookup-cont pred dfg)
+ (($ $kif kt kf)
+ (when (eqv? kt label)
+ (bitvector-set! bool (true-idx tidx) #t))
+ (when (eqv? kf label)
+ (bitvector-set! bool (false-idx tidx) #t)))
+ (_ #t))))
+ (_ #t))
+ (lp preds #t)))))))
+ (lp (1+ n) first?
+ (or changed?
+ (not (= prev-count (bit-count #t bool)))))))
+ (else
+ (if (or first? changed?)
+ (lp 0 #f #f)
+ boolv)))))))
+
(define (compute-defs dfg min-label label-count)
(define (cont-defs k)
(match (lookup-cont k dfg)
@@ -258,13 +321,21 @@ index corresponds to MIN-LABEL, and so on."
(idoms (compute-idoms dfg min-label label-count))
(defs (compute-defs dfg min-label label-count))
(var-substs (make-vector var-count #f))
- (label-substs (make-vector label-count #f))
+ (equiv-labels (make-vector label-count #f))
(equiv-set (make-hash-table)))
(define (idx->label idx) (+ idx min-label))
(define (label->idx label) (- label min-label))
(define (idx->var idx) (+ idx min-var))
(define (var->idx var) (- var min-var))
+ (define (for-each/2 f l1 l2)
+ (unless (= (length l1) (length l2))
+ (error "bad lengths" l1 l2))
+ (let lp ((l1 l1) (l2 l2))
+ (when (pair? l1)
+ (f (car l1) (car l2))
+ (lp (cdr l1) (cdr l2)))))
+
(define (subst-var var)
;; It could be that the var is free in this function; if so, its
;; name will be less than min-var.
@@ -311,36 +382,38 @@ index corresponds to MIN-LABEL, and so on."
(when exp-key
(hash-set! equiv-set exp-key (cons label equiv))))
((candidate . candidates)
- (let ((subst (vector-ref defs (label->idx candidate))))
- (cond
- ((not (bitvector-ref avail (label->idx candidate)))
- ;; This expression isn't available here; try
- ;; the next one.
- (lp candidates))
- (else
- ;; Yay, a match. Mark expression for
- ;; replacement with $values.
- (vector-set! label-substs (label->idx label) subst)
- ;; If we dominate the successor, mark vars
- ;; for substitution.
- (when (= label (vector-ref idoms (label->idx k)))
- (for-each
- (lambda (var subst-var)
- (vector-set! var-substs (var->idx var)
subst-var))
- (vector-ref defs (label->idx label))
- subst))))))))))))
+ (cond
+ ((not (bitvector-ref avail (label->idx candidate)))
+ ;; This expression isn't available here; try
+ ;; the next one.
+ (lp candidates))
+ (else
+ ;; Yay, a match. Mark expression as equivalent.
+ (vector-set! equiv-labels (label->idx label)
+ candidate)
+ ;; If we dominate the successor, mark vars
+ ;; for substitution.
+ (when (= label (vector-ref idoms (label->idx k)))
+ (for-each/2
+ (lambda (var subst-var)
+ (vector-set! var-substs (var->idx var)
subst-var))
+ (vector-ref defs (label->idx label))
+ (vector-ref defs (label->idx candidate)))))))))))))
(_ #f))
(lp (1+ label))))
(values (compute-dom-edges idoms min-label)
- label-substs min-label var-substs min-var)))
+ equiv-labels defs min-label var-substs min-var)))
(call-with-values (lambda () (compute-label-and-var-ranges fun)) compute))
-(define (apply-cse fun dfg doms label-substs min-label var-substs min-var)
+(define (apply-cse fun dfg
+ doms equiv-labels defs min-label var-substs min-var boolv)
(define (idx->label idx) (+ idx min-label))
(define (label->idx label) (- label min-label))
(define (idx->var idx) (+ idx min-var))
(define (var->idx var) (- var min-var))
+ (define (true-idx idx) idx)
+ (define (false-idx idx) (+ idx (vector-length equiv-labels)))
(define (subst-var var)
;; It could be that the var is free in this function; if so,
@@ -383,18 +456,36 @@ index corresponds to MIN-LABEL, and so on."
(($ $prompt escape? tag handler)
($prompt escape? (subst-var tag) handler))))
- (define (visit-exp* k exp)
+ (define (visit-exp* k src exp)
(match exp
- ((and fun ($ $fun)) (cse fun dfg))
+ ((and fun ($ $fun))
+ (build-cps-term ($continue k src ,(cse fun dfg))))
(_
- (match (lookup-cont k dfg)
- (($ $kargs names vars)
- (cond
- ((vector-ref label-substs (label->idx label))
- => (lambda (vars)
- (build-cps-exp ($values vars))))
- (else (visit-exp exp))))
- (_ (visit-exp exp))))))
+ (cond
+ ((vector-ref equiv-labels (label->idx label))
+ => (lambda (equiv)
+ (let* ((eidx (label->idx equiv))
+ (vars (vector-ref defs eidx)))
+ (rewrite-cps-term (lookup-cont k dfg)
+ (($ $kif kt kf)
+ ,(let* ((bool (vector-ref boolv (label->idx label)))
+ (t (bitvector-ref bool (true-idx eidx)))
+ (f (bitvector-ref bool (false-idx eidx))))
+ (if (eqv? t f)
+ (build-cps-term
+ ($continue k src ,(visit-exp exp)))
+ (build-cps-term
+ ($continue (if t kt kf) src ($values ()))))))
+ (($ $kargs)
+ ($continue k src ($values vars)))
+ ;; There is no point in adding a case for $ktail, as
+ ;; only $values, $call, or $callk can continue to
+ ;; $ktail.
+ (_
+ ($continue k src ,(visit-exp exp)))))))
+ (else
+ (build-cps-term
+ ($continue k src ,(visit-exp exp))))))))
(define (visit-dom-conts label)
(let ((cont (lookup-cont label dfg)))
@@ -413,22 +504,23 @@ index corresponds to MIN-LABEL, and so on."
($letrec names syms (map (lambda (fun) (cse fun dfg)) funs)
,(visit-term body label)))
(($ $continue k src exp)
- ,(let* ((exp (visit-exp* k exp))
- (conts (append-map visit-dom-conts
- (vector-ref doms (label->idx label)))))
+ ,(let ((conts (append-map visit-dom-conts
+ (vector-ref doms (label->idx label)))))
(if (null? conts)
- (build-cps-term ($continue k src ,exp))
- (build-cps-term ($letk ,conts ($continue k src ,exp))))))))
+ (visit-exp* k src exp)
+ (build-cps-term
+ ($letk ,conts ,(visit-exp* k src exp))))))))
(rewrite-cps-exp fun
(($ $fun src meta free body)
($fun src meta (map subst-var free) ,(visit-entry-cont body)))))
-;; TODO: Truth values, and interprocedural CSE.
(define (cse fun dfg)
(call-with-values (lambda () (compute-equivalent-subexpressions fun dfg))
- (lambda (doms label-substs min-label var-substs min-var)
- (apply-cse fun dfg doms label-substs min-label var-substs min-var))))
+ (lambda (doms equiv-labels defs min-label var-substs min-var)
+ (apply-cse fun dfg doms equiv-labels defs min-label var-substs min-var
+ (compute-truthy-expressions dfg
+ min-label (vector-length
doms))))))
(define (eliminate-common-subexpressions fun)
(call-with-values (lambda () (renumber fun))
diff --git a/module/language/cps/effects-analysis.scm
b/module/language/cps/effects-analysis.scm
index 1725d28..a8e7cb2 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -294,8 +294,12 @@
;; Vectors.
(define-primitive-effects
((vector . _) (cause &allocation))
+ ((make-vector n init) (logior (cause &type-check) (cause &allocation)))
+ ((make-vector/immediate n init) (cause &allocation))
((vector-ref v n) (logior (cause &type-check) &vector))
+ ((vector-ref/immediate v n) (logior (cause &type-check) &vector))
((vector-set! v n x) (logior (cause &type-check) (cause &vector)))
+ ((vector-set!/immediate v n x) (logior (cause &type-check) (cause &vector)))
((vector-length v) (cause &type-check)))
;; Variables.
@@ -323,6 +327,17 @@
(4 &struct-4)
(5 &struct-5)
(_ &struct-6+))))
+ ((struct-ref/immediate s n)
+ (logior (cause &type-check)
+ (match (lookup-constant-index n dfg)
+ (#f &struct)
+ (0 &struct-0)
+ (1 &struct-1)
+ (2 &struct-2)
+ (3 &struct-3)
+ (4 &struct-4)
+ (5 &struct-5)
+ (_ &struct-6+))))
((struct-set! s n x)
(logior (cause &type-check)
(match (lookup-constant-index n dfg)
@@ -334,6 +349,17 @@
(4 (cause &struct-4))
(5 (cause &struct-5))
(_ (cause &struct-6+)))))
+ ((struct-set!/immediate s n x)
+ (logior (cause &type-check)
+ (match (lookup-constant-index n dfg)
+ (#f (cause &struct))
+ (0 (cause &struct-0))
+ (1 (cause &struct-1))
+ (2 (cause &struct-2))
+ (3 (cause &struct-3))
+ (4 (cause &struct-4))
+ (5 (cause &struct-5))
+ (_ (cause &struct-6+)))))
((struct-vtable s) (cause &type-check)))
;; Strings.
@@ -461,8 +487,8 @@
(($ $arity _ () _ () #f) (logior (cause &allocation)
(cause &type-check)))))
(($ $kif) &no-effects)
- (($ $kentry) &type-check)
- (($ $kclause) &type-check)
+ (($ $kentry) (cause &type-check))
+ (($ $kclause) (cause &type-check))
(($ $ktail) &no-effects)))
(lp (1+ n))))
effects))
hooks/post-receive
--
GNU Guile
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-891-gd03c3c7,
Andy Wingo <=