[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-54-g2c02a21
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-54-g2c02a21 |
|
Date: |
Sun, 29 Jun 2014 12:32:54 +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=2c02a21023c946a3d31c43417d440d6babbf2622
The branch, master has been updated
via 2c02a21023c946a3d31c43417d440d6babbf2622 (commit)
via 3a12f2ce0b1827677c2d789f72ce5e5007dede99 (commit)
via b352309301a0d7fe41196b08e34186edda210d86 (commit)
via 6fe36f220e2a346cce0f3da363e5a11fbfd11ff4 (commit)
via b1103eb9804e18654c885d3336ee3b63dec08eb9 (commit)
via d40b05386c72c5a17734ee3fd58e35e931ac46ef (commit)
from ec412d75627aeffbd816ac351eabcd1b533540c6 (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 2c02a21023c946a3d31c43417d440d6babbf2622
Author: Andy Wingo <address@hidden>
Date: Sun Jun 29 14:29:20 2014 +0200
Remove namesets.
This was a failed experiment. It had good space complexity but terrible
time complexity.
* module/Makefile.am: Update.
* module/language/cps/nameset.scm: Remove.
commit 3a12f2ce0b1827677c2d789f72ce5e5007dede99
Author: Andy Wingo <address@hidden>
Date: Sun Jun 29 14:20:52 2014 +0200
Rewrite type inference to use intmaps
* module/language/cps/types.scm: Rewrite to use intmaps instead of
namesets.
commit b352309301a0d7fe41196b08e34186edda210d86
Author: Andy Wingo <address@hidden>
Date: Sun Jun 29 10:41:57 2014 +0200
New module (language cps intmap)
* module/language/cps/intmap.scm: New file.
* module/Makefile.am: Add to build.
commit 6fe36f220e2a346cce0f3da363e5a11fbfd11ff4
Author: Andy Wingo <address@hidden>
Date: Sun Jun 29 14:20:26 2014 +0200
Rewrite CSE to use intsets.
* module/language/cps/cse.scm: Rewrite using intsets.
commit b1103eb9804e18654c885d3336ee3b63dec08eb9
Author: Andy Wingo <address@hidden>
Date: Sun Jun 29 14:09:04 2014 +0200
New module: (language cps intset)
* module/Makefile.am: Add to build.
* module/language/cps/intset.scm: New file.
commit d40b05386c72c5a17734ee3fd58e35e931ac46ef
Author: Andy Wingo <address@hidden>
Date: Sat Jun 28 15:24:29 2014 +0200
Fix bit-count* bug
* libguile/bitvectors.c (scm_bit_count_star): Fix typo introduced in
2005 refactor (!) in which the second arg was erroneously taken from
the first arg.
* test-suite/tests/bitvectors.test: Add test.
* doc/ref/api-compound.texi: Fix doc example for u32vector selector.
-----------------------------------------------------------------------
Summary of changes:
doc/ref/api-compound.texi | 2 +-
libguile/bitvectors.c | 2 +-
module/Makefile.am | 3 +-
module/language/cps/cse.scm | 206 ++++++++++---------
module/language/cps/intmap.scm | 387 +++++++++++++++++++++++++++++++++++
module/language/cps/intset.scm | 417 ++++++++++++++++++++++++++++++++++++++
module/language/cps/nameset.scm | 396 ------------------------------------
module/language/cps/types.scm | 361 +++++++++++++++-----------------
test-suite/tests/bitvectors.test | 4 +
9 files changed, 1093 insertions(+), 685 deletions(-)
create mode 100644 module/language/cps/intmap.scm
create mode 100644 module/language/cps/intset.scm
delete mode 100644 module/language/cps/nameset.scm
diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi
index 055de99..8ec32d6 100644
--- a/doc/ref/api-compound.texi
+++ b/doc/ref/api-compound.texi
@@ -1142,7 +1142,7 @@ For example,
@example
(bit-count* #*01110111 #*11001101 #t) @result{} 3
-(bit-count* #*01110111 #u(7 0 4) #f) @result{} 2
+(bit-count* #*01110111 #u32(7 0 4) #f) @result{} 2
@end example
@end deffn
diff --git a/libguile/bitvectors.c b/libguile/bitvectors.c
index 1611119..d594317 100644
--- a/libguile/bitvectors.c
+++ b/libguile/bitvectors.c
@@ -720,7 +720,7 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0,
ssize_t kv_inc;
const scm_t_uint32 *kv_bits;
- kv_bits = scm_bitvector_elements (v, &kv_handle,
+ kv_bits = scm_bitvector_elements (kv, &kv_handle,
&kv_off, &kv_len, &kv_inc);
if (v_len != kv_len)
diff --git a/module/Makefile.am b/module/Makefile.am
index 4ca70c2..aa7f8ee 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -131,7 +131,8 @@ CPS_LANG_SOURCES =
\
language/cps/dfg.scm \
language/cps/effects-analysis.scm \
language/cps/elide-values.scm \
- language/cps/nameset.scm \
+ language/cps/intmap.scm \
+ language/cps/intset.scm \
language/cps/primitives.scm \
language/cps/prune-bailouts.scm \
language/cps/prune-top-level-scopes.scm \
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index 2f4f432..c8ca695 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -29,104 +29,121 @@
#:use-module (language cps dfg)
#:use-module (language cps effects-analysis)
#:use-module (language cps renumber)
+ #:use-module (language cps intset)
+ #:use-module (rnrs bytevectors)
#:export (eliminate-common-subexpressions))
-(define (compute-always-available-expressions effects)
- "Return the set of continuations whose values are always available
-within their dominance frontier. This is the case for effects that do
-not allocate, read, or write mutable memory."
- (let ((out (make-bitvector (vector-length effects) #f)))
- (let lp ((n 0))
- (cond
- ((< n (vector-length effects))
- (unless (causes-effect? (vector-ref effects n)
- (logior &allocation &read &write))
- (bitvector-set! out n #t))
- (lp (1+ n)))
- (else out)))))
-
-(define (compute-available-expressions dfg min-label label-count)
+(define (cont-successors cont)
+ (match cont
+ (($ $kargs names syms body)
+ (let lp ((body body))
+ (match body
+ (($ $letk conts body) (lp body))
+ (($ $letrec names vars funs body) (lp body))
+ (($ $continue k src exp)
+ (match exp
+ (($ $prompt escape? tag handler) (list k handler))
+ (($ $branch kt) (list k kt))
+ (_ (list k)))))))
+
+ (($ $kreceive arity k) (list k))
+
+ (($ $kclause arity ($ $cont kbody)) (list kbody))
+
+ (($ $kfun src meta self tail clause)
+ (let lp ((clause clause))
+ (match clause
+ (($ $cont kclause ($ $kclause _ _ alt))
+ (cons kclause (lp alt)))
+ (#f '()))))
+
+ (($ $kfun src meta self tail #f) '())
+
+ (($ $ktail) '())))
+
+(define (compute-available-expressions dfg min-label label-count idoms)
"Compute and return the continuations that may be reached if flow
reaches a continuation N. Returns a vector of bitvectors, whose first
index corresponds to MIN-LABEL, and so on."
(let* ((effects (compute-effects dfg min-label label-count))
- (always-avail (compute-always-available-expressions effects))
- ;; Vector of bitvectors, indicating that at a continuation N,
- ;; the values from continuations M... are available.
- (avail-in (make-vector label-count #f))
- (avail-out (make-vector label-count #f)))
+ ;; Vector of intsets, indicating that at a continuation N, the
+ ;; values from continuations M... are available.
+ (avail (make-vector label-count #f))
+ (revisit-label #f))
(define (label->idx label) (- label min-label))
(define (idx->label idx) (+ idx min-label))
+ (define (get-effects label) (vector-ref effects (label->idx label)))
+
+ (define (propagate! pred succ out)
+ (let* ((succ-idx (label->idx succ))
+ (in (match (lookup-predecessors succ dfg)
+ ;; Fast path: normal control flow.
+ ((_) out)
+ ;; Slow path: control-flow join.
+ (_ (cond
+ ((vector-ref avail succ-idx)
+ => (lambda (in)
+ (intset-intersect in out)))
+ (else out))))))
+ (when (and (<= succ pred)
+ (or (not revisit-label) (< succ revisit-label))
+ (not (eq? in (vector-ref avail succ-idx))))
+ ;; Arrange to revisit if this is not a forward edge and the
+ ;; available set changed.
+ (set! revisit-label succ))
+ (vector-set! avail succ-idx in)))
+
+ (define (clobber label in)
+ (let ((fx (get-effects label)))
+ (cond
+ ((not (causes-effect? fx &write))
+ ;; Fast-path if this expression clobbers nothing.
+ in)
+ (else
+ ;; Kill clobbered expressions.
+ (let ((first (let lp ((dom label))
+ (let* ((dom (vector-ref idoms (label->idx dom))))
+ (and (< min-label dom)
+ (let ((fx (vector-ref effects (label->idx
dom))))
+ (if (causes-all-effects? fx)
+ dom
+ (lp dom))))))))
+ (let lp ((i first) (in in))
+ (cond
+ ((intset-next in i)
+ => (lambda (i)
+ (if (effect-clobbers? fx (vector-ref effects (label->idx
i)))
+ (lp (1+ i) (intset-remove in i))
+ (lp (1+ i) in))))
+ (else in))))))))
(synthesize-definition-effects! effects dfg min-label label-count)
- (let lp ((n 0))
- (when (< n label-count)
- (vector-set! avail-in n (make-bitvector label-count #f))
- (vector-set! avail-out n (make-bitvector label-count #f))
- (lp (1+ n))))
+ (vector-set! avail 0 empty-intset)
- (let ((tmp (make-bitvector label-count #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* ((in (vector-ref avail-in n))
- (prev-count (bit-count #t in))
- (out (vector-ref avail-out n))
- (fx (vector-ref effects n)))
- ;; Intersect avail-out from predecessors into "in".
- (let lp ((preds (lookup-predecessors (idx->label n) dfg))
- (initialized? #f))
- (match preds
- (() #t)
- ((pred . preds)
- (let ((pred (label->idx pred)))
- (cond
- ((and first? (<= n pred))
- ;; Avoid intersecting back-edges and cross-edges on
- ;; the first iteration.
- (lp preds initialized?))
- (else
- (if initialized?
- (intersect! in (vector-ref avail-out pred))
- (bitvector-copy! in (vector-ref avail-out pred)))
- (lp preds #t)))))))
- (let ((new-count (bit-count #t in)))
- (unless (= prev-count new-count)
- ;; Copy "in" to "out".
- (bitvector-copy! out in)
- ;; Kill expressions that don't commute.
- (cond
- ((causes-all-effects? fx)
- ;; Fast-path if this expression clobbers the world.
- (intersect! out always-avail))
- ((not (causes-effect? fx &write))
- ;; Fast-path if this expression clobbers nothing.
- #t)
- (else
- ;; Loop of sadness.
- (bitvector-copy! tmp out)
- (bit-set*! tmp always-avail #f)
- (let lp ((i 0))
- (let ((i (bit-position #t tmp i)))
- (when i
- (when (effect-clobbers? fx (vector-ref effects i))
- (bitvector-set! out i #f))
- (lp (1+ i))))))))
- (bitvector-set! out n #t)
- (lp (1+ n) first? (or changed? (not (= prev-count
new-count)))))))
- (else
- (if (or first? changed?)
- (lp 0 #f #f)
- (values avail-in effects))))))))
+ (let lp ((n 0))
+ (cond
+ ((< n label-count)
+ (let* ((label (idx->label n))
+ ;; It's possible for "in" to be #f if it has no
+ ;; predecessors, as is the case for the ktail of a
+ ;; function with an iloop.
+ (in (or (vector-ref avail n) empty-intset))
+ (out (intset-add (clobber label in) label)))
+ (lookup-predecessors label dfg)
+ (let visit-succs ((succs (cont-successors (lookup-cont label dfg))))
+ (match succs
+ (() (lp (1+ n)))
+ ((succ . succs)
+ (propagate! label succ out)
+ (visit-succs succs))))))
+ (revisit-label
+ (let ((n (label->idx revisit-label)))
+ (set! revisit-label #f)
+ (lp n)))
+ (else
+ (values avail effects))))))
(define (compute-truthy-expressions dfg min-label label-count)
"Compute a \"truth map\", indicating which expressions can be shown to
@@ -252,9 +269,8 @@ be that both true and false proofs are available."
;; it immediately dominates. These are the "D" edges in the DJ tree.
(define (compute-equivalent-subexpressions fun dfg)
- (define (compute min-label label-count min-var var-count avail effects)
- (let ((idoms (compute-idoms dfg min-label label-count))
- (defs (compute-defs dfg min-label label-count))
+ (define (compute min-label label-count min-var var-count idoms avail effects)
+ (let ((defs (compute-defs dfg min-label label-count))
(var-substs (make-vector var-count #f))
(equiv-labels (make-vector label-count #f))
(equiv-set (make-hash-table)))
@@ -376,7 +392,7 @@ be that both true and false proofs are available."
equiv))))
(((and head (candidate . vars)) . candidates)
(cond
- ((not (bitvector-ref avail (label->idx candidate)))
+ ((not (intset-ref avail candidate))
;; This expression isn't available here; try
;; the next one.
(lp candidates))
@@ -404,11 +420,13 @@ be that both true and false proofs are available."
(call-with-values (lambda () (compute-label-and-var-ranges fun))
(lambda (min-label label-count min-var var-count)
- (call-with-values
- (lambda ()
- (compute-available-expressions dfg min-label label-count))
- (lambda (avail effects)
- (compute min-label label-count min-var var-count avail effects))))))
+ (let ((idoms (compute-idoms dfg min-label label-count)))
+ (call-with-values
+ (lambda ()
+ (compute-available-expressions dfg min-label label-count idoms))
+ (lambda (avail effects)
+ (compute min-label label-count min-var var-count
+ idoms avail effects)))))))
(define (apply-cse fun dfg
doms equiv-labels min-label var-substs min-var boolv)
diff --git a/module/language/cps/intmap.scm b/module/language/cps/intmap.scm
new file mode 100644
index 0000000..19d04c0
--- /dev/null
+++ b/module/language/cps/intmap.scm
@@ -0,0 +1,387 @@
+;;; Functional name maps
+;;; Copyright (C) 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 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 program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;;
+;;; Some CPS passes need to perform a flow analysis in which every
+;;; program point has an associated map over some set of labels or
+;;; variables. The naive way to implement this is with an array of
+;;; arrays, but this has N^2 complexity, and it really can hurt us.
+;;;
+;;; Instead, this module provides a functional map that can share space
+;;; between program points, reducing the amortized space complexity of
+;;; the representations down to O(n log n). Adding entries to the
+;;; mapping and lookup are O(log n). Intersection and union between
+;;; intmaps that share state are fast, too.
+;;;
+;;; Code:
+
+(define-module (language cps intmap)
+ #:use-module (srfi srfi-9)
+ #:use-module (ice-9 match)
+ #:export (empty-intmap
+ intmap?
+ intmap-add
+ intmap-remove
+ intmap-ref
+ intmap-next
+ intmap-union
+ intmap-intersect))
+
+;; Persistent sparse intmaps.
+
+(define-syntax-rule (define-inline name val)
+ (define-syntax name (identifier-syntax val)))
+
+(define-inline *branch-bits* 4)
+(define-inline *branch-size* (ash 1 *branch-bits*))
+(define-inline *branch-mask* (1- *branch-size*))
+
+(define-record-type <intmap>
+ (make-intmap min shift root)
+ intmap?
+ (min intmap-min)
+ (shift intmap-shift)
+ (root intmap-root))
+
+(define (new-branch)
+ (make-vector *branch-size* #f))
+(define (clone-branch-and-set branch i elt)
+ (let ((new (new-branch)))
+ (when branch (vector-move-left! branch 0 *branch-size* new 0))
+ (vector-set! new i elt)
+ new))
+(define (branch-empty? branch)
+ (let lp ((i 0))
+ (or (= i *branch-size*)
+ (and (not (vector-ref branch i))
+ (lp (1+ i))))))
+
+(define (round-down min shift)
+ (logand min (lognot (1- (ash 1 shift)))))
+
+(define empty-intmap (make-intmap 0 0 #f))
+
+(define (add-level min shift root)
+ (let* ((shift* (+ shift *branch-bits*))
+ (min* (round-down min shift*))
+ (idx (logand (ash (- min min*) (- shift))
+ *branch-mask*)))
+ (make-intmap min* shift* (clone-branch-and-set #f idx root))))
+
+(define (make-intmap/prune min shift root)
+ (if (zero? shift)
+ (make-intmap min shift root)
+ (let lp ((i 0) (elt #f))
+ (cond
+ ((< i *branch-size*)
+ (if (vector-ref root i)
+ (if elt
+ (make-intmap min shift root)
+ (lp (1+ i) i))
+ (lp (1+ i) elt)))
+ (elt
+ (let ((shift (- shift *branch-bits*)))
+ (make-intmap/prune (+ min (ash elt shift))
+ shift
+ (vector-ref root elt))))
+ ;; Shouldn't be reached...
+ (else empty-intmap)))))
+
+(define (intmap-add bs i val meet)
+ (define (adjoin i shift root)
+ (cond
+ ((zero? shift)
+ (cond
+ ((eq? root val) root)
+ ((not root) val)
+ (else (meet root val))))
+ (else
+ (let* ((shift (- shift *branch-bits*))
+ (idx (logand (ash i (- shift)) *branch-mask*))
+ (node (and root (vector-ref root idx)))
+ (new-node (adjoin i shift node)))
+ (if (eq? node new-node)
+ root
+ (clone-branch-and-set root idx new-node))))))
+ (match bs
+ (($ <intmap> min shift root)
+ (cond
+ ((not val) (intmap-remove bs i))
+ ((not root)
+ ;; Add first element.
+ (make-intmap i 0 val))
+ ((and (<= min i) (< i (+ min (ash 1 shift))))
+ ;; Add element to map; level will not change.
+ (let ((old-root root)
+ (root (adjoin (- i min) shift root)))
+ (if (eq? root old-root)
+ bs
+ (make-intmap min shift root))))
+ ((< i min)
+ ;; Rebuild the tree by unioning two intmaps.
+ (intmap-union (intmap-add empty-intmap i val error) bs error))
+ (else
+ ;; Add a new level and try again.
+ (intmap-add (add-level min shift root) i val error))))))
+
+(define (intmap-remove bs i)
+ (define (remove i shift root)
+ (cond
+ ((zero? shift) #f)
+ (else
+ (let* ((shift (- shift *branch-bits*))
+ (idx (logand (ash i (- shift)) *branch-mask*)))
+ (cond
+ ((vector-ref root idx)
+ => (lambda (node)
+ (let ((new-node (remove i shift node)))
+ (if (eq? node new-node)
+ root
+ (let ((root (clone-branch-and-set root idx new-node)))
+ (and (or new-node (not (branch-empty? root)))
+ root))))))
+ (else root))))))
+ (match bs
+ (($ <intmap> min shift root)
+ (cond
+ ((not root) bs)
+ ((and (<= min i) (< i (+ min (ash 1 shift))))
+ ;; Add element to map; level will not change.
+ (let ((old-root root)
+ (root (remove (- i min) shift root)))
+ (if (eq? root old-root)
+ bs
+ (make-intmap/prune min shift root))))
+ (else bs)))))
+
+(define (intmap-ref bs i)
+ (match bs
+ (($ <intmap> min shift root)
+ (and (<= min i) (< i (+ min (ash 1 shift)))
+ (let ((i (- i min)))
+ (let lp ((node root) (shift shift))
+ (and node
+ (if (= shift *branch-bits*)
+ (vector-ref node (logand i *branch-mask*))
+ (let* ((shift (- shift *branch-bits*))
+ (idx (logand (ash i (- shift))
+ *branch-mask*)))
+ (lp (vector-ref node idx) shift))))))))))
+
+(define (intmap-next bs i)
+ (define (visit-branch node shift i)
+ (let lp ((i i) (idx (logand (ash i (- shift)) *branch-mask*)))
+ (and (< idx *branch-size*)
+ (or (visit-node (vector-ref node idx) shift i)
+ (let ((inc (ash 1 shift)))
+ (lp (+ (round-down i shift) inc) (1+ idx)))))))
+ (define (visit-node node shift i)
+ (and node
+ (if (zero? shift)
+ i
+ (visit-branch node (- shift *branch-bits*) i))))
+ (match bs
+ (($ <intmap> min shift root)
+ (let ((i (if (and i (< min i))
+ (- i min)
+ 0)))
+ (and (< i (ash 1 shift))
+ (let ((i (visit-node root shift i)))
+ (and i (+ min i))))))))
+
+(define (intmap-union a b meet)
+ ;; Union A and B from index I; the result will be fresh.
+ (define (union-branches/fresh shift a b i fresh)
+ (let lp ((i 0))
+ (cond
+ ((< i *branch-size*)
+ (let* ((a-child (vector-ref a i))
+ (b-child (vector-ref b i)))
+ (vector-set! fresh i (union shift a-child b-child))
+ (lp (1+ i))))
+ (else fresh))))
+ ;; Union A and B from index I; the result may be eq? to A.
+ (define (union-branches/a shift a b i)
+ (let lp ((i i))
+ (cond
+ ((< i *branch-size*)
+ (let* ((a-child (vector-ref a i))
+ (b-child (vector-ref b i)))
+ (if (eq? a-child b-child)
+ (lp (1+ i))
+ (let ((child (union shift a-child b-child)))
+ (cond
+ ((eq? a-child child)
+ (lp (1+ i)))
+ (else
+ (let ((result (clone-branch-and-set a i child)))
+ (union-branches/fresh shift a b (1+ i) result))))))))
+ (else a))))
+ ;; Union A and B; the may could be eq? to either.
+ (define (union-branches shift a b)
+ (let lp ((i 0))
+ (cond
+ ((< i *branch-size*)
+ (let* ((a-child (vector-ref a i))
+ (b-child (vector-ref b i)))
+ (if (eq? a-child b-child)
+ (lp (1+ i))
+ (let ((child (union shift a-child b-child)))
+ (cond
+ ((eq? a-child child)
+ (union-branches/a shift a b (1+ i)))
+ ((eq? b-child child)
+ (union-branches/a shift b a (1+ i)))
+ (else
+ (let ((result (clone-branch-and-set a i child)))
+ (union-branches/fresh shift a b (1+ i) result))))))))
+ ;; Seems they are the same but not eq?. Odd.
+ (else a))))
+ (define (union shift a-node b-node)
+ (cond
+ ((not a-node) b-node)
+ ((not b-node) a-node)
+ ((eq? a-node b-node) a-node)
+ ((zero? shift) (meet a-node b-node))
+ (else (union-branches (- shift *branch-bits*) a-node b-node))))
+ (match (cons a b)
+ ((($ <intmap> a-min a-shift a-root) . ($ <intmap> b-min b-shift b-root))
+ (cond
+ ((not (= b-shift a-shift))
+ ;; Hoist the map with the lowest shift to meet the one with the
+ ;; higher shift.
+ (if (< b-shift a-shift)
+ (intmap-union a (add-level b-min b-shift b-root) meet)
+ (intmap-union (add-level a-min a-shift a-root) b meet)))
+ ((not (= b-min a-min))
+ ;; Nodes at the same shift but different minimums will cover
+ ;; disjoint ranges (due to the round-down call on min). Hoist
+ ;; both until they cover the same range.
+ (intmap-union (add-level a-min a-shift a-root)
+ (add-level b-min b-shift b-root)
+ meet))
+ (else
+ ;; At this point, A and B cover the same range.
+ (let ((root (union a-shift a-root b-root)))
+ (cond
+ ((eq? root a-root) a)
+ ((eq? root b-root) b)
+ (else (make-intmap a-min a-shift root)))))))))
+
+(define (intmap-intersect a b meet)
+ ;; Intersect A and B from index I; the result will be fresh.
+ (define (intersect-branches/fresh shift a b i fresh)
+ (let lp ((i 0))
+ (cond
+ ((< i *branch-size*)
+ (let* ((a-child (vector-ref a i))
+ (b-child (vector-ref b i)))
+ (vector-set! fresh i (intersect shift a-child b-child))
+ (lp (1+ i))))
+ ((branch-empty? fresh) #f)
+ (else fresh))))
+ ;; Intersect A and B from index I; the result may be eq? to A.
+ (define (intersect-branches/a shift a b i)
+ (let lp ((i i))
+ (cond
+ ((< i *branch-size*)
+ (let* ((a-child (vector-ref a i))
+ (b-child (vector-ref b i)))
+ (if (eq? a-child b-child)
+ (lp (1+ i))
+ (let ((child (intersect shift a-child b-child)))
+ (cond
+ ((eq? a-child child)
+ (lp (1+ i)))
+ (else
+ (let ((result (clone-branch-and-set a i child)))
+ (intersect-branches/fresh shift a b (1+ i) result))))))))
+ (else a))))
+ ;; Intersect A and B; the may could be eq? to either.
+ (define (intersect-branches shift a b)
+ (let lp ((i 0))
+ (cond
+ ((< i *branch-size*)
+ (let* ((a-child (vector-ref a i))
+ (b-child (vector-ref b i)))
+ (if (eq? a-child b-child)
+ (lp (1+ i))
+ (let ((child (intersect shift a-child b-child)))
+ (cond
+ ((eq? a-child child)
+ (intersect-branches/a shift a b (1+ i)))
+ ((eq? b-child child)
+ (intersect-branches/a shift b a (1+ i)))
+ (else
+ (let ((result (clone-branch-and-set a i child)))
+ (intersect-branches/fresh shift a b (1+ i) result))))))))
+ ;; Seems they are the same but not eq?. Odd.
+ (else a))))
+ (define (intersect shift a-node b-node)
+ (cond
+ ((or (not a-node) (not b-node)) #f)
+ ((eq? a-node b-node) a-node)
+ ((zero? shift) (meet a-node b-node))
+ (else (intersect-branches (- shift *branch-bits*) a-node b-node))))
+
+ (define (different-mins lo-min lo-shift lo-root hi-min hi-shift hi lo-is-a?)
+ (cond
+ ((<= lo-shift hi-shift)
+ ;; If LO has a lower shift and a lower min, it is disjoint. If
+ ;; it has the same shift and a different min, it is also
+ ;; disjoint.
+ empty-intmap)
+ (else
+ (let* ((lo-shift (- lo-shift *branch-bits*))
+ (lo-idx (ash (- hi-min lo-min) (- lo-shift))))
+ (if (>= lo-idx *branch-size*)
+ ;; HI has a lower shift, but it not within LO.
+ empty-intmap
+ (let ((lo (make-intmap (+ lo-min (ash lo-idx lo-shift))
+ lo-shift
+ (vector-ref lo-root lo-idx))))
+ (if lo-is-a?
+ (intmap-intersect lo hi meet)
+ (intmap-intersect hi lo meet))))))))
+
+ (define (different-shifts-same-min min hi-shift hi-root lo lo-is-a?)
+ (let ((hi (make-intmap min
+ (- hi-shift *branch-bits*)
+ (vector-ref hi-root 0))))
+ (if lo-is-a?
+ (intmap-intersect lo hi meet)
+ (intmap-intersect hi lo meet))))
+
+ (match (cons a b)
+ ((($ <intmap> a-min a-shift a-root) . ($ <intmap> b-min b-shift b-root))
+ (cond
+ ((< a-min b-min)
+ (different-mins a-min a-shift a-root b-min b-shift b #t))
+ ((< b-min a-min)
+ (different-mins b-min b-shift b-root a-min a-shift a #f))
+ ((< a-shift b-shift)
+ (different-shifts-same-min b-min b-shift b-root a #t))
+ ((< b-shift a-shift)
+ (different-shifts-same-min a-min a-shift a-root b #f))
+ (else
+ ;; At this point, A and B cover the same range.
+ (let ((root (intersect a-shift a-root b-root)))
+ (cond
+ ((eq? root a-root) a)
+ ((eq? root b-root) b)
+ (else (make-intmap/prune a-min a-shift root)))))))))
diff --git a/module/language/cps/intset.scm b/module/language/cps/intset.scm
new file mode 100644
index 0000000..8bda290
--- /dev/null
+++ b/module/language/cps/intset.scm
@@ -0,0 +1,417 @@
+;;; Functional name maps
+;;; Copyright (C) 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 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 program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;;
+;;; A persistent, functional data structure representing a set of
+;;; integers as a tree whose branches are vectors and whose leaves are
+;;; fixnums. Intsets are careful to preserve sub-structure, in the
+;;; sense of eq?, whereever possible.
+;;;
+;;; Code:
+
+(define-module (language cps intset)
+ #:use-module (rnrs bytevectors)
+ #:use-module (srfi srfi-9)
+ #:use-module (ice-9 match)
+ #:export (empty-intset
+ intset?
+ intset-add
+ intset-remove
+ intset-ref
+ intset-next
+ intset-union
+ intset-intersect))
+
+(define-syntax-rule (define-inline name val)
+ (define-syntax name (identifier-syntax val)))
+
+(define-inline *leaf-bits* 5)
+(define-inline *leaf-size* (ash 1 *leaf-bits*))
+(define-inline *leaf-mask* (1- *leaf-size*))
+(define-inline *branch-bits* 3)
+(define-inline *branch-size* (ash 1 *branch-bits*))
+(define-inline *branch-mask* (1- *branch-size*))
+
+(define-record-type <intset>
+ (make-intset min shift root)
+ intset?
+ (min intset-min)
+ (shift intset-shift)
+ (root intset-root))
+
+(define (new-leaf) 0)
+(define-inlinable (clone-leaf-and-set leaf i val)
+ (if val
+ (if leaf
+ (logior leaf (ash 1 i))
+ (ash 1 i))
+ (if leaf
+ (logand leaf (lognot (ash 1 i)))
+ #f)))
+(define (leaf-empty? leaf)
+ (zero? leaf))
+
+(define (new-branch)
+ (make-vector *branch-size* #f))
+(define (clone-branch-and-set branch i elt)
+ (let ((new (new-branch)))
+ (when branch (vector-move-left! branch 0 *branch-size* new 0))
+ (vector-set! new i elt)
+ new))
+(define (branch-empty? branch)
+ (let lp ((i 0))
+ (or (= i *branch-size*)
+ (and (not (vector-ref branch i))
+ (lp (1+ i))))))
+
+(define (round-down min shift)
+ (logand min (lognot (1- (ash 1 shift)))))
+
+(define empty-intset (make-intset 0 *leaf-bits* #f))
+
+(define (add-level min shift root)
+ (let* ((shift* (+ shift *branch-bits*))
+ (min* (round-down min shift*))
+ (idx (logand (ash (- min min*) (- shift)) *branch-mask*)))
+ (make-intset min* shift* (clone-branch-and-set #f idx root))))
+
+(define (make-intset/prune min shift root)
+ (if (= shift *leaf-bits*)
+ (make-intset min shift root)
+ (let lp ((i 0) (elt #f))
+ (cond
+ ((< i *branch-size*)
+ (if (vector-ref root i)
+ (if elt
+ (make-intset min shift root)
+ (lp (1+ i) i))
+ (lp (1+ i) elt)))
+ (elt
+ (let ((shift (- shift *branch-bits*)))
+ (make-intset/prune (+ min (ash elt shift))
+ shift
+ (vector-ref root elt))))
+ ;; Shouldn't be reached...
+ (else empty-intset)))))
+
+(define (intset-add bs i)
+ (define (adjoin i shift root)
+ (cond
+ ((= shift *leaf-bits*)
+ (let ((idx (logand i *leaf-mask*)))
+ (if (and root (logbit? idx root))
+ root
+ (clone-leaf-and-set root idx #t))))
+ (else
+ (let* ((shift (- shift *branch-bits*))
+ (idx (logand (ash i (- shift)) *branch-mask*))
+ (node (and root (vector-ref root idx)))
+ (new-node (adjoin i shift node)))
+ (if (eq? node new-node)
+ root
+ (clone-branch-and-set root idx new-node))))))
+ (match bs
+ (($ <intset> min shift root)
+ (cond
+ ((not root)
+ ;; Add first element.
+ (let ((min (round-down i shift)))
+ (make-intset min *leaf-bits*
+ (adjoin (- i min) *leaf-bits* root))))
+ ((and (<= min i) (< i (+ min (ash 1 shift))))
+ ;; Add element to set; level will not change.
+ (let ((old-root root)
+ (root (adjoin (- i min) shift root)))
+ (if (eq? root old-root)
+ bs
+ (make-intset min shift root))))
+ ((< i min)
+ ;; Rebuild the tree by unioning two intsets.
+ (intset-union (intset-add empty-intset i) bs))
+ (else
+ ;; Add a new level and try again.
+ (intset-add (add-level min shift root) i))))))
+
+(define (intset-remove bs i)
+ (define (remove i shift root)
+ (cond
+ ((= shift *leaf-bits*)
+ (let ((idx (logand i *leaf-mask*)))
+ (if (logbit? idx root)
+ (let ((root (clone-leaf-and-set root idx #f)))
+ (and (not (leaf-empty? root)) root))
+ root)))
+ (else
+ (let* ((shift (- shift *branch-bits*))
+ (idx (logand (ash i (- shift)) *branch-mask*)))
+ (cond
+ ((vector-ref root idx)
+ => (lambda (node)
+ (let ((new-node (remove i shift node)))
+ (if (eq? node new-node)
+ root
+ (let ((root (clone-branch-and-set root idx new-node)))
+ (and (or new-node (not (branch-empty? root)))
+ root))))))
+ (else root))))))
+ (match bs
+ (($ <intset> min shift root)
+ (cond
+ ((not root) bs)
+ ((and (<= min i) (< i (+ min (ash 1 shift))))
+ ;; Add element to set; level will not change.
+ (let ((old-root root)
+ (root (remove (- i min) shift root)))
+ (if (eq? root old-root)
+ bs
+ (make-intset/prune min shift root))))
+ (else bs)))))
+
+(define (intset-ref bs i)
+ (match bs
+ (($ <intset> min shift root)
+ (and (<= min i) (< i (+ min (ash 1 shift)))
+ (let ((i (- i min)))
+ (let lp ((node root) (shift shift))
+ (and node
+ (if (= shift *leaf-bits*)
+ (logbit? (logand i *leaf-mask*) node)
+ (let* ((shift (- shift *branch-bits*))
+ (idx (logand (ash i (- shift)) *branch-mask*)))
+ (lp (vector-ref node idx) shift))))))))))
+
+(define (intset-next bs i)
+ (define (visit-leaf node i)
+ (let lp ((idx (logand i *leaf-mask*)))
+ (if (logbit? idx node)
+ (logior (logand i (lognot *leaf-mask*)) idx)
+ (let ((idx (1+ idx)))
+ (and (< idx *leaf-size*)
+ (lp idx))))))
+ (define (visit-branch node shift i)
+ (let lp ((i i) (idx (logand (ash i (- shift)) *branch-mask*)))
+ (and (< idx *branch-size*)
+ (or (visit-node (vector-ref node idx) shift i)
+ (let ((inc (ash 1 shift)))
+ (lp (+ (round-down i shift) inc) (1+ idx)))))))
+ (define (visit-node node shift i)
+ (and node
+ (if (= shift *leaf-bits*)
+ (visit-leaf node i)
+ (visit-branch node (- shift *branch-bits*) i))))
+ (match bs
+ (($ <intset> min shift root)
+ (let ((i (if (and i (< min i))
+ (- i min)
+ 0)))
+ (and (< i (ash 1 shift))
+ (let ((i (visit-node root shift i)))
+ (and i (+ min i))))))))
+
+(define (intset-size shift root)
+ (cond
+ ((not root) 0)
+ ((= *leaf-bits* shift) *leaf-size*)
+ (else
+ (let lp ((i (1- *branch-size*)))
+ (let ((node (vector-ref root i)))
+ (if node
+ (let ((shift (- shift *branch-bits*)))
+ (+ (intset-size shift node)
+ (* i (ash 1 shift))))
+ (lp (1- i))))))))
+
+(define (intset-union a b)
+ ;; Union leaves.
+ (define (union-leaves a b)
+ (logior (or a 0) (or b 0)))
+ ;; Union A and B from index I; the result will be fresh.
+ (define (union-branches/fresh shift a b i fresh)
+ (let lp ((i 0))
+ (cond
+ ((< i *branch-size*)
+ (let* ((a-child (vector-ref a i))
+ (b-child (vector-ref b i)))
+ (vector-set! fresh i (union shift a-child b-child))
+ (lp (1+ i))))
+ (else fresh))))
+ ;; Union A and B from index I; the result may be eq? to A.
+ (define (union-branches/a shift a b i)
+ (let lp ((i i))
+ (cond
+ ((< i *branch-size*)
+ (let* ((a-child (vector-ref a i))
+ (b-child (vector-ref b i)))
+ (if (eq? a-child b-child)
+ (lp (1+ i))
+ (let ((child (union shift a-child b-child)))
+ (cond
+ ((eq? a-child child)
+ (lp (1+ i)))
+ (else
+ (let ((result (clone-branch-and-set a i child)))
+ (union-branches/fresh shift a b (1+ i) result))))))))
+ (else a))))
+ ;; Union A and B; the may could be eq? to either.
+ (define (union-branches shift a b)
+ (let lp ((i 0))
+ (cond
+ ((< i *branch-size*)
+ (let* ((a-child (vector-ref a i))
+ (b-child (vector-ref b i)))
+ (if (eq? a-child b-child)
+ (lp (1+ i))
+ (let ((child (union shift a-child b-child)))
+ (cond
+ ((eq? a-child child)
+ (union-branches/a shift a b (1+ i)))
+ ((eq? b-child child)
+ (union-branches/a shift b a (1+ i)))
+ (else
+ (let ((result (clone-branch-and-set a i child)))
+ (union-branches/fresh shift a b (1+ i) result))))))))
+ ;; Seems they are the same but not eq?. Odd.
+ (else a))))
+ (define (union shift a-node b-node)
+ (cond
+ ((not a-node) b-node)
+ ((not b-node) a-node)
+ ((eq? a-node b-node) a-node)
+ ((= shift *leaf-bits*) (union-leaves a-node b-node))
+ (else (union-branches (- shift *branch-bits*) a-node b-node))))
+ (match (cons a b)
+ ((($ <intset> a-min a-shift a-root) . ($ <intset> b-min b-shift b-root))
+ (cond
+ ((not (= b-shift a-shift))
+ ;; Hoist the set with the lowest shift to meet the one with the
+ ;; higher shift.
+ (if (< b-shift a-shift)
+ (intset-union a (add-level b-min b-shift b-root))
+ (intset-union (add-level a-min a-shift a-root) b)))
+ ((not (= b-min a-min))
+ ;; Nodes at the same shift but different minimums will cover
+ ;; disjoint ranges (due to the round-down call on min). Hoist
+ ;; both until they cover the same range.
+ (intset-union (add-level a-min a-shift a-root)
+ (add-level b-min b-shift b-root)))
+ (else
+ ;; At this point, A and B cover the same range.
+ (let ((root (union a-shift a-root b-root)))
+ (cond
+ ((eq? root a-root) a)
+ ((eq? root b-root) b)
+ (else (make-intset a-min a-shift root)))))))))
+
+(define (intset-intersect a b)
+ (define tmp (new-leaf))
+ ;; Intersect leaves.
+ (define (intersect-leaves a b)
+ (logand a b))
+ ;; Intersect A and B from index I; the result will be fresh.
+ (define (intersect-branches/fresh shift a b i fresh)
+ (let lp ((i 0))
+ (cond
+ ((< i *branch-size*)
+ (let* ((a-child (vector-ref a i))
+ (b-child (vector-ref b i)))
+ (vector-set! fresh i (intersect shift a-child b-child))
+ (lp (1+ i))))
+ ((branch-empty? fresh) #f)
+ (else fresh))))
+ ;; Intersect A and B from index I; the result may be eq? to A.
+ (define (intersect-branches/a shift a b i)
+ (let lp ((i i))
+ (cond
+ ((< i *branch-size*)
+ (let* ((a-child (vector-ref a i))
+ (b-child (vector-ref b i)))
+ (if (eq? a-child b-child)
+ (lp (1+ i))
+ (let ((child (intersect shift a-child b-child)))
+ (cond
+ ((eq? a-child child)
+ (lp (1+ i)))
+ (else
+ (let ((result (clone-branch-and-set a i child)))
+ (intersect-branches/fresh shift a b (1+ i) result))))))))
+ (else a))))
+ ;; Intersect A and B; the may could be eq? to either.
+ (define (intersect-branches shift a b)
+ (let lp ((i 0))
+ (cond
+ ((< i *branch-size*)
+ (let* ((a-child (vector-ref a i))
+ (b-child (vector-ref b i)))
+ (if (eq? a-child b-child)
+ (lp (1+ i))
+ (let ((child (intersect shift a-child b-child)))
+ (cond
+ ((eq? a-child child)
+ (intersect-branches/a shift a b (1+ i)))
+ ((eq? b-child child)
+ (intersect-branches/a shift b a (1+ i)))
+ (else
+ (let ((result (clone-branch-and-set a i child)))
+ (intersect-branches/fresh shift a b (1+ i) result))))))))
+ ;; Seems they are the same but not eq?. Odd.
+ (else a))))
+ (define (intersect shift a-node b-node)
+ (cond
+ ((or (not a-node) (not b-node)) #f)
+ ((eq? a-node b-node) a-node)
+ ((= shift *leaf-bits*) (intersect-leaves a-node b-node))
+ (else (intersect-branches (- shift *branch-bits*) a-node b-node))))
+ (match (cons a b)
+ ((($ <intset> a-min a-shift a-root) . ($ <intset> b-min b-shift b-root))
+ (cond
+ ((< a-min b-min)
+ ;; Make A have the higher min.
+ (intset-intersect b a))
+ ((< b-min a-min)
+ (cond
+ ((<= b-shift a-shift)
+ ;; If B has a lower shift and a lower min, it is disjoint. If
+ ;; it has the same shift and a different min, it is also
+ ;; disjoint.
+ empty-intset)
+ (else
+ (let* ((b-shift (- b-shift *branch-bits*))
+ (b-idx (ash (- a-min b-min) (- b-shift))))
+ (if (>= b-idx *branch-size*)
+ ;; A has a lower shift, but it not within B.
+ empty-intset
+ (intset-intersect a
+ (make-intset (+ b-min (ash b-idx b-shift))
+ b-shift
+ (vector-ref b-root b-idx))))))))
+ ((< b-shift a-shift)
+ ;; Make A have the lower shift.
+ (intset-intersect b a))
+ ((< a-shift b-shift)
+ ;; A and B have the same min but a different shift. Recurse down.
+ (intset-intersect a
+ (make-intset b-min
+ (- b-shift *branch-bits*)
+ (vector-ref b-root 0))))
+ (else
+ ;; At this point, A and B cover the same range.
+ (let ((root (intersect a-shift a-root b-root)))
+ (cond
+ ((eq? root a-root) a)
+ ((eq? root b-root) b)
+ (else (make-intset/prune a-min a-shift root)))))))))
diff --git a/module/language/cps/nameset.scm b/module/language/cps/nameset.scm
deleted file mode 100644
index 823da61..0000000
--- a/module/language/cps/nameset.scm
+++ /dev/null
@@ -1,396 +0,0 @@
-;;; Functional name maps
-;;; Copyright (C) 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 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 program. If not, see
-;;; <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;;
-;;; Some CPS passes need to perform a flow analysis in which every
-;;; program point has an associated map over some set of labels or
-;;; variables. The naive way to implement this is with an array of
-;;; arrays, but this has N^2 complexity, and it really can hurt us.
-;;;
-;;; Instead, this module provides a functional map that can share space
-;;; between program points, reducing the amortized space complexity of
-;;; the representations down to O(n). Adding entries to the mapping is
-;;; O(1), though lookup is O(log n). When augmented with a dominator
-;;; analysis, "meet" operations (intersection or union) can be made in
-;;; O(log n) time as well, which results in overall O(n log n)
-;;; complexity for flow analysis. (It would be nice to prove this
-;;; properly; I could have some of the details wrong.)
-;;;
-;;; Namesets are functional hashed lists that map names (unsigned
-;;; integers) to values. Instead of using vhashes from ice-9/vlist.scm,
-;;; we copy that code below and specialize it to hold pointerless tuple
-;;; values. The code was originally written by Ludovic Courtès
-;;; <address@hidden>. See ice-9/vlist.scm for more detailed commentary.
-;;;
-;;; A nameset backing store starts with the entries of the hash table,
-;;; including the chain links, the keys, and the payload. A bucket list
-;;; array follows.
-;;;
-;;; Although the hash table logic is the same for all namesets, each
-;;; nameset kind can have its own payload size and format. Adding an
-;;; entry to a nameset fills in the next unused hash entry slot and
-;;; updates the corresponding bucket to point to the newly allocated
-;;; hash entry.
-;;;
-;;; As an example, consider a nameset with two entries, each with its
-;;; key K, and with 12 bytes of payload consisting of type T and range
-;;; R- and R+. Assume that H = hashv(K1) = hashv(K2). The resulting
-;;; layout is as follows:
-;;;
-;;; byte offset contents
-;;; 0 ,---------------------------.
-;;; +4 | size | Header
-;;; +8 | next-free |
-;;; 8 +---------------------------+
-;;; +0 | -1, K1, T1, R-1, R+1 |
-;;; +20 | ,-> 0, K2, T2, R-2, R+2 | Chain links
-;;; +40 | | |
-;;; 8 + size * 20 +-|-------------------------+
-;;; +0 | | -1 | Hash buckets
-;;; +4 | | -1 |
-;;; +8 | '-- 1 <-------------------- H
-;;; 8 + size * 24 `---------------------------'
-;;;
-;;; For the purposes of illustration, the backing store has size 3,
-;;; indicating space for three entries. In practice backing stores will
-;;; only have power-of-two sizes.
-;;;
-;;; Code:
-
-(define-module (language cps nameset)
- #:use-module (rnrs bytevectors)
- #:export (define-nameset-type))
-
-(define-syntax define-nameset-type
- (lambda (x)
- (define (id base suffix)
- (datum->syntax base (symbol-append (syntax->datum base) suffix)))
- (define-syntax-rule (with-ids (stem suffix ...) body)
- (with-syntax ((suffix (id stem 'suffix))
- ...)
- body))
- (syntax-case x ()
- ((_ (stem val ... #:size size) read write meet)
- (with-ids
- (#'stem -null -lookup -ref -has-entry? -length -add -meet)
- #'(define-values (-null -lookup -ref -has-entry? -length -add -meet)
- (let ((read* read) (write* write) (meet* meet))
- (nameset-type (val ... #:size size)
- read* write* meet*))))))))
-
-(define-syntax-rule (nameset-type (val ... #:size *value-size*)
- value-ref value-set!
- value-meet)
- (let* ((*size-offset* 0)
- (*next-free-offset* 4)
- (*header-size* 8)
-
- ;; int32 link
- (*link-size* 4)
- (*link-offset* 0)
- ;; uint32 key
- (*key-size* 4)
- (*key-offset* 4)
-
- ;; *value-size* is a parameter.
- (*value-offset* 8)
-
- (*entry-size* (+ *key-size* *link-size* *value-size*))
-
- ;; int32 bucket
- (*bucket-size* 4))
-
- (define (block-size block)
- (bytevector-u32-native-ref block *size-offset*))
- (define (block-next-free block)
- (bytevector-u32-native-ref block *next-free-offset*))
-
- (define (set-block-next-free! block next-free)
- (bytevector-u32-native-set! block *next-free-offset* next-free))
-
- (define (block-key-ref block offset)
- (let ((entry (+ *header-size* (* offset *entry-size*))))
- (bytevector-u32-native-ref block (+ entry *key-offset*))))
-
- (define (block-link-ref block offset)
- (let ((entry (+ *header-size* (* offset *entry-size*))))
- (bytevector-s32-native-ref block (+ entry *link-offset*))))
-
- (define (block-value-ref block offset)
- (let ((entry (+ *header-size* (* offset *entry-size*))))
- (value-ref block (+ entry *value-offset*))))
-
- (define (hash-bucket-offset size khash)
- (+ *header-size* (* size *entry-size*) (* khash *bucket-size*)))
-
- ;; Returns the index of the last entry stored in BLOCK with
- ;; SIZE-modulo hash value KHASH.
- (define (block-hash-bucket-ref block size khash)
- (bytevector-s32-native-ref block (hash-bucket-offset size khash)))
-
- (define (block-entry-init! block offset key val ...)
- (let* ((size (block-size block))
- (entry (+ *header-size* (* offset *entry-size*)))
- (hash (hashv key size))
- (link (block-hash-bucket-ref block size hash)))
- (bytevector-s32-native-set! block (+ entry *link-offset*) link)
- (bytevector-u32-native-set! block (+ entry *key-offset*) key)
- (value-set! block (+ entry *value-offset*) val ...)
- (bytevector-s32-native-set! block (hash-bucket-offset size hash)
offset)))
-
- (define (make-block size)
- ;; Having the fill value be -1 makes the initial buckets empty. The
- ;; fill value doesn't affect the other fields.
- (let ((bv (make-bytevector (+ *header-size*
- (* size (+ *entry-size* *bucket-size*)))
- -1)))
- (bytevector-u32-native-set! bv *size-offset* size)
- (bytevector-u32-native-set! bv *next-free-offset* 0)
- bv))
-
- ;;;
- ;;; nameset := (OFFSET . HEAD)
- ;;; head := (BLOCK . TAIL)
- ;;; tail := '() | NAMESET
- ;;;
- (define (make-nameset offset head) (cons offset head))
- (define (nameset-offset nameset) (car nameset))
- (define (nameset-head nameset) (cdr nameset))
-
- (define (make-nameset-head block tail) (cons block tail))
- (define (nameset-head-block head) (car head))
- (define (nameset-head-tail head) (cdr head))
-
- (define (nameset-block nameset)
- (nameset-head-block (nameset-head nameset)))
- (define (nameset-tail nameset)
- (nameset-head-tail (nameset-head nameset)))
-
- (define block-null (make-block 0))
- (define nameset-null (make-nameset 0 (make-nameset-head block-null '())))
-
- (define (nameset-ref nameset index)
- "Return the element at index INDEX in NAMESET."
- (let loop ((index index)
- (nameset nameset))
- (let ((block (nameset-block nameset))
- (offset (nameset-offset nameset)))
- (if (<= index offset)
- (call-with-values (lambda ()
- (block-value-ref block (- offset index)))
- (lambda (val ...)
- (values (block-key-ref block (- offset index)) val ...)))
- (loop (- index offset 1) (nameset-tail nameset))))))
-
- (define* (nameset-lookup nameset name #:optional max-depth)
- "Return the index at which NAME is found, or #f if NAME is not present
-in NAMESET."
- (let lookup ((nameset nameset) (pos 0))
- (let* ((max-offset (nameset-offset nameset))
- (block (nameset-block nameset))
- (size (block-size block)))
- (and (> size 0)
- (let visit-link ((offset (block-hash-bucket-ref block size
- (hashv name
size))))
- (cond
- ((and max-depth (>= (+ pos (- max-offset offset)) max-depth))
- #f)
- ((< offset 0)
- (lookup (nameset-tail nameset) (+ pos (1+ max-offset))))
- ((and (<= offset max-offset)
- (eqv? name (block-key-ref block offset)))
- (+ pos (- max-offset offset)))
- (else
- (visit-link (block-link-ref block offset)))))))))
-
- (define-syntax-rule (tmp-id prefix id)
- (datum->syntax prefix
- (symbol-append (syntax->datum prefix)
- '-
- (syntax->datum id))))
-
- (define-syntax &t
- (lambda (x)
- (syntax-case x ()
- ((_ stem id) (tmp-id #'stem #'id)))))
-
- (define-syntax lambda&t
- (lambda (x)
- (syntax-case x ()
- ((_ stem (id (... ...)) body (... ...))
- (with-syntax (((t (... ...))
- (map (lambda (x) (tmp-id #'stem x))
- #'(id (... ...)))))
- #'(lambda (t (... ...)) body (... ...)))))))
-
- (define (nameset-has-entry? nameset name val ...)
- (cond
- ((nameset-lookup nameset name)
- => (lambda (idx)
- (call-with-values (lambda () (nameset-ref nameset idx))
- (lambda&t
- existing (name val ...)
- (and (eqv? val (&t existing val))
- ...)))))
- (else #f)))
-
- (define (nameset-length nameset)
- "Return the length of NAMESET."
- (let loop ((nameset nameset)
- (len 0))
- (if (eq? nameset nameset-null)
- len
- (loop (nameset-tail nameset)
- (+ len 1 (nameset-offset nameset))))))
-
- (define (nameset-add nameset name val ...)
- "Return a new nameset, with the additional association of NAME
-with VAL..."
- (define (next-nameset nameset)
- (let* ((block (nameset-block nameset))
- (offset (1+ (nameset-offset nameset)))
- (old-size (block-size block)))
- (cond
- ((and (< offset old-size)
- (= offset (block-next-free block)))
- ;; Fast path: Add the item directly to the block.
- (set-block-next-free! block (1+ offset))
- (values (make-nameset offset (nameset-head nameset))
- block
- offset))
- (else
- ;; Slow path: Allocate a new block.
- (let* ((new-size (cond ((zero? old-size) 1)
- ((< offset old-size) 1) ;; new head
- (else (* 2 old-size))))
- (block (make-block new-size)))
- (set-block-next-free! block 1)
- (values (make-nameset 0 (make-nameset-head block nameset))
- block
- 0))))))
-
- (call-with-values (lambda () (next-nameset nameset))
- (lambda (nameset block offset)
- (block-entry-init! block offset name val ...)
- nameset)))
-
- (define (nameset-adjoin nameset name val ...)
- "Like nameset-add, but doesn't add a new association if one exists
-already."
- (if (nameset-has-entry? nameset name val ...)
- nameset
- (nameset-add nameset name val ...)))
-
- (define (nameset-shared-tail a b)
- (let lp ((a-offset (nameset-offset a))
- (a-head (nameset-head a))
- (a-len (nameset-length a))
- (b-offset (nameset-offset b))
- (b-head (nameset-head b))
- (b-len (nameset-length b)))
- (cond
- ((< b-len a-len)
- ;; Ensure A is the shorter list.
- (lp b-offset b-head b-len
- a-offset a-head a-len))
- ((< a-len b-len)
- ;; Traverse B until it is not the longer list.
- (if (< (- b-len a-len) (1+ b-offset))
- (lp a-offset a-head a-len
- (- b-offset (- b-len a-len)) b-head a-len)
- (let ((b (nameset-head-tail b-head)))
- (lp a-offset a-head a-len
- (nameset-offset b)
- (nameset-head b)
- (- b-len (1+ b-offset))))))
- ((< b-offset a-offset)
- ;; Ensure A is the list with the least block offset.
- (lp b-offset b-head b-len
- a-offset a-head a-len))
- ((not (eq? (nameset-head-block a-head) (nameset-head-block b-head)))
- ;; Lists are of equal length but don't have the same block --
- ;; their offsets must differ, and A must have the smaller offset.
- (let ((a (nameset-head-tail a-head)))
- (lp (nameset-offset a)
- (nameset-head a)
- (- a-len (1+ a-offset))
- (- b-offset (1+ a-offset))
- b-head
- (- b-len (1+ a-offset)))))
- (else
- ;; Lists are of equal length and have the same block, and thus
- ;; must have the same offset -- they are the same. We found
- ;; the shared tail. Try to preserve eq? identity if possible.
- (cond
- ((and (eqv? (nameset-offset a) a-offset)
- (eq? (nameset-head a) a-head))
- a)
- ((and (eqv? (nameset-offset b) a-offset)
- (eq? (nameset-head b) a-head))
- b)
- (else
- (make-nameset a-offset a-head)))))))
-
- (define* (nameset-meet base new old adjoin)
- (let* ((len (nameset-length base))
- (new-len (- (nameset-length new)
- (nameset-length (nameset-shared-tail new old)))))
- (let lp ((offset (nameset-offset new))
- (block (nameset-block new))
- (tail (nameset-tail new))
- (visited 0)
- (base base)
- (added 0))
- (cond
- ((= visited new-len)
- ;; Done with adjoining new entries.
- base)
- ((< offset 0)
- ;; Reached the end of the current block; keep going with
- ;; the next one.
- (lp (nameset-offset tail)
- (nameset-block tail)
- (nameset-tail tail)
- visited
- base
- added))
- (else
- (let ((name (block-key-ref block offset)))
- (define (recur base*)
- (lp (1- offset) block tail (1+ visited)
- base* (if (eq? base base*) added (1+ added))))
-
- (cond
- ((nameset-lookup new name visited)
- ;; This name is shadowed by a more shallow entry.
- (recur base))
- ;; Otherwise meet the entry in A with the entry in B.
- (else
- (call-with-values
- (lambda ()
- (block-value-ref block offset))
- (lambda (val ...)
- (recur (adjoin base name val ...))))))))))))
-
- (values nameset-null
- nameset-lookup
- nameset-ref
- nameset-has-entry?
- nameset-length
- nameset-add
- nameset-meet)))
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 2b4acd2..0bd2812 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -70,13 +70,8 @@
;;; A naive approach to type analysis would build up a table that has
;;; entries for all variables at all program points, but this has
;;; N-squared complexity and quickly grows unmanageable. Instead, we
-;;; use _namesets_ from (language cps nameset) to share state between
-;;; connected program points. All namesets in a type analysis share a
-;;; tail at some depth, which allows efficient computation of the
-;;; differences between types at two different program points. The
-;;; shared tail corresponds to the types that flow into an expression's
-;;; dominator. This approach also allows easy detection of when a
-;;; fixed-point has been reached.
+;;; use _intmaps_ from (language cps intmap) to share state between
+;;; connected program points.
;;;
;;; Code:
@@ -84,7 +79,7 @@
#:use-module (ice-9 match)
#:use-module (language cps)
#:use-module (language cps dfg)
- #:use-module (language cps nameset)
+ #:use-module (language cps intmap)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
@@ -191,23 +186,105 @@
((a b c) (max (max a b) c))
((a b c d) (max (max a b) c d))))
+
+
+(define-syntax-rule (define-compile-time-value name val)
+ (define-syntax name
+ (make-variable-transformer
+ (lambda (x)
+ (syntax-case x (set!)
+ (var (identifier? #'var)
+ (datum->syntax #'var val)))))))
+
+(define-compile-time-value min-fixnum most-negative-fixnum)
+(define-compile-time-value max-fixnum most-positive-fixnum)
+
+(define-inlinable (make-unclamped-type-entry type min max)
+ (vector type min max))
+(define-inlinable (type-entry-type tentry)
+ (vector-ref tentry 0))
+(define-inlinable (type-entry-clamped-min tentry)
+ (vector-ref tentry 1))
+(define-inlinable (type-entry-clamped-max tentry)
+ (vector-ref tentry 2))
+
+(define-syntax-rule (clamp-range val)
+ (cond
+ ((< val min-fixnum) min-fixnum)
+ ((< max-fixnum val) max-fixnum)
+ (else val)))
+
+(define-inlinable (make-type-entry type min max)
+ (vector type (clamp-range min) (clamp-range max)))
+(define-inlinable (type-entry-min tentry)
+ (let ((min (type-entry-clamped-min tentry)))
+ (if (eq? min min-fixnum) -inf.0 min)))
+(define-inlinable (type-entry-max tentry)
+ (let ((max (type-entry-clamped-max tentry)))
+ (if (eq? max max-fixnum) +inf.0 max)))
+
+(define all-types-entry (make-type-entry &all-types -inf.0 +inf.0))
+
+(define* (var-type-entry typeset var #:optional (default all-types-entry))
+ (or (intmap-ref typeset var) default))
+
+(define (var-type typeset var)
+ (type-entry-type (var-type-entry typeset var)))
+(define (var-min typeset var)
+ (type-entry-min (var-type-entry typeset var)))
+(define (var-max typeset var)
+ (type-entry-max (var-type-entry typeset var)))
+
+;; Is the type entry A contained entirely within B?
+(define (type-entry<=? a b)
+ (match (cons a b)
+ ((#(a-type a-min a-max) . #(b-type b-min b-max))
+ (and (eqv? b-type (logior a-type b-type))
+ (<= b-min a-min)
+ (>= b-max a-max)))))
+
+(define (type-entry-union a b)
+ (cond
+ ((type-entry<=? b a) a)
+ ((type-entry<=? a b) b)
+ (else (make-type-entry
+ (logior (type-entry-type a) (type-entry-type b))
+ (min (type-entry-clamped-min a) (type-entry-clamped-min b))
+ (max (type-entry-clamped-max a) (type-entry-clamped-max b))))))
+
+(define (type-entry-intersection a b)
+ (cond
+ ((type-entry<=? a b) a)
+ ((type-entry<=? b a) b)
+ (else (make-type-entry
+ (logand (type-entry-type a) (type-entry-type b))
+ (max (type-entry-clamped-min a) (type-entry-clamped-min b))
+ (min (type-entry-clamped-max a) (type-entry-clamped-max b))))))
+
+(define (adjoin-var typeset var entry)
+ (intmap-add typeset var entry type-entry-union))
+
+(define (restrict-var typeset var entry)
+ (intmap-add typeset var entry type-entry-intersection))
+
(define (constant-type val)
"Compute the type and range of VAL. Return three values: the type,
minimum, and maximum."
(define (return type val)
(if val
- (values type val val)
- (values type -inf.0 +inf.0)))
+ (make-type-entry type val val)
+ (make-type-entry type -inf.0 +inf.0)))
(cond
((number? val)
(cond
((exact-integer? val) (return &exact-integer val))
((eqv? (imag-part val) 0)
(if (nan? val)
- (values &flonum -inf.0 +inf.0)
- (values (if (exact? val) &fraction &flonum)
- (if (rational? val) (inexact->exact (floor val)) val)
- (if (rational? val) (inexact->exact (ceiling val)) val))))
+ (make-type-entry &flonum -inf.0 +inf.0)
+ (make-type-entry
+ (if (exact? val) &fraction &flonum)
+ (if (rational? val) (inexact->exact (floor val)) val)
+ (if (rational? val) (inexact->exact (ceiling val)) val))))
(else (return &complex #f))))
((eq? val '()) (return &null #f))
((eq? val #nil) (return &nil #f))
@@ -226,92 +303,6 @@ minimum, and maximum."
(else (error "unhandled constant" val))))
-
-
-;;; Types are represented as a nameset that maps variable index to type,
-;;; minimum, and maximum values. See (language cps nameset) for more
-;;; details on namesets.
-
-(define-nameset-type (typeset type min max #:size 12)
- ;; unt32 type * int32 min * int32 max
- (lambda (bv pos)
- (let ((type (bytevector-u32-native-ref bv pos))
- (min (bytevector-s32-native-ref bv (+ pos 4)))
- (max (bytevector-s32-native-ref bv (+ pos 8))))
- (values type min max)))
- (lambda (bv pos type min max)
- (bytevector-u32-native-set! bv pos type)
- (bytevector-s32-native-set! bv (+ pos 4) min)
- (bytevector-s32-native-set! bv (+ pos 8) max))
- (lambda (type1 min1 max1 type2 min2 max2)
- (values (logior type1 type2)
- (min min1 min2)
- (max max1 max2))))
-
-
-
-
-(define* (var-type-and-clamped-range typeset var #:optional
- (default (lambda ()
- (values &all-types
- *min-s32*
- *max-s32*))))
- (let ((pos (typeset-lookup typeset var)))
- (if pos
- (call-with-values (lambda () (typeset-ref typeset pos))
- (lambda (name type min max)
- (values type min max)))
- (default))))
-
-(define (var-type typeset var)
- (let-values (((type min max) (var-type-and-clamped-range typeset var)))
- type))
-(define (var-min typeset var)
- (let-values (((type min max) (var-type-and-clamped-range typeset var)))
- (if (= min *min-s32*) -inf.0 min)))
-(define (var-max typeset var)
- (let-values (((type min max) (var-type-and-clamped-range typeset var)))
- (if (= max *max-s32*) +inf.0 max)))
-
-(define (var-type-and-range typeset var)
- (let-values (((type min max) (var-type-and-clamped-range typeset var)))
- (values type
- (if (= min *min-s32*) -inf.0 min)
- (if (= max *max-s32*) +inf.0 max))))
-
-(define-syntax-rule (clamp-range val)
- (cond
- ((< val *min-s32*) *min-s32*)
- ((< *max-s32* val) *max-s32*)
- (else val)))
-
-(define (adjoin-var/clamped typeset var type min max)
- ;(pk 'adjoin/clamped var type min max)
- (match (typeset-lookup typeset var)
- (#f (typeset-add typeset var type min max))
- (pos
- (let-values (((_ type* min* max*) (typeset-ref typeset pos)))
- (let ((type (logior type type*))
- (min (if (< min min*) min min*))
- (max (if (> max max*) max max*)))
- (if (and (eqv? type type*) (eqv? min min*) (eqv? max max*))
- typeset
- (typeset-add typeset var type min max)))))))
-(define (adjoin-var typeset var type min max)
- (adjoin-var/clamped typeset var type (clamp-range min) (clamp-range max)))
-
-(define (restrict-var/clamped typeset var type min max)
- (let-values (((type* min* max*) (var-type-and-clamped-range typeset var)))
- (let ((type (logand type type*))
- (min (if (> min min*) min min*))
- (max (if (< max max*) max max*)))
- (if (and (eqv? type type*) (eqv? min min*) (eqv? max max*))
- typeset
- (typeset-add typeset var type min max)))))
-(define (restrict-var typeset var type min max)
- ;(pk 'restrict var type min max)
- (restrict-var/clamped typeset var type (clamp-range min) (clamp-range max)))
-
(define *type-checkers* (make-hash-table))
(define *type-inferrers* (make-hash-table))
@@ -355,11 +346,13 @@ minimum, and maximum."
((define!
(syntax-rules ()
((_ val type min max)
- (set! out (adjoin-var out val type min max)))))
+ (set! out (adjoin-var out val
+ (make-type-entry type min max))))))
(restrict!
(syntax-rules ()
((_ val type min max)
- (set! out (restrict-var out val type min max)))))
+ (set! out (restrict-var out val
+ (make-type-entry type min max))))))
(&type (syntax-rules () ((_ val) (var-type in val))))
(&min (syntax-rules () ((_ val) (var-min in val))))
(&max (syntax-rules () ((_ val) (var-max in val)))))
@@ -1119,13 +1112,13 @@ mapping symbols to types."
;; Initial state: nothing flows into the $kfun.
(let ((entry (get-entry min-label)))
- (update-in-types! entry typeset-null)))
+ (update-in-types! entry empty-intmap)))
- (define (adjoin-vars types vars type min max)
+ (define (adjoin-vars types vars entry)
(match vars
(() types)
((var . vars)
- (adjoin-vars (adjoin-var types var type min max) vars type min max))))
+ (adjoin-vars (adjoin-var types var entry) vars entry))))
(define (infer-primcall types succ name args result)
(cond
@@ -1138,10 +1131,35 @@ mapping symbols to types."
(append args (list result))
args))))
(result
- (adjoin-var types result &all-types -inf.0 +inf.0))
+ (adjoin-var types result all-types-entry))
(else
types)))
+ (define (type-entry-saturating-union a b)
+ (cond
+ ((type-entry<=? b a) a)
+ #;
+ ((and (not saturate-ranges?)
+ (eqv? (a-type ))
+ (type-entry<=? a b)) b)
+ (else (make-type-entry
+ (let* ((a-type (type-entry-type a))
+ (b-type (type-entry-type b))
+ (type (logior a-type b-type)))
+ (unless (eqv? a-type type)
+ (set! types-changed? #t))
+ type)
+ (let ((a-min (type-entry-clamped-min a))
+ (b-min (type-entry-clamped-min b)))
+ (if (< b-min a-min)
+ (if saturate-ranges? min-fixnum b-min)
+ a-min))
+ (let ((a-max (type-entry-clamped-max a))
+ (b-max (type-entry-clamped-max b)))
+ (if (> b-max a-max)
+ (if saturate-ranges? max-fixnum b-max)
+ a-max))))))
+
(define (propagate-types! pred-label pred-entry succ-idx succ-label out)
;; Update "in" set of continuation.
(let ((succ-entry (get-entry succ-label)))
@@ -1154,61 +1172,20 @@ mapping symbols to types."
(let* ((succ-dom-label (vector-ref idoms (label->idx succ-label)))
(succ-dom-entry (get-entry succ-dom-label))
(old-in (in-types succ-entry))
- (base (or old-in (in-types succ-dom-entry)))
- (tail (or (out-types pred-entry succ-idx)
- (in-types succ-dom-entry))))
- (define (name-dominates? name)
- (let ((d (lookup-def name dfg)))
- (or (= d succ-label)
- ;; If D is less than min-label, it is a closure
- ;; variable and thus dominates the whole function.
- ;; However it may not have a definition on the
- ;; base; in that case the adjoin will do nothing.
- (<= d succ-dom-label))))
- (define (adjoin base name type min max)
- (if (name-dominates? name)
- (call-with-values
- (lambda ()
- (var-type-and-clamped-range
- base
- name
- (if (< (lookup-def name dfg) min-label)
- ;; A free variable with no restrictions.
- (lambda ()
- (values &all-types *min-s32* *max-s32*))
- ;; The first def'n of a loop variable.
- (lambda ()
- (values &no-type *max-s32* *min-s32*)))))
- (lambda (type* min* max*)
- (if (and (eqv? type* (logior type type*))
- (<= min* min) (>= max* max))
- base
- (let ((type (logior type type*))
- (min (if (< min min*)
- (if saturate-ranges? *min-s32* min)
- min*))
- (max (if (> max max*)
- (if saturate-ranges? *max-s32* max)
- max*)))
- (unless (eqv? type type*)
- (when (<= succ-label pred-label)
- ;(pk 'types-changed name type type*)
- (set! types-changed? #t)))
- (typeset-add base name type min max)))))
- base))
- (unless base (error "what!"))
- (unless tail (error "what2!"))
- (let ((in (typeset-meet base out tail adjoin)))
- ;; If the "in" set changed, update the entry and possibly
- ;; arrange to iterate again.
- (unless (eq? old-in in)
- (update-in-types! succ-entry in)
- ;; If the changed successor is a back-edge, ensure that
- ;; we revisit the function.
- (when (<= succ-label pred-label)
- (unless (and revisit-label (< revisit-label succ-label))
- ;(pk 'marking-revisit pred-label succ-label)
- (set! revisit-label succ-label)))))))))
+ (in (if old-in
+ (intmap-intersect old-in out
+ type-entry-saturating-union)
+ out)))
+ ;; If the "in" set changed, update the entry and possibly
+ ;; arrange to iterate again.
+ (unless (eq? old-in in)
+ (update-in-types! succ-entry in)
+ ;; If the changed successor is a back-edge, ensure that
+ ;; we revisit the function.
+ (when (<= succ-label pred-label)
+ (unless (and revisit-label (<= revisit-label succ-label))
+ ;; (pk 'marking-revisit pred-label succ-label)
+ (set! revisit-label succ-label))))))))
;; Finally update "out" set for current expression.
(update-out-types! pred-entry succ-idx out))
@@ -1219,7 +1196,10 @@ mapping symbols to types."
(match exp
(($ $branch kt ($ $values (arg)))
;; The "normal" continuation is the #f branch.
- (let ((types (restrict-var types arg (logior &boolean &nil) 0 0)))
+ (let ((types (restrict-var types arg
+ (make-type-entry (logior &boolean &nil)
+ 0
+ 0))))
(propagate! 0 k types))
;; No additional information on the #t branch,
;; as there's no way currently to remove #f
@@ -1255,30 +1235,23 @@ mapping symbols to types."
(propagate! 0 k out))
(((def . defs) . (arg . args))
(lp defs args
- (call-with-values
- (lambda ()
- (var-type-and-clamped-range in arg))
- (lambda (type min max)
- (adjoin-var/clamped out def
- type min max)))))))))
+ (adjoin-var out def (var-type-entry in arg))))))))
(_
(propagate! 0 k types))))
((or ($ $call) ($ $callk))
(propagate! 0 k types))
(_
- (let-values (((type min max)
- (match exp
- (($ $void)
- (values &unspecified -inf.0 +inf.0))
- (($ $const val)
- (constant-type val))
- ((or ($ $prim) ($ $fun) ($ $closure))
- ;; Could be more precise here.
- (values &procedure -inf.0 +inf.0)))))
- (match (lookup-cont k dfg)
- (($ $kargs (_) (var))
- (let ((types (adjoin-var types var type min max)))
- (propagate! 0 k types))))))))
+ (match (lookup-cont k dfg)
+ (($ $kargs (_) (var))
+ (let ((entry (match exp
+ (($ $void)
+ (make-type-entry &unspecified -inf.0 +inf.0))
+ (($ $const val)
+ (constant-type val))
+ ((or ($ $prim) ($ $fun) ($ $closure))
+ ;; Could be more precise here.
+ (make-type-entry &procedure -inf.0 +inf.0)))))
+ (propagate! 0 k (adjoin-var types var entry))))))))
(prepare-initial-state!)
@@ -1301,7 +1274,8 @@ mapping symbols to types."
(($ $letrec names vars funs term)
(visit-term term
(adjoin-vars types vars
- &procedure -inf.0 +inf.0)))
+ (make-type-entry &procedure
+ -inf.0 +inf.0))))
(($ $letk conts term)
(visit-term term types))
(($ $continue k src exp)
@@ -1310,19 +1284,16 @@ mapping symbols to types."
(match (lookup-cont k dfg)
(($ $kargs names vars)
(propagate! 0 k
- (adjoin-vars types vars
- &all-types -inf.0 +inf.0)))))
+ (adjoin-vars types vars all-types-entry)))))
(($ $kfun src meta self tail clause)
- (let ((types (adjoin-var types self
- &all-types -inf.0 +inf.0)))
+ (let ((types (adjoin-var types self all-types-entry)))
(match clause
(#f #f)
(($ $cont kclause)
(propagate! 0 kclause types)))))
(($ $kclause arity ($ $cont kbody ($ $kargs names vars)) alt)
(propagate! 0 kbody
- (adjoin-vars types vars
- &all-types -inf.0 +inf.0))
+ (adjoin-vars types vars all-types-entry))
(match alt
(#f #f)
(($ $cont kclause)
@@ -1368,14 +1339,20 @@ mapping symbols to types."
(define (lookup-pre-type analysis label def)
(match analysis
(($ <type-analysis> min-label label-count typev)
- (let ((entry (vector-ref typev (- label min-label))))
- (var-type-and-range (vector-ref entry 0) def)))))
+ (let* ((entry (vector-ref typev (- label min-label)))
+ (tentry (var-type-entry (vector-ref entry 0) def)))
+ (values (type-entry-type tentry)
+ (type-entry-min tentry)
+ (type-entry-max tentry))))))
(define (lookup-post-type analysis label def succ-idx)
(match analysis
(($ <type-analysis> min-label label-count typev)
- (let ((entry (vector-ref typev (- label min-label))))
- (var-type-and-range (vector-ref entry (1+ succ-idx)) def)))))
+ (let* ((entry (vector-ref typev (- label min-label)))
+ (tentry (var-type-entry (vector-ref entry (1+ succ-idx)) def)))
+ (values (type-entry-type tentry)
+ (type-entry-min tentry)
+ (type-entry-max tentry))))))
(define (primcall-types-check? analysis label name args)
(match (hashq-ref *type-checkers* name)
diff --git a/test-suite/tests/bitvectors.test b/test-suite/tests/bitvectors.test
index 8541576..d9dfa13 100644
--- a/test-suite/tests/bitvectors.test
+++ b/test-suite/tests/bitvectors.test
@@ -70,3 +70,7 @@
(let ((v (bitvector #t #t #f #f)))
(bit-set*! v #*101 #f)
(equal? v #*0100))))
+
+(with-test-prefix "bit-count*"
+ (pass-if-equal 3 (bit-count* #*01110111 #*11001101 #t))
+ (pass-if-equal 2 (bit-count* #*01110111 #u32(7 0 4) #f)))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-54-g2c02a21,
Andy Wingo <=