[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-48-gec412d7
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-48-gec412d7 |
|
Date: |
Sun, 22 Jun 2014 10:20:01 +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=ec412d75627aeffbd816ac351eabcd1b533540c6
The branch, master has been updated
via ec412d75627aeffbd816ac351eabcd1b533540c6 (commit)
via 97ed2e77ab22e1695c5c4df6f5f6cfd98b90636f (commit)
via 38c7bd0e774e663699504f7007b72ac494bb2606 (commit)
via 803a1ee7c7abf6b87c875756fe44ef96fcb0512f (commit)
from fab18c02e88ba48217182b11d93b8bdc7c09ca48 (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 ec412d75627aeffbd816ac351eabcd1b533540c6
Author: Andy Wingo <address@hidden>
Date: Thu Jun 19 08:49:05 2014 +0200
Rewrite type inference pass to use namesets
* module/Makefile.am: Build types.scm early, but don't block the rest of
the build on it.
* module/language/cps/types.scm: Rewrite to use namesets.
* module/language/cps/dce.scm:
* module/language/cps/type-fold.scm: Adapt to interface changes.
commit 97ed2e77ab22e1695c5c4df6f5f6cfd98b90636f
Author: Andy Wingo <address@hidden>
Date: Sun Jun 8 18:50:07 2014 +0200
New module: (language cps nameset)
* module/language/cps/nameset.scm: New file.
* module/Makefile.am: Add new file.
commit 38c7bd0e774e663699504f7007b72ac494bb2606
Author: Andy Wingo <address@hidden>
Date: Sun Jun 15 22:02:29 2014 +0200
Refactor dominator computation
* module/language/cps/cse.scm:
* module/language/cps/dfg.scm (compute-idoms, compute-dom-edges): Move
these procedures from cse.scm to dfg.scm.
Remove loop-detection code; that can come back later but it is
bitrotten for now.
commit 803a1ee7c7abf6b87c875756fe44ef96fcb0512f
Author: Andy Wingo <address@hidden>
Date: Sun Jun 8 14:46:18 2014 +0200
Constant folding for (list) and (vector) in peval
* module/language/tree-il/peval.scm (peval): Add cases for (list) -> '()
and (vector) -> #().
-----------------------------------------------------------------------
Summary of changes:
module/Makefile.am | 8 +-
module/language/cps/cse.scm | 60 ---
module/language/cps/dce.scm | 9 +-
module/language/cps/dfg.scm | 225 ++--------
module/language/cps/nameset.scm | 396 ++++++++++++++++
module/language/cps/type-fold.scm | 39 +-
module/language/cps/types.scm | 914 +++++++++++++++++--------------------
module/language/tree-il/peval.scm | 4 +
8 files changed, 885 insertions(+), 770 deletions(-)
create mode 100644 module/language/cps/nameset.scm
diff --git a/module/Makefile.am b/module/Makefile.am
index a4fd0ed..4ca70c2 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -27,10 +27,8 @@ modpath =
# Build eval.go first. Then build psyntax-pp.go, as the expander has to
# run on every loaded scheme file. It doesn't pay off at compile-time
-# to interpret the expander in parallel. At the same time build
-# language/cps/types.go -- it has a particularly bad memory overhead
-# when run interpreted, and it makes sense to compile it first.
-BOOT_SOURCES = ice-9/psyntax-pp.scm language/cps/types.go
+# to interpret the expander in parallel.
+BOOT_SOURCES = ice-9/psyntax-pp.scm
BOOT_GOBJECTS = $(BOOT_SOURCES:%.scm=%.go)
$(BOOT_GOBJECTS): ice-9/eval.go
$(GOBJECTS): $(BOOT_GOBJECTS)
@@ -51,6 +49,7 @@ ice-9/match.go: ice-9/match.scm ice-9/match.upstream.scm
SOURCES = \
ice-9/boot-9.scm \
language/tree-il/peval.scm \
+ language/cps/types.scm \
system/vm/elf.scm \
ice-9/vlist.scm \
srfi/srfi-1.scm \
@@ -132,6 +131,7 @@ CPS_LANG_SOURCES =
\
language/cps/dfg.scm \
language/cps/effects-analysis.scm \
language/cps/elide-values.scm \
+ language/cps/nameset.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 64dab7f..2f4f432 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -248,68 +248,8 @@ be that both true and false proofs are available."
(values min-label label-count min-var var-count)))))
fun kfun 0 self 0))))
-(define (compute-idoms dfg min-label label-count)
- (define (label->idx label) (- label min-label))
- (define (idx->label idx) (+ idx min-label))
- (let ((idoms (make-vector label-count #f)))
- (define (common-idom d0 d1)
- ;; We exploit the fact that a reverse post-order is a topological
- ;; sort, and so the idom of a node is always numerically less than
- ;; the node itself.
- (cond
- ((= d0 d1) d0)
- ((< d0 d1) (common-idom d0 (vector-ref idoms (label->idx d1))))
- (else (common-idom (vector-ref idoms (label->idx d0)) d1))))
- (define (compute-idom preds)
- (define (has-idom? pred)
- (vector-ref idoms (label->idx pred)))
- (match preds
- (() min-label)
- ((pred . preds)
- (if (has-idom? pred)
- (let lp ((idom pred) (preds preds))
- (match preds
- (() idom)
- ((pred . preds)
- (lp (if (has-idom? pred)
- (common-idom idom pred)
- idom)
- preds))))
- (compute-idom preds)))))
- ;; This is the iterative O(n^2) fixpoint algorithm, originally from
- ;; Allen and Cocke ("Graph-theoretic constructs for program flow
- ;; analysis", 1972). See the discussion in Cooper, Harvey, and
- ;; Kennedy's "A Simple, Fast Dominance Algorithm", 2001.
- (let iterate ((n 0) (changed? #f))
- (cond
- ((< n label-count)
- (let ((idom (vector-ref idoms n))
- (idom* (compute-idom (lookup-predecessors (idx->label n) dfg))))
- (cond
- ((eqv? idom idom*)
- (iterate (1+ n) changed?))
- (else
- (vector-set! idoms n idom*)
- (iterate (1+ n) #t)))))
- (changed?
- (iterate 0 #f))
- (else idoms)))))
-
;; Compute a vector containing, for each node, a list of the nodes that
;; it immediately dominates. These are the "D" edges in the DJ tree.
-(define (compute-dom-edges idoms min-label)
- (define (label->idx label) (- label min-label))
- (define (idx->label idx) (+ idx min-label))
- (define (vector-push! vec idx val)
- (let ((v vec) (i idx))
- (vector-set! v i (cons val (vector-ref v i)))))
- (let ((doms (make-vector (vector-length idoms) '())))
- (let lp ((n 0))
- (when (< n (vector-length idoms))
- (let ((idom (vector-ref idoms n)))
- (vector-push! doms (label->idx idom) (idx->label n)))
- (lp (1+ n))))
- doms))
(define (compute-equivalent-subexpressions fun dfg)
(define (compute min-label label-count min-var var-count avail effects)
diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm
index fbfd2f3..2f34c38 100644
--- a/module/language/cps/dce.scm
+++ b/module/language/cps/dce.scm
@@ -87,12 +87,9 @@
(define (idx->label idx) (+ idx min-label))
(define (var->idx var) (- var min-var))
(define (visit-primcall lidx fx name args)
- (let ((args (map var->idx args)))
- ;; Negative args are closure variables.
- (unless (or-map negative? args)
- (when (primcall-types-check? lidx typev name args)
- (vector-set! effects lidx
- (logand fx (lognot &type-check)))))))
+ (when (primcall-types-check? typev (idx->label lidx) name args)
+ (vector-set! effects lidx
+ (logand fx (lognot &type-check)))))
(let lp ((lidx 0))
(when (< lidx label-count)
(let ((fx (vector-ref effects lidx)))
diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
index 593d02c..6f18075 100644
--- a/module/language/cps/dfg.scm
+++ b/module/language/cps/dfg.scm
@@ -67,6 +67,9 @@
control-point?
lookup-bound-syms
+ compute-idoms
+ compute-dom-edges
+
;; Data flow analysis.
compute-live-variables
dfa-k-idx dfa-k-sym dfa-k-count dfa-k-in dfa-k-out
@@ -337,56 +340,36 @@ body continuation in the prompt."
(values k-map succs)))))
-;; Dominator analysis.
-(define-record-type $dominator-analysis
- (make-dominator-analysis min-label idoms dom-levels loop-header irreducible)
- dominator-analysis?
- ;; Label corresponding to first entry in idoms, dom-levels, etc
- (min-label dominator-analysis-min-label)
- ;; Vector of k-idx -> k-idx
- (idoms dominator-analysis-idoms)
- ;; Vector of k-idx -> dom-level
- (dom-levels dominator-analysis-dom-levels)
- ;; Vector of k-idx -> k-idx or -1
- (loop-header dominator-analysis-loop-header)
- ;; Vector of k-idx -> true or false value
- (irreducible dominator-analysis-irreducible))
-
-(define (compute-dom-levels idoms)
- (let ((dom-levels (make-vector (vector-length idoms) #f)))
- (define (compute-dom-level n)
- (or (vector-ref dom-levels n)
- (let ((dom-level (1+ (compute-dom-level (vector-ref idoms n)))))
- (vector-set! dom-levels n dom-level)
- dom-level)))
- (vector-set! dom-levels 0 0)
- (let lp ((n 0))
- (when (< n (vector-length idoms))
- (compute-dom-level n)
- (lp (1+ n))))
- dom-levels))
-
-(define (compute-idoms preds min-label label-count)
+(define (compute-idoms dfg min-label label-count)
+ (define preds (dfg-preds dfg))
(define (label->idx label) (- label min-label))
(define (idx->label idx) (+ idx min-label))
- (let ((idoms (make-vector label-count 0)))
+ (define (idx->dfg-idx idx) (- (idx->label idx) (dfg-min-label dfg)))
+ (let ((idoms (make-vector label-count #f)))
(define (common-idom d0 d1)
;; We exploit the fact that a reverse post-order is a topological
;; sort, and so the idom of a node is always numerically less than
;; the node itself.
(cond
((= d0 d1) d0)
- ((< d0 d1) (common-idom d0 (vector-ref idoms d1)))
- (else (common-idom (vector-ref idoms d0) d1))))
+ ((< d0 d1) (common-idom d0 (vector-ref idoms (label->idx d1))))
+ (else (common-idom (vector-ref idoms (label->idx d0)) d1))))
(define (compute-idom preds)
+ (define (has-idom? pred)
+ (vector-ref idoms (label->idx pred)))
(match preds
- (() 0)
+ (() min-label)
((pred . preds)
- (let lp ((idom (label->idx pred)) (preds preds))
- (match preds
- (() idom)
- ((pred . preds)
- (lp (common-idom idom (label->idx pred)) preds)))))))
+ (if (has-idom? pred)
+ (let lp ((idom pred) (preds preds))
+ (match preds
+ (() idom)
+ ((pred . preds)
+ (lp (if (has-idom? pred)
+ (common-idom idom pred)
+ idom)
+ preds))))
+ (compute-idom preds)))))
;; This is the iterative O(n^2) fixpoint algorithm, originally from
;; Allen and Cocke ("Graph-theoretic constructs for program flow
;; analysis", 1972). See the discussion in Cooper, Harvey, and
@@ -395,7 +378,7 @@ body continuation in the prompt."
(cond
((< n label-count)
(let ((idom (vector-ref idoms n))
- (idom* (compute-idom (vector-ref preds (idx->label n)))))
+ (idom* (compute-idom (vector-ref preds (idx->dfg-idx n)))))
(cond
((eqv? idom idom*)
(iterate (1+ n) changed?))
@@ -408,168 +391,20 @@ body continuation in the prompt."
;; Compute a vector containing, for each node, a list of the nodes that
;; it immediately dominates. These are the "D" edges in the DJ tree.
-(define (compute-dom-edges idoms)
+(define (compute-dom-edges idoms min-label)
+ (define (label->idx label) (- label min-label))
+ (define (idx->label idx) (+ idx min-label))
(let ((doms (make-vector (vector-length idoms) '())))
(let lp ((n 0))
(when (< n (vector-length idoms))
(let ((idom (vector-ref idoms n)))
- (vector-push! doms idom n))
+ (vector-push! doms (label->idx idom) (idx->label n)))
(lp (1+ n))))
doms))
-;; Compute a vector containing, for each node, a list of the successors
-;; of that node that are not dominated by that node. These are the "J"
-;; edges in the DJ tree.
-(define (compute-join-edges preds min-label idoms)
- (define (dominates? n1 n2)
- (or (= n1 n2)
- (and (< n1 n2)
- (dominates? n1 (vector-ref idoms n2)))))
- (let ((joins (make-vector (vector-length idoms) '())))
- (let lp ((n 0))
- (when (< n (vector-length idoms))
- (for-each (lambda (pred)
- (let ((pred (- pred min-label)))
- (unless (dominates? pred n)
- (vector-push! joins pred n))))
- (vector-ref preds (+ n min-label)))
- (lp (1+ n))))
- joins))
-
-;; Compute a vector containing, for each node, a list of the back edges
-;; to that node. If a node is not the entry of a reducible loop, that
-;; list is empty.
-(define (compute-reducible-back-edges joins idoms)
- (define (dominates? n1 n2)
- (or (= n1 n2)
- (and (< n1 n2)
- (dominates? n1 (vector-ref idoms n2)))))
- (let ((back-edges (make-vector (vector-length idoms) '())))
- (let lp ((n 0))
- (when (< n (vector-length joins))
- (for-each (lambda (succ)
- (when (dominates? succ n)
- (vector-push! back-edges succ n)))
- (vector-ref joins n))
- (lp (1+ n))))
- back-edges))
-
-;; Compute the levels in the dominator tree at which there are
-;; irreducible loops, as an integer. If a bit N is set in the integer,
-;; that indicates that at level N in the dominator tree, there is at
-;; least one irreducible loop.
-(define (compute-irreducible-dom-levels doms joins idoms dom-levels)
- (define (dominates? n1 n2)
- (or (= n1 n2)
- (and (< n1 n2)
- (dominates? n1 (vector-ref idoms n2)))))
- (let ((pre-order (make-vector (vector-length doms) #f))
- (last-pre-order (make-vector (vector-length doms) #f))
- (res 0)
- (count 0))
- ;; Is MAYBE-PARENT an ancestor of N on the depth-first spanning tree
- ;; computed from the DJ graph? See Havlak 1997, "Nesting of
- ;; Reducible and Irreducible Loops".
- (define (ancestor? a b)
- (let ((w (vector-ref pre-order a))
- (v (vector-ref pre-order b)))
- (and (<= w v)
- (<= v (vector-ref last-pre-order w)))))
- ;; Compute depth-first spanning tree of DJ graph.
- (define (recurse n)
- (unless (vector-ref pre-order n)
- (visit n)))
- (define (visit n)
- ;; Pre-order visitation index.
- (vector-set! pre-order n count)
- (set! count (1+ count))
- (for-each recurse (vector-ref doms n))
- (for-each recurse (vector-ref joins n))
- ;; Pre-order visitation index of last descendant.
- (vector-set! last-pre-order (vector-ref pre-order n) (1- count)))
-
- (visit 0)
-
- (let lp ((n 0))
- (when (< n (vector-length joins))
- (for-each (lambda (succ)
- ;; If this join edge is not a loop back edge but it
- ;; does go to an ancestor on the DFST of the DJ
- ;; graph, then we have an irreducible loop.
- (when (and (not (dominates? succ n))
- (ancestor? succ n))
- (set! res (logior (ash 1 (vector-ref dom-levels
succ))))))
- (vector-ref joins n))
- (lp (1+ n))))
-
- res))
-
-(define (compute-nodes-by-level dom-levels)
- (let* ((max-level (let lp ((n 0) (max-level 0))
- (if (< n (vector-length dom-levels))
- (lp (1+ n) (max (vector-ref dom-levels n) max-level))
- max-level)))
- (nodes-by-level (make-vector (1+ max-level) '())))
- (let lp ((n (1- (vector-length dom-levels))))
- (when (>= n 0)
- (vector-push! nodes-by-level (vector-ref dom-levels n) n)
- (lp (1- n))))
- nodes-by-level))
-
-;; Collect all predecessors to the back-nodes that are strictly
-;; dominated by the loop header, and mark them as belonging to the loop.
-;; If they already have a loop header, that means they are either in a
-;; nested loop, or they have already been visited already.
-(define (mark-loop-body header back-nodes preds min-label idoms loop-headers)
- (define (strictly-dominates? n1 n2)
- (and (< n1 n2)
- (let ((idom (vector-ref idoms n2)))
- (or (= n1 idom)
- (strictly-dominates? n1 idom)))))
- (define (visit node)
- (when (strictly-dominates? header node)
- (cond
- ((vector-ref loop-headers node) => visit)
- (else
- (vector-set! loop-headers node header)
- (for-each (lambda (pred) (visit (- pred min-label)))
- (vector-ref preds (+ node min-label)))))))
- (for-each visit back-nodes))
-
-(define (mark-irreducible-loops level idoms dom-levels loop-headers)
- ;; FIXME: Identify strongly-connected components that are >= LEVEL in
- ;; the dominator tree, and somehow mark them as irreducible.
- (warn 'irreducible-loops-at-level level))
-
-;; "Identifying Loops Using DJ Graphs" by Sreedhar, Gao, and Lee, ACAPS
-;; Technical Memo 98, 1995.
-(define (identify-loops preds min-label idoms dom-levels)
- (let* ((doms (compute-dom-edges idoms))
- (joins (compute-join-edges preds min-label idoms))
- (back-edges (compute-reducible-back-edges joins idoms))
- (irreducible-levels
- (compute-irreducible-dom-levels doms joins idoms dom-levels))
- (loop-headers (make-vector (vector-length idoms) #f))
- (nodes-by-level (compute-nodes-by-level dom-levels)))
- (let lp ((level (1- (vector-length nodes-by-level))))
- (when (>= level 0)
- (for-each (lambda (n)
- (let ((edges (vector-ref back-edges n)))
- (unless (null? edges)
- (mark-loop-body n edges preds min-label
- idoms loop-headers))))
- (vector-ref nodes-by-level level))
- (when (logbit? level irreducible-levels)
- (mark-irreducible-loops level idoms dom-levels loop-headers))
- (lp (1- level))))
- loop-headers))
-
-(define (analyze-dominators dfg min-label label-count)
- (let* ((idoms (compute-idoms (dfg-preds dfg) min-label label-count))
- (dom-levels (compute-dom-levels idoms))
- (loop-headers (identify-loops (dfg-preds dfg) min-label idoms
dom-levels)))
- (make-dominator-analysis min-label idoms dom-levels loop-headers #f)))
-
+;; There used to be some loop detection code here, but it bitrotted.
+;; We'll need it again eventually but for now it can be found in the git
+;; history.
;; Compute the maximum fixed point of the data-flow constraint problem.
;;
diff --git a/module/language/cps/nameset.scm b/module/language/cps/nameset.scm
new file mode 100644
index 0000000..823da61
--- /dev/null
+++ b/module/language/cps/nameset.scm
@@ -0,0 +1,396 @@
+;;; 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/type-fold.scm
b/module/language/cps/type-fold.scm
index b644fd0..3dc2155 100644
--- a/module/language/cps/type-fold.scm
+++ b/module/language/cps/type-fold.scm
@@ -134,22 +134,24 @@
((eqv? type &nil) #nil)
((eqv? type &null) '())
(else (error "unhandled type" type val))))
- (let* ((typev (infer-types fun dfg #:max-label-count 3000))
- (folded? (and typev
- (make-bitvector (/ (vector-length typev) 2) #f)))
- (folded-values (and typev
- (make-vector (bitvector-length folded?) #f))))
+ (let* ((typev (infer-types fun dfg))
+ (label-count ((make-local-cont-folder label-count)
+ (lambda (k cont label-count) (1+ label-count))
+ fun 0))
+ (folded? (make-bitvector label-count #f))
+ (folded-values (make-vector label-count #f)))
(define (label->idx label) (- label min-label))
(define (var->idx var) (- var min-var))
- (define (maybe-fold-value! label name k def)
- (call-with-values (lambda () (lookup-post-type typev label def))
+ (define (maybe-fold-value! label name def)
+ (call-with-values (lambda () (lookup-post-type typev label def 0))
(lambda (type min max)
(when (and (not (zero? type))
(zero? (logand type (1- type)))
(zero? (logand type (lognot &scalar-types)))
(eqv? min max))
- (bitvector-set! folded? label #t)
- (vector-set! folded-values label (scalar-value type min))))))
+ (bitvector-set! folded? (label->idx label) #t)
+ (vector-set! folded-values (label->idx label)
+ (scalar-value type min))))))
(define (maybe-fold-unary-branch! label name arg)
(let* ((folder (hashq-ref *branch-folders* name)))
(when folder
@@ -157,8 +159,8 @@
(lambda (type min max)
(call-with-values (lambda () (folder type min max))
(lambda (f? v)
- (bitvector-set! folded? label f?)
- (vector-set! folded-values label v))))))))
+ (bitvector-set! folded? (label->idx label) f?)
+ (vector-set! folded-values (label->idx label) v))))))))
(define (maybe-fold-binary-branch! label name arg0 arg1)
(let* ((folder (hashq-ref *branch-folders* name)))
(when folder
@@ -169,8 +171,8 @@
(call-with-values (lambda ()
(folder type0 min0 max0 type1 min1 max1))
(lambda (f? v)
- (bitvector-set! folded? label f?)
- (vector-set! folded-values label v))))))))))
+ (bitvector-set! folded? (label->idx label) f?)
+ (vector-set! folded-values (label->idx label) v))))))))))
(define (visit-cont cont)
(match cont
(($ $cont label ($ $kargs _ _ body))
@@ -190,18 +192,17 @@
;; We might be able to fold primcalls that define a value.
(match (lookup-cont k dfg)
(($ $kargs (_) (def))
- (maybe-fold-value! (label->idx label) name (label->idx k)
- (var->idx def)))
+ ;(pk 'maybe-fold-value src name args)
+ (maybe-fold-value! label name def))
(_ #f)))
(($ $continue kf src ($ $branch kt ($ $primcall name args)))
;; We might be able to fold primcalls that branch.
+ ;(pk 'maybe-fold-branch label src name args)
(match args
((arg)
- (maybe-fold-unary-branch! (label->idx label) name
- (var->idx arg)))
+ (maybe-fold-unary-branch! label name arg))
((arg0 arg1)
- (maybe-fold-binary-branch! (label->idx label) name
- (var->idx arg0) (var->idx arg1)))))
+ (maybe-fold-binary-branch! label name arg0 arg1))))
(_ #f)))
(when typev
(match fun
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index e6689d6..2b4acd2 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -67,14 +67,16 @@
;;; to saturate that range towards positive or infinity (as
;;; appropriate).
;;;
-;;; We represent the set of types and ranges of value at a given
-;;; program point as a bytevector that is N * 12 bytes long, where N is
-;;; the number of variables. Each 12-byte value indicates the type,
-;;; minimum, and maximum of the value. This gives an overall time and
-;;; space complexity of the algorithm of O(label-count *
-;;; variable-count). Perhaps with a different representation for the
-;;; types we could decrease this, sharing space between typesets and
-;;; requiring fewer "meet" operations.
+;;; 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.
;;;
;;; Code:
@@ -82,7 +84,10 @@
#:use-module (ice-9 match)
#:use-module (language cps)
#:use-module (language cps dfg)
+ #:use-module (language cps nameset)
#:use-module (rnrs bytevectors)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-11)
#:export (;; Specific types.
&exact-integer
&flonum
@@ -198,9 +203,11 @@ minimum, and maximum."
(cond
((exact-integer? val) (return &exact-integer val))
((eqv? (imag-part val) 0)
- (values (if (exact? val) &fraction &flonum)
- (if (rational? val) (inexact->exact (floor val)) val)
- (if (rational? val) (inexact->exact (ceiling val)) val)))
+ (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))))
(else (return &complex #f))))
((eq? val '()) (return &null #f))
((eq? val #nil) (return &nil #f))
@@ -219,65 +226,94 @@ minimum, and maximum."
(else (error "unhandled constant" val))))
-(define-syntax-rule (var-type bv var)
- (bytevector-u32-native-ref bv (* var 12)))
-(define-syntax-rule (var-clamped-min bv var)
- (bytevector-s32-native-ref bv (+ (* var 12) 4)))
-(define-syntax-rule (var-clamped-max bv var)
- (bytevector-s32-native-ref bv (+ (* var 12) 8)))
-(define-syntax-rule (var-min bv var)
- (let ((min (var-clamped-min bv var)))
- (if (= min *min-s32*)
- -inf.0
- min)))
-(define-syntax-rule (var-max bv var)
- (let ((max (var-clamped-max bv var)))
- (if (= max *max-s32*)
- +inf.0
- max)))
-
-(define-inlinable (clamp-range 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-syntax-rule (set-var-type! bv var val)
- (bytevector-u32-native-set! bv (* var 12) val))
-(define-syntax-rule (set-var-clamped-min! bv var val)
- (bytevector-s32-native-set! bv (+ (* var 12) 4) val))
-(define-syntax-rule (set-var-clamped-max! bv var val)
- (bytevector-s32-native-set! bv (+ (* var 12) 8) val))
-(define-syntax-rule (set-var-min! bv var val)
- (set-var-clamped-min! bv var (clamp-range val)))
-(define-syntax-rule (set-var-max! bv var val)
- (set-var-clamped-max! bv var (clamp-range val)))
-
-(define-inlinable (extend-var-type! bv var type)
- (set-var-type! bv var (logior (var-type bv var) type)))
-(define-inlinable (restrict-var-type! bv var type)
- (set-var-type! bv var (logand (var-type bv var) type)))
-(define-inlinable (extend-var-range! bv var min max)
- (let ((old-min (var-clamped-min bv var))
- (old-max (var-clamped-max bv var))
- (min (clamp-range min))
- (max (clamp-range max)))
- (when (< min old-min)
- (set-var-clamped-min! bv var min))
- (when (< old-max max)
- (set-var-clamped-max! bv var max))))
-(define-inlinable (restrict-var-range! bv var min max)
- (let ((old-min (var-clamped-min bv var))
- (old-max (var-clamped-max bv var))
- (min (clamp-range min))
- (max (clamp-range max)))
- (when (< old-min min)
- (set-var-clamped-min! bv var min))
- (when (< max old-max)
- (set-var-clamped-max! bv var max))))
+
+(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))
-(define *predicate-inferrers* (make-hash-table))
(define-syntax-rule (define-type-helper name)
(define-syntax-parameter name
@@ -295,11 +331,11 @@ minimum, and maximum."
(hashq-set!
*type-checkers*
'name
- (lambda (in arg ...)
+ (lambda (typeset arg ...)
(syntax-parameterize
- ((&type (syntax-rules () ((_ val) (var-type in val))))
- (&min (syntax-rules () ((_ val) (var-min in val))))
- (&max (syntax-rules () ((_ val) (var-max in val)))))
+ ((&type (syntax-rules () ((_ val) (var-type typeset val))))
+ (&min (syntax-rules () ((_ val) (var-min typeset val))))
+ (&max (syntax-rules () ((_ val) (var-max typeset val)))))
body ...))))
(define-syntax-rule (check-type arg type min max)
@@ -309,55 +345,34 @@ minimum, and maximum."
(<= min (&min arg))
(<= (&max arg) max)))
-(define-syntax-rule (define-type-inferrer (name var ...) body ...)
+(define-syntax-rule (define-type-inferrer* (name succ var ...) body ...)
(hashq-set!
*type-inferrers*
'name
- (lambda (out var ...)
- (syntax-parameterize
- ((define!
- (syntax-rules ()
- ((_ val type min max)
- (begin
- (extend-var-type! out val type)
- (extend-var-range! out val min max)))))
- (restrict!
- (syntax-rules ()
- ((_ val type min max)
- (when (>= val 0)
- (restrict-var-type! out val type)
- (restrict-var-range! out val min max)))))
- ;; Negative vals are closure variables.
- (&type (syntax-rules ()
- ((_ val) (if (< val 0) &all-types (var-type out val)))))
- (&min (syntax-rules ()
- ((_ val) (if (< val 0) -inf.0 (var-min out val)))))
- (&max (syntax-rules ()
- ((_ val) (if (< val 0) +inf.0 (var-max out val))))))
- body ...
- (values)))))
-
-(define-syntax-rule (define-predicate-inferrer (name var ... true?) body ...)
- (hashq-set!
- *predicate-inferrers*
- 'name
- (lambda (out var ... true?)
- (syntax-parameterize
- ((restrict!
- (syntax-rules ()
- ((_ val type min max)
- (when (>= val 0)
- (restrict-var-type! out val type)
- (restrict-var-range! out val min max)))))
- ;; Negative vals are closure variables.
- (&type (syntax-rules ()
- ((_ val) (if (< val 0) &all-types (var-type out val)))))
- (&min (syntax-rules ()
- ((_ val) (if (< val 0) -inf.0 (var-min out val)))))
- (&max (syntax-rules ()
- ((_ val) (if (< val 0) +inf.0 (var-max out val))))))
- body ...
- (values)))))
+ (lambda (in succ var ...)
+ (let ((out in))
+ (syntax-parameterize
+ ((define!
+ (syntax-rules ()
+ ((_ val type min max)
+ (set! out (adjoin-var out val type min max)))))
+ (restrict!
+ (syntax-rules ()
+ ((_ val type min max)
+ (set! out (restrict-var out val 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)))))
+ body ...
+ out)))))
+
+(define-syntax-rule (define-type-inferrer (name arg ...) body ...)
+ (define-type-inferrer* (name succ arg ...) body ...))
+
+(define-syntax-rule (define-predicate-inferrer (name arg ... true?) body ...)
+ (define-type-inferrer* (name succ arg ...)
+ (let ((true? (not (zero? succ))))
+ body ...)))
(define-syntax define-simple-type-checker
(lambda (x)
@@ -470,7 +485,6 @@ minimum, and maximum."
(max (min (&max a) (&max b))))
(restrict! a type min max)
(restrict! b type min max))))
-;; FIXME!!!!!
(define-type-inferrer-aliases eq? eqv? equal?)
(define-syntax-rule (define-simple-predicate-inferrer predicate type)
@@ -555,7 +569,7 @@ minimum, and maximum."
&all-types))
(define-type-inferrer (make-vector size init result)
(restrict! size &exact-integer 0 *max-vector-len*)
- (define! result &vector (&min size) (&max size)))
+ (define! result &vector (max (&min size) 0) (&max size)))
(define-type-checker (vector-ref v idx)
(and (check-type v &vector 0 *max-vector-len*)
@@ -579,7 +593,8 @@ minimum, and maximum."
(define-simple-type-checker (vector-length &vector))
(define-type-inferrer (vector-length v result)
(restrict! v &vector 0 *max-vector-len*)
- (define! result &exact-integer (max (&min v) 0) (&max v)))
+ (define! result &exact-integer (max (&min v) 0)
+ (min (&max v) *max-vector-len*)))
@@ -731,7 +746,6 @@ minimum, and maximum."
(when (zero? (logand (logior (&type a) (&type b)) (lognot &number)))
(restrict! a &real -inf.0 +inf.0)
(restrict! b &real -inf.0 +inf.0)))
-;; FIXME!!!
(define-type-aliases < <= > >=)
;; Arithmetic.
@@ -909,7 +923,8 @@ minimum, and maximum."
(cond
((zero? (logand (&type val) (logior &flonum &complex)))
(define! result &boolean 0 0))
- ((zero? (logand (&type val) (lognot (logior &flonum &complex))))
+ ((zero? (logand (&type val) (logand &number
+ (lognot (logior &flonum &complex)))))
(define! result &boolean 1 1))
(else
(define! result &boolean 0 1))))
@@ -1007,7 +1022,6 @@ minimum, and maximum."
;; Flonums.
(define-simple-type-checker (sqrt &number))
(define-type-inferrer (sqrt x result)
- (restrict! x &number -inf.0 +inf.0)
(let ((type (&type x)))
(cond
((and (zero? (logand type &complex)) (<= 0 (&min x)))
@@ -1022,11 +1036,18 @@ minimum, and maximum."
(define-simple-type-checker (abs &real))
(define-type-inferrer (abs x result)
- (restrict! x &real -inf.0 +inf.0)
- (define! result (logior (logand (&type x) (lognot &number))
- (logand (&type x) &real))
- (min (abs (&min x)) (abs (&max x)))
- (max (abs (&min x)) (abs (&max x)))))
+ (let ((type (&type x)))
+ (cond
+ ((eqv? type (logand type &number))
+ (restrict! x &real -inf.0 +inf.0)
+ (define! result (logand type &real)
+ (min (abs (&min x)) (abs (&max x)))
+ (max (abs (&min x)) (abs (&max x)))))
+ (else
+ (define! result (logior (logand (&type x) (lognot &number))
+ (logand (&type x) &real))
+ (max (&min x) 0)
+ (max (abs (&min x)) (abs (&max x))))))))
@@ -1041,12 +1062,12 @@ minimum, and maximum."
(define-simple-type-checker (integer->char (&exact-integer 0 #x10ffff)))
(define-type-inferrer (integer->char i result)
(restrict! i &exact-integer 0 #x10ffff)
- (define! result &char (&min i) (&max i)))
+ (define! result &char (max (&min i) 0) (min (&max i) #x10ffff)))
(define-simple-type-checker (char->integer &char))
(define-type-inferrer (char->integer c result)
(restrict! c &char 0 #x10ffff)
- (define! result &exact-integer (&min c) (&max c)))
+ (define! result &exact-integer (max (&min c) 0) (min (&max c) #x10ffff)))
@@ -1055,391 +1076,312 @@ minimum, and maximum."
;;; Type flow analysis: the meet (ahem) of the algorithm.
;;;
-(define (infer-types* dfg min-label label-count min-var var-count)
+(define (infer-types* dfg min-label label-count)
"Compute types for all variables in @var{fun}. Returns a hash table
mapping symbols to types."
- (let* ((typev (make-vector (* 2 label-count) #f))
- (changed (make-bitvector var-count #f))
- (changed-types (make-bitvector var-count #f))
- (changed-ranges (make-bitvector var-count #f))
- (revisit-labels (make-bitvector label-count #f))
- (tmp (make-bytevector (* var-count 12) 0))
- (tmp2 (make-bytevector (* var-count 12) 0))
- (saturate? #f))
- (define (var->idx var) (- var min-var))
- (define (idx->var idx) (+ idx min-var))
+ (let ((typev (make-vector label-count))
+ (idoms (compute-idoms dfg min-label label-count))
+ (revisit-label #f)
+ (types-changed? #f)
+ (saturate-ranges? #f))
(define (label->idx label) (- label min-label))
- (define (idx->label idx) (+ idx min-label))
-
- (define (get-pre-types label)
- (vector-ref typev (* (label->idx label) 2)))
- (define (get-post-types label)
- (vector-ref typev (1+ (* (label->idx label) 2))))
-
- (define (define! bv val type min max)
- (extend-var-type! bv val type)
- (extend-var-range! bv val min max))
-
- (define (restrict! bv val type min max)
- (when (>= val 0)
- (restrict-var-type! bv val type)
- (restrict-var-range! bv val min max)))
-
- (define (infer-primcall! out name args result)
- (let lp ((args args))
- (match args
- ((arg . args)
- ;; Primcall operands can originate outside the function.
- (when (<= 0 arg)
- (bitvector-set! changed arg #t))
- (lp args))
- (_ #f)))
- (when result
- (bitvector-set! changed result #t))
- (let ((inferrer (hashq-ref *type-inferrers* name)))
- (if inferrer
- ;; FIXME: remove the apply?
- (apply inferrer out
- (if result
- (append args (list result))
- args))
- (when result
- (define! out result &all-types -inf.0 +inf.0)))))
-
- (define (infer-predicate! out name args true?)
- (let ((pred-inferrer (hashq-ref *predicate-inferrers* name)))
- (when pred-inferrer
- ;; FIXME: remove the apply?
- (apply pred-inferrer out (append args (list true?))))))
-
- (define (propagate-types! k in)
- (match (lookup-predecessors k dfg)
- ((_)
- ;; Fast path: we dominate the successor. Just copy; there's no
- ;; need to set bits in the "revisit-labels" set because we'll
- ;; reach the successor in this iteration anyway.
- (let ((out (get-pre-types k)))
- (bytevector-copy! in 0 out 0 (* var-count 12))
- out))
+
+ (define (get-entry label) (vector-ref typev (label->idx label)))
+
+ (define (in-types entry) (vector-ref entry 0))
+ (define (out-types entry succ) (vector-ref entry (1+ succ)))
+
+ (define (update-in-types! entry types)
+ (vector-set! entry 0 types))
+ (define (update-out-types! entry succ types)
+ (vector-set! entry (1+ succ) types))
+
+ (define (prepare-initial-state!)
+ ;; The result is a vector with an entry for each label. Each entry
+ ;; is a vector. The first slot in the entry vector corresponds to
+ ;; the types that flow into the labelled expression. The following
+ ;; slot is for the types that flow out to the first successor, and
+ ;; so on for additional successors.
+ (let lp ((label min-label))
+ (when (< label (+ min-label label-count))
+ (let* ((nsuccs (match (lookup-cont label dfg)
+ (($ $kargs _ _ term)
+ (match (find-call term)
+ (($ $continue k src (or ($ $branch) ($
$prompt))) 2)
+ (_ 1)))
+ (($ $kfun src meta self tail clause) (if clause 1
0))
+ (($ $kclause arity body alt) (if alt 2 1))
+ (($ $kreceive) 1)
+ (($ $ktail) 0)))
+ (entry (make-vector (1+ nsuccs) #f)))
+ (vector-set! typev (label->idx label) entry)
+ (lp (1+ label)))))
+
+ ;; Initial state: nothing flows into the $kfun.
+ (let ((entry (get-entry min-label)))
+ (update-in-types! entry typeset-null)))
+
+ (define (adjoin-vars types vars type min max)
+ (match vars
+ (() types)
+ ((var . vars)
+ (adjoin-vars (adjoin-var types var type min max) vars type min max))))
+
+ (define (infer-primcall types succ name args result)
+ (cond
+ ((hashq-ref *type-inferrers* name)
+ => (lambda (inferrer)
+ ;; FIXME: remove the apply?
+ ;(pk 'primcall name args result)
+ (apply inferrer types succ
+ (if result
+ (append args (list result))
+ args))))
+ (result
+ (adjoin-var types result &all-types -inf.0 +inf.0))
+ (else
+ types)))
+
+ (define (propagate-types! pred-label pred-entry succ-idx succ-label out)
+ ;; Update "in" set of continuation.
+ (let ((succ-entry (get-entry succ-label)))
+ (match (lookup-predecessors succ-label dfg)
+ ((_)
+ ;; A normal edge.
+ (update-in-types! succ-entry out))
+ (_
+ ;; A control-flow join.
+ (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)))))))))
+ ;; Finally update "out" set for current expression.
+ (update-out-types! pred-entry succ-idx out))
+
+ (define (visit-exp label entry k types exp)
+ (define (propagate! succ-idx succ-label types)
+ (propagate-types! label entry succ-idx succ-label types))
+ ;; Each of these branches must propagate! to its successors.
+ (match exp
+ (($ $branch kt ($ $values (arg)))
+ ;; The "normal" continuation is the #f branch.
+ (let ((types (restrict-var types arg (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
+ ;; from the typeset (because it would remove
+ ;; #t as well: they are both &boolean).
+ (propagate! 1 kt types))
+ (($ $branch kt ($ $primcall name args))
+ ;; The "normal" continuation is the #f branch.
+ (let ((types (infer-primcall types 0 name args #f)))
+ (propagate! 0 k types))
+ (let ((types (infer-primcall types 1 name args #f)))
+ (propagate! 1 kt types)))
+ (($ $prompt escape? tag handler)
+ ;; The "normal" continuation enters the prompt.
+ (propagate! 0 k types)
+ (propagate! 1 handler types))
+ (($ $primcall name args)
+ (propagate! 0 k
+ (match (lookup-cont k dfg)
+ (($ $kargs _ defs)
+ (infer-primcall types 0 name args
+ (match defs ((var) var) (() #f))))
+ (_
+ ;(pk 'warning-no-restrictions name)
+ types))))
+ (($ $values args)
+ (match (lookup-cont k dfg)
+ (($ $kargs _ defs)
+ (let ((in types))
+ (let lp ((defs defs) (args args) (out types))
+ (match (cons defs args)
+ ((() . ())
+ (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)))))))))
+ (_
+ (propagate! 0 k types))))
+ ((or ($ $call) ($ $callk))
+ (propagate! 0 k types))
(_
- (propagate-types/slow! k in))))
-
- (define (propagate-types/slow! k in)
- (let ((out (get-pre-types k)))
- ;; Slow path: union.
- (let lp ((n 0))
- (let ((n (bit-position #t changed-types n)))
- (when n
- (let ((in-type (var-type in n))
- (out-type (var-type out n)))
- (let ((type (logior in-type out-type)))
- (unless (= type out-type)
- (bitvector-set! revisit-labels (label->idx k) #t)
- (set-var-type! out n type))))
- (lp (1+ n)))))
- (let lp ((n 0))
- (let ((n (bit-position #t changed-ranges n)))
- (when n
- (let ((in-min (var-clamped-min in n))
- (in-max (var-clamped-max in n))
- (out-min (var-clamped-min out n))
- (out-max (var-clamped-max out n)))
- (let ((min (min in-min out-min)))
- (unless (= min out-min)
- (bitvector-set! revisit-labels (label->idx k) #t)
- (set-var-min! out n (if saturate? *min-s32* min))))
- (let ((max (max in-max out-max)))
- (unless (= max out-max)
- (bitvector-set! revisit-labels (label->idx k) #t)
- (set-var-max! out n (if saturate? *max-s32* max)))))
- (lp (1+ n)))))))
-
- ;; Initialize "tmp" as a template.
- (let lp ((n 0))
- (when (< n var-count)
- (set-var-min! tmp n +inf.0)
- (set-var-max! tmp n -inf.0)
- (lp (1+ n))))
-
- ;; Initial state: invalid range, no types.
- (let lp ((n 0))
- (define (make-fresh-type-vector var-count)
- (let ((bv (make-bytevector (* var-count 12) 0)))
- (bytevector-copy! tmp 0 bv 0 (* var-count 12))
- bv))
- (when (< n label-count)
- (vector-set! typev (* n 2) (make-fresh-type-vector var-count))
- (vector-set! typev (1+ (* n 2)) (make-fresh-type-vector var-count))
- (lp (1+ n))))
-
- ;; Iterate over all labels in the function. When visiting a label
- ;; N, we first propagate N's types to the continuation, then refine
- ;; those types in place (at the continuation). This is consistent
- ;; with an interpretation that the types at a labelled expression
- ;; describe the values before the expression is evaluated, i.e., the
- ;; types that flow into a label.
+ (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))))))))
+
+ (prepare-initial-state!)
+
+ ;; Iterate over all labelled expressions in the function,
+ ;; propagating types and ranges to all successors.
(let lp ((label min-label))
+ ;(pk 'visit label)
(cond
((< label (+ min-label label-count))
- (let ((pre (get-pre-types label))
- (post (get-post-types label)))
- ;; First, clear the "changed" bitvector and save a copy of the
- ;; "post" set, so we can detect what changes in this
- ;; expression.
- (let ((revisit? (bitvector-ref revisit-labels (label->idx label))))
- ;; Check all variables for changes in expressions that we
- ;; are revisiting because of a changed incoming type or
- ;; range on a control-flow join.
- (bitvector-fill! changed revisit?))
- (bitvector-set! revisit-labels (label->idx label) #f)
- (bytevector-copy! post 0 tmp 0 (bytevector-length post))
-
- ;; Now copy the incoming types to the outgoing types.
- (bytevector-copy! pre 0 post 0 (bytevector-length post))
-
+ (let* ((entry (vector-ref typev (label->idx label)))
+ (types (in-types entry)))
+ (define (propagate! succ-idx succ-label types)
+ (propagate-types! label entry succ-idx succ-label types))
;; Add types for new definitions, and restrict types of
;; existing variables due to side effects.
(match (lookup-cont label dfg)
(($ $kargs names vars term)
- (let visit-term ((term term))
+ (let visit-term ((term term) (types types))
(match term
(($ $letrec names vars funs term)
- (let lp ((vars vars))
- (match vars
- ((var . vars)
- (let ((def (var->idx var)))
- (bitvector-set! changed def #t)
- (define! post def &procedure -inf.0 +inf.0)
- (lp vars)))
- (_ (visit-term term)))))
+ (visit-term term
+ (adjoin-vars types vars
+ &procedure -inf.0 +inf.0)))
(($ $letk conts term)
- (visit-term term))
+ (visit-term term types))
(($ $continue k src exp)
- (match exp
- (($ $branch kt exp)
- ;; The "normal" continuation is the #f branch.
- ;; For the #t branch we need to roll our own
- ;; "changed" logic. This will be refactored
- ;; in the future.
- (let ((kt-out tmp2))
- (bytevector-copy! pre 0 kt-out 0 (bytevector-length
pre))
- (match exp
- (($ $values (arg))
- (let ((arg (var->idx arg)))
- (unless (< arg 0)
- (bitvector-set! changed arg #t)
- (restrict! post arg (logior &boolean &nil) 0 0))
- ;; No additional information on the #t branch,
- ;; as there's no way currently to remove #f
- ;; from the typeset (because it would remove
- ;; #t as well: they are both &boolean).
- ))
- (($ $primcall name args)
- (let ((args (map var->idx args)))
- ;; For the #t branch we need to roll our own
- ;; "changed" logic. This will be refactored
- ;; in the future.
- (define (update-changelist! k from var)
- (let ((to (get-pre-types k)))
- (unless (or (< var 0)
- (bitvector-ref changed-types var)
- (= (logior (var-type from var)
- (var-type to var))
- (var-type to var)))
- (bitvector-set! changed-types var #t))
- (unless (or (< var 0)
- (bitvector-ref changed-ranges var)
- (and
- (<= (var-min to var) (var-min
from var))
- (<= (var-max from var) (var-max
to var))))
- (bitvector-set! changed-ranges var #t))))
- ;; The "normal" continuation is the #f branch.
- (infer-predicate! post name args #f)
- (infer-predicate! kt-out name args #t)
- (let lp ((args args))
- (match args
- ((arg . args)
- ;; Primcall operands can originate
- ;; outside the function.
- (when (<= 0 arg)
- ;; `out' will be scanned below.
- (bitvector-set! changed arg #t)
- ;; But we need to manually scan
- ;; kt-out.
- (update-changelist! kt kt-out arg))
- (lp args))
- (_ #f))))))
- ;; Manually propagate the kt branch.
- (propagate-types! kt kt-out)))
- (($ $primcall name args)
- (match (lookup-cont k dfg)
- (($ $kargs (_) (var))
- (let ((def (var->idx var)))
- (infer-primcall! post name (map var->idx args) def)))
- (($ $kargs ())
- (infer-primcall! post name (map var->idx args) #f))
- (_ #f)))
- (($ $values args)
- (match (lookup-cont k dfg)
- (($ $kargs _ defs)
- (let lp ((defs defs) (args args))
- (match (cons defs args)
- ((() . ()) #f)
- (((def . defs) . (arg . args))
- (let ((def (var->idx def)) (arg (var->idx arg)))
- (bitvector-set! changed def #t)
- (if (< arg 0)
- (define! post def &all-types -inf.0 +inf.0)
- (define! post def (var-type post arg)
- (var-min post arg) (var-max post arg))))
- (lp defs args)))))
- (_ #f)))
- ((or ($ $call) ($ $callk) ($ $prompt))
- ;; Nothing to do.
- #t)
- (_
- (call-with-values
- (lambda ()
- (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))))
- (lambda (type min max)
- (match (lookup-cont k dfg)
- (($ $kargs (_) (var))
- (let ((def (var->idx var)))
- (bitvector-set! changed def #t)
- (define! post def type min max))))))))))))
- (cont
- (let lp ((vars (match cont
- (($ $kreceive arity k*)
- (match (lookup-cont k* dfg)
- (($ $kargs names vars) vars)))
- (($ $kfun src meta self)
- (list self))
- (($ $kclause arity ($ $cont kbody))
- (match (lookup-cont kbody dfg)
- (($ $kargs names vars) vars)))
- (_ '()))))
- (match vars
- (() #t)
- ((var . vars)
- (bitvector-set! changed (var->idx var) #t)
- (define! post (var->idx var) &all-types -inf.0 +inf.0)
- (lp vars))))))
-
- ;; Now determine the set of changed variables.
- (let lp ((n 0))
- (let ((n (bit-position #t changed n)))
- (when n
- (unless (eqv? (var-type tmp n) (var-type post n))
- (bitvector-set! changed-types n #t))
- (unless (and (eqv? (var-clamped-min tmp n)
- (var-clamped-min post n))
- (eqv? (var-clamped-max tmp n)
- (var-clamped-max post n)))
- (bitvector-set! changed-ranges n #t))
- (lp (1+ n)))))
-
- ;; Propagate outgoing types to successors.
- (match (lookup-cont label dfg)
- (($ $kargs names vars term)
- (match (find-call term)
- (($ $continue k src exp)
- (propagate-types! k post)
- (match exp
- (($ $prompt escape? tag handler)
- (propagate-types! handler post))
- (_ #f)))))
- (($ $kreceive arity k*)
- (propagate-types! k* post))
+ (visit-exp label entry k types exp)))))
+ (($ $kreceive arity k)
+ (match (lookup-cont k dfg)
+ (($ $kargs names vars)
+ (propagate! 0 k
+ (adjoin-vars types vars
+ &all-types -inf.0 +inf.0)))))
(($ $kfun src meta self tail clause)
- (let lp ((clause clause))
+ (let ((types (adjoin-var types self
+ &all-types -inf.0 +inf.0)))
(match clause
(#f #f)
- (($ $cont k ($ $kclause arity body alternate))
- (propagate-types! k post)
- (lp alternate)))))
- (($ $kclause arity ($ $cont kbody))
- (propagate-types! kbody post))
- (_ #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))
+ (match alt
+ (#f #f)
+ (($ $cont kclause)
+ (propagate! 1 kclause types))))
+ (($ $ktail) #t)))
;; And loop.
(lp (1+ label)))
- ;; Iterate until the types reach a fixed point.
- ((bit-position #t changed-types 0)
- (bitvector-fill! changed-types #f)
- (bitvector-fill! changed-ranges #f)
- (lp min-label))
-
- ;; Once the types have a fixed point, iterate until ranges also
- ;; reach a fixed point, saturating ranges to accelerate
- ;; convergence.
- ((or (bit-position #t changed-ranges 0)
- (bit-position #t revisit-labels 0))
- (bitvector-fill! changed-ranges #f)
- (set! saturate? #t)
- (lp min-label))
+ ;; Iterate until we reach a fixed point.
+ (revisit-label
+ ;; Once the types have a fixed point, iterate until ranges also
+ ;; reach a fixed point, saturating ranges to accelerate
+ ;; convergence.
+ (unless types-changed?
+ (set! saturate-ranges? #t))
+ (set! types-changed? #f)
+ (let ((label revisit-label))
+ (set! revisit-label #f)
+ ;(pk 'looping)
+ (lp label)))
;; All done! Return the computed types.
(else typev)))))
-(define* (infer-types fun dfg #:key (max-label-count +inf.0))
+(define-record-type <type-analysis>
+ (make-type-analysis min-label label-count types)
+ type-analysis?
+ (min-label type-analysis-min-label)
+ (label-count type-analysis-label-count)
+ (types type-analysis-types))
+
+(define (infer-types fun dfg)
;; Fun must be renumbered.
(match fun
- (($ $cont min-label ($ $kfun _ _ min-var))
- (call-with-values
- (lambda ()
- ((make-local-cont-folder label-count var-count)
- (lambda (k cont label-count var-count)
- (define (min* var vars)
- (match vars
- ((var* . vars)
- (min* (min var var*) vars))
- (_ var)))
- (let ((label-count (1+ label-count)))
- (match cont
- (($ $kargs names vars body)
- (let lp ((body body)
- (var-count (+ var-count (length vars))))
- (match body
- (($ $letrec names vars funs body)
- (lp body
- (+ var-count (length vars))))
- (($ $letk conts body)
- (lp body var-count))
- (_ (values label-count var-count)))))
- (($ $kfun src meta self)
- (values label-count (1+ var-count)))
- (_
- (values label-count var-count)))))
- fun 0 0))
- (lambda (label-count var-count)
- (and (< label-count max-label-count)
- (infer-types* dfg min-label label-count min-var var-count)))))))
-
-(define (lookup-pre-type typev label def)
- (if (< def 0)
- (values &all-types -inf.0 +inf.0)
- (let ((types (vector-ref typev (* label 2))))
- (values (var-type types def)
- (var-min types def)
- (var-max types def)))))
-
-(define (lookup-post-type typev label def)
- (if (< def 0)
- (values &all-types -inf.0 +inf.0)
- (let ((types (vector-ref typev (1+ (* label 2)))))
- (values (var-type types def)
- (var-min types def)
- (var-max types def)))))
-
-(define (primcall-types-check? label-idx typev name arg-idxs)
- (let ((checker (hashq-ref *type-checkers* name)))
- (and checker
- (apply checker (vector-ref typev (* label-idx 2)) arg-idxs))))
+ (($ $cont min-label ($ $kfun))
+ (let ((label-count ((make-local-cont-folder label-count)
+ (lambda (k cont label-count) (1+ label-count))
+ fun 0)))
+ (make-type-analysis min-label label-count
+ (infer-types* dfg min-label label-count))))))
+
+(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)))))
+
+(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)))))
+
+(define (primcall-types-check? analysis label name args)
+ (match (hashq-ref *type-checkers* name)
+ (#f #f)
+ (checker
+ (match analysis
+ (($ <type-analysis> min-label label-count typev)
+ (let ((entry (vector-ref typev (- label min-label))))
+ (apply checker (vector-ref entry 0) args)))))))
diff --git a/module/language/tree-il/peval.scm
b/module/language/tree-il/peval.scm
index 15487b0..3331291 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -1249,6 +1249,10 @@ top-level bindings from ENV and return the resulting
expression."
(make-primcall src 'list (list x)))
(('cons x ($ <primcall> _ 'list elts))
(make-primcall src 'list (cons x elts)))
+ (('list)
+ (make-const src '()))
+ (('vector)
+ (make-const src '#()))
((name . args)
(make-primcall src name args))))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-48-gec412d7,
Andy Wingo <=