summaryrefslogtreecommitdiff
path: root/module/language/cps/intmap.scm
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2015-05-24 17:37:14 +0200
committerAndy Wingo <wingo@pobox.com>2015-06-02 10:05:09 +0200
commit23379467aeb8c192830a11e21ec6bb5fd69b0169 (patch)
treefe02c7f2f4c3706e34abfd6696b35b90fb20dd0f /module/language/cps/intmap.scm
parentad29059ff84461210534b4cd56726443937aed66 (diff)
downloadguile-23379467aeb8c192830a11e21ec6bb5fd69b0169.tar.gz
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!.
Diffstat (limited to 'module/language/cps/intmap.scm')
-rw-r--r--module/language/cps/intmap.scm51
1 files changed, 46 insertions, 5 deletions
diff --git a/module/language/cps/intmap.scm b/module/language/cps/intmap.scm
index d96801c13..485f35469 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))))