[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 07/12: Add intmap-replace!.
From: |
Andy Wingo |
Subject: |
[Guile-commits] 07/12: Add intmap-replace!. |
Date: |
Tue, 02 Jun 2015 08:33:53 +0000 |
wingo pushed a commit to branch master
in repository guile.
commit 23379467aeb8c192830a11e21ec6bb5fd69b0169
Author: Andy Wingo <address@hidden>
Date: Sun May 24 17:37:14 2015 +0200
Add intmap-replace!.
* module/language/cps/intmap.scm (intmap-replace!): New interface.
* module/language/cps2/dce.scm (elide-type-checks):
* module/language/cps2/simplify.scm (transform-conts):
* module/language/cps2/utils.scm (intmap-map):
* module/language/tree-il/compile-cps2.scm (cps-convert/thunk): Use
intmap-replace!.
---
module/language/cps/intmap.scm | 51 +++++++++++++++++++++++++++---
module/language/cps2/dce.scm | 3 +-
module/language/cps2/simplify.scm | 2 +-
module/language/cps2/utils.scm | 4 +--
module/language/tree-il/compile-cps2.scm | 3 +-
5 files changed, 50 insertions(+), 13 deletions(-)
diff --git a/module/language/cps/intmap.scm b/module/language/cps/intmap.scm
index d96801c..485f354 100644
--- a/module/language/cps/intmap.scm
+++ b/module/language/cps/intmap.scm
@@ -43,6 +43,7 @@
intmap-add
intmap-add!
intmap-replace
+ intmap-replace!
intmap-remove
intmap-ref
intmap-next
@@ -285,20 +286,61 @@
(($ <transient-intmap>)
(intmap-add (persistent-intmap map) i val meet))))
+(define* (intmap-replace! map i val #:optional (meet (lambda (old new) new)))
+ "Like intmap-add!, but requires that @var{i} was present in the map
+already, and always calls the meet procedure."
+ (define (not-found)
+ (error "not found" i))
+ (define (ensure-branch! root idx)
+ (let ((edit (vector-ref root *edit-index*))
+ (v (vector-ref root idx)))
+ (when (absent? v) (not-found))
+ (let ((v* (writable-branch v edit)))
+ (unless (eq? v v*)
+ (vector-set! root idx v*))
+ v*)))
+ (define (adjoin! i shift root)
+ (let* ((shift (- shift *branch-bits*))
+ (idx (logand (ash i (- shift)) *branch-mask*)))
+ (if (zero? shift)
+ (let ((node (vector-ref root idx)))
+ (when (absent? node) (not-found))
+ (vector-set! root idx (meet node val)))
+ (adjoin! i shift (ensure-branch! root idx)))))
+ (match map
+ (($ <transient-intmap> min shift root edit)
+ (assert-readable! edit)
+ (cond
+ ((< i 0)
+ ;; The power-of-two spanning trick doesn't work across 0.
+ (error "Intmaps can only map non-negative integers." i))
+ ((and (present? root) (<= min i) (< i (+ min (ash 1 shift))))
+ (if (zero? shift)
+ (set-transient-intmap-root! map (meet root val))
+ (let ((root* (writable-branch root edit)))
+ (unless (eq? root root*)
+ (set-transient-intmap-root! map root*))
+ (adjoin! (- i min) shift root*))))
+ (else
+ (not-found)))
+ map)
+ (($ <intmap>)
+ (intmap-add! (transient-intmap map) i val meet))))
+
(define* (intmap-replace map i val #:optional (meet (lambda (old new) new)))
"Like intmap-add, but requires that @var{i} was present in the map
already, and always calls the meet procedure."
- (define (not-found i)
+ (define (not-found)
(error "not found" i))
(define (adjoin i shift root)
(if (zero? shift)
(if (absent? root)
- (not-found i)
+ (not-found)
(meet root val))
(let* ((shift (- shift *branch-bits*))
(idx (logand (ash i (- shift)) *branch-mask*)))
(if (absent? root)
- (not-found i)
+ (not-found)
(let* ((node (vector-ref root idx))
(node* (adjoin i shift node)))
(if (eq? node node*)
@@ -316,8 +358,7 @@ already, and always calls the meet procedure."
(if (eq? root old-root)
map
(make-intmap min shift root))))
- (else
- (not-found i))))
+ (else (not-found))))
(($ <transient-intmap>)
(intmap-replace (persistent-intmap map) i val meet))))
diff --git a/module/language/cps2/dce.scm b/module/language/cps2/dce.scm
index a45d324..28ef04f 100644
--- a/module/language/cps2/dce.scm
+++ b/module/language/cps2/dce.scm
@@ -44,8 +44,7 @@ KFUN where we can prove that no assertion will be raised at
run-time."
(let ((types (infer-types conts kfun)))
(define (visit-primcall effects fx label name args)
(if (primcall-types-check? types label name args)
- (intmap-add! effects label (logand fx (lognot &type-check))
- (lambda (old new) new))
+ (intmap-replace! effects label (logand fx (lognot &type-check)))
effects))
(persistent-intmap
(intmap-fold (lambda (label types effects)
diff --git a/module/language/cps2/simplify.scm
b/module/language/cps2/simplify.scm
index 7416aa2..a9355cd 100644
--- a/module/language/cps2/simplify.scm
+++ b/module/language/cps2/simplify.scm
@@ -58,7 +58,7 @@
(let ((v* (f k v)))
(if (equal? v v*)
out
- (intmap-add! out k v* (lambda (old new) new)))))
+ (intmap-replace! out k v*))))
conts
conts)))
diff --git a/module/language/cps2/utils.scm b/module/language/cps2/utils.scm
index 7905218..c723aa0 100644
--- a/module/language/cps2/utils.scm
+++ b/module/language/cps2/utils.scm
@@ -106,9 +106,7 @@
(define (intmap-map proc map)
(persistent-intmap
- (intmap-fold (lambda (k v out)
- (intmap-add! out k (proc k v)
- (lambda (old new) new)))
+ (intmap-fold (lambda (k v out) (intmap-replace! out k (proc k v)))
map
map)))
diff --git a/module/language/tree-il/compile-cps2.scm
b/module/language/tree-il/compile-cps2.scm
index 59b93f5..14cd5f5 100644
--- a/module/language/tree-il/compile-cps2.scm
+++ b/module/language/tree-il/compile-cps2.scm
@@ -915,8 +915,7 @@ integer."
($ ((lambda (cps)
(let ((init (build-cont
($kfun (tree-il-src exp) '() init ktail kclause))))
- (with-cps (persistent-intmap (intmap-add! cps kinit init
- (lambda (old new)
new)))
+ (with-cps (persistent-intmap (intmap-replace! cps kinit init))
kinit))))))))
(define *comp-module* (make-fluid))
- [Guile-commits] branch master updated (48b2f19 -> 6e725df), Andy Wingo, 2015/06/02
- [Guile-commits] 01/12: Fix regression in compute-idoms, Andy Wingo, 2015/06/02
- [Guile-commits] 03/12: Add intmap-replace., Andy Wingo, 2015/06/02
- [Guile-commits] 04/12: intset-next starting point is optional, Andy Wingo, 2015/06/02
- [Guile-commits] 02/12: Fix type-fold on multiplying exact numbers, Andy Wingo, 2015/06/02
- [Guile-commits] 06/12: DCE uses type analysis to find dead code, Andy Wingo, 2015/06/02
- [Guile-commits] 08/12: Fix compute-defining-expressions (and thereby compute-constant-values), Andy Wingo, 2015/06/02
- [Guile-commits] 07/12: Add intmap-replace!.,
Andy Wingo <=
- [Guile-commits] 09/12: Port prune-top-level-scopes pass to CPS2, Andy Wingo, 2015/06/02
- [Guile-commits] 10/12: Add intmap-fold-right, Andy Wingo, 2015/06/02
- [Guile-commits] 11/12: Add "intset" syntax to construct intsets., Andy Wingo, 2015/06/02
- [Guile-commits] 05/12: Port type inference module to CPS2, Andy Wingo, 2015/06/02
- [Guile-commits] 12/12: Port contification pass to CPS2., Andy Wingo, 2015/06/02