[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 03/07: DRAFT: Use 'eqv?' instead of 'eq?' in intmap.scm,
From: |
Mark H. Weaver |
Subject: |
[Guile-commits] 03/07: DRAFT: Use 'eqv?' instead of 'eq?' in intmap.scm, intset.scm, etc. |
Date: |
Thu, 6 Jun 2019 05:37:14 -0400 (EDT) |
mhw pushed a commit to branch wip-new-tagging
in repository guile.
commit 90275c1c183d24324b431647dc6b178f74ceec7a
Author: Mark H Weaver <address@hidden>
Date: Wed Jun 5 08:17:30 2019 -0400
DRAFT: Use 'eqv?' instead of 'eq?' in intmap.scm, intset.scm, etc.
---
module/language/cps/intmap.scm | 76 +++++++++++++++---------------
module/language/cps/intset.scm | 72 ++++++++++++++--------------
module/language/cps/specialize-numbers.scm | 4 +-
3 files changed, 76 insertions(+), 76 deletions(-)
diff --git a/module/language/cps/intmap.scm b/module/language/cps/intmap.scm
index 8995d62..d9dd482 100644
--- a/module/language/cps/intmap.scm
+++ b/module/language/cps/intmap.scm
@@ -89,7 +89,7 @@
(define *absent* (list 'absent))
(define-inlinable (absent? x)
- (eq? x *absent*))
+ (eqv? x *absent*))
(define-inlinable (present? x)
(not (absent? x)))
@@ -106,11 +106,11 @@
(vector-set! new i elt)
new))
(define-inlinable (assert-readable! root-edit)
- (unless (eq? (get-atomic-reference root-edit) (current-thread))
+ (unless (eqv? (get-atomic-reference root-edit) (current-thread))
(error "Transient intmap owned by another thread" root-edit)))
(define-inlinable (writable-branch branch root-edit)
(let ((edit (vector-ref branch *edit-index*)))
- (if (eq? root-edit edit)
+ (if (eqv? root-edit edit)
branch
(clone-branch-with-edit branch root-edit))))
(define (branch-empty? branch)
@@ -190,7 +190,7 @@
(vector-set! root idx v)
v)
(let ((v* (writable-branch v edit)))
- (unless (eq? v v*)
+ (unless (eqv? v v*)
(vector-set! root idx v*))
v*))))
(define (adjoin! i shift root)
@@ -198,7 +198,7 @@
(idx (logand (ash i (- shift)) *branch-mask*)))
(if (zero? shift)
(let ((node (vector-ref root idx)))
- (unless (eq? node val)
+ (unless (eqv? node val)
(vector-set! root idx (if (present? node) (meet node val) val))))
(adjoin! i shift (ensure-branch! root idx)))))
(match map
@@ -215,10 +215,10 @@
((and (<= min i) (< i (+ min (ash 1 shift))))
;; Add element to map; level will not change.
(if (zero? shift)
- (unless (eq? root val)
+ (unless (eqv? root val)
(set-transient-intmap-root! map (meet root val)))
(let ((root* (writable-branch root edit)))
- (unless (eq? root root*)
+ (unless (eqv? root root*)
(set-transient-intmap-root! map root*))
(adjoin! (- i min) shift root*))))
(else
@@ -247,7 +247,7 @@
(define (adjoin i shift root)
(if (zero? shift)
(cond
- ((eq? root val) root)
+ ((eqv? root val) root)
((absent? root) val)
(else (meet root val)))
(let* ((shift (- shift *branch-bits*))
@@ -259,7 +259,7 @@
root*)
(let* ((node (vector-ref root idx))
(node* (adjoin i shift node)))
- (if (eq? node node*)
+ (if (eqv? node node*)
root
(clone-branch-and-set root idx node*)))))))
(match map
@@ -275,7 +275,7 @@
;; Add element to map; level will not change.
(let ((old-root root)
(root (adjoin (- i min) shift root)))
- (if (eq? root old-root)
+ (if (eqv? root old-root)
map
(make-intmap min shift root))))
((< i min)
@@ -297,7 +297,7 @@ already, and always calls the meet procedure."
(v (vector-ref root idx)))
(when (absent? v) (not-found))
(let ((v* (writable-branch v edit)))
- (unless (eq? v v*)
+ (unless (eqv? v v*)
(vector-set! root idx v*))
v*)))
(define (adjoin! i shift root)
@@ -319,7 +319,7 @@ already, and always calls the meet procedure."
(if (zero? shift)
(set-transient-intmap-root! map (meet root val))
(let ((root* (writable-branch root edit)))
- (unless (eq? root root*)
+ (unless (eqv? root root*)
(set-transient-intmap-root! map root*))
(adjoin! (- i min) shift root*))))
(else
@@ -344,7 +344,7 @@ already, and always calls the meet procedure."
(not-found)
(let* ((node (vector-ref root idx))
(node* (adjoin i shift node)))
- (if (eq? node node*)
+ (if (eqv? node node*)
root
(clone-branch-and-set root idx node*)))))))
(match map
@@ -356,7 +356,7 @@ already, and always calls the meet procedure."
((and (present? root) (<= min i) (< i (+ min (ash 1 shift))))
(let ((old-root root)
(root (adjoin (- i min) shift root)))
- (if (eq? root old-root)
+ (if (eqv? root old-root)
map
(make-intmap min shift root))))
(else (not-found))))
@@ -374,7 +374,7 @@ already, and always calls the meet procedure."
(if (absent? node)
root
(let ((node* (remove i shift node)))
- (if (eq? node node*)
+ (if (eqv? node node*)
root
(clone-branch-and-set root idx node*))))))))
(match map
@@ -384,7 +384,7 @@ already, and always calls the meet procedure."
((and (<= min i) (< i (+ min (ash 1 shift))))
;; Add element to map; level will not change.
(let ((root* (remove (- i min) shift root)))
- (if (eq? root root*)
+ (if (eqv? root root*)
map
(if (absent? root*)
empty-intmap
@@ -544,48 +544,48 @@ already, and always calls the meet procedure."
(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.
+ ;; Union A and B from index I; the result may be eqv? 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)
+ (if (eqv? a-child b-child)
(lp (1+ i))
(let ((child (union shift a-child b-child)))
(cond
- ((eq? a-child child)
+ ((eqv? 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.
+ ;; Union A and B; the may could be eqv? 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)
+ (if (eqv? a-child b-child)
(lp (1+ i))
(let ((child (union shift a-child b-child)))
(cond
- ((eq? a-child child)
+ ((eqv? a-child child)
(union-branches/a shift a b (1+ i)))
- ((eq? b-child child)
+ ((eqv? 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.
+ ;; Seems they are the same but not eqv?. Odd.
(else a))))
(define (union shift a-node b-node)
(cond
((absent? a-node) b-node)
((absent? b-node) a-node)
- ((eq? a-node b-node) a-node)
+ ((eqv? 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)
@@ -608,8 +608,8 @@ already, and always calls the meet procedure."
;; 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)
+ ((eqv? root a-root) a)
+ ((eqv? root b-root) b)
(else (make-intmap a-min a-shift root)))))))))
(define* (intmap-intersect a b #:optional (meet meet-error))
@@ -624,47 +624,47 @@ already, and always calls the meet procedure."
(lp (1+ i))))
((branch-empty? fresh) *absent*)
(else fresh))))
- ;; Intersect A and B from index I; the result may be eq? to A.
+ ;; Intersect A and B from index I; the result may be eqv? 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)
+ (if (eqv? a-child b-child)
(lp (1+ i))
(let ((child (intersect shift a-child b-child)))
(cond
- ((eq? a-child child)
+ ((eqv? 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.
+ ;; Intersect A and B; the may could be eqv? 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)
+ (if (eqv? a-child b-child)
(lp (1+ i))
(let ((child (intersect shift a-child b-child)))
(cond
- ((eq? a-child child)
+ ((eqv? a-child child)
(intersect-branches/a shift a b (1+ i)))
- ((eq? b-child child)
+ ((eqv? 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.
+ ;; Seems they are the same but not eqv?. Odd.
(else a))))
(define (intersect shift a-node b-node)
(cond
((or (absent? a-node) (absent? b-node)) *absent*)
- ((eq? a-node b-node) a-node)
+ ((eqv? a-node b-node) a-node)
((zero? shift) (meet a-node b-node))
(else (intersect-branches (- shift *branch-bits*) a-node b-node))))
@@ -717,8 +717,8 @@ already, and always calls the meet procedure."
;; 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)
+ ((eqv? root a-root) a)
+ ((eqv? root b-root) b)
(else (make-intmap/prune a-min a-shift root)))))))))
(define (intmap->alist intmap)
diff --git a/module/language/cps/intset.scm b/module/language/cps/intset.scm
index 7b2a66a..51fcf24 100644
--- a/module/language/cps/intset.scm
+++ b/module/language/cps/intset.scm
@@ -20,7 +20,7 @@
;;; 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.
+;;; sense of eqv?, whereever possible.
;;;
;;; Code:
@@ -128,11 +128,11 @@
(vector-set! new i elt)
new))
(define-inlinable (assert-readable! root-edit)
- (unless (eq? (get-atomic-reference root-edit) (current-thread))
+ (unless (eqv? (get-atomic-reference root-edit) (current-thread))
(error "Transient intset owned by another thread" root-edit)))
(define-inlinable (writable-branch branch root-edit)
(let ((edit (vector-ref branch *edit-index*)))
- (if (eq? root-edit edit)
+ (if (eqv? root-edit edit)
branch
(clone-branch-and-set branch *edit-index* root-edit))))
(define (branch-empty? branch)
@@ -211,7 +211,7 @@
(vector-set! root idx v)
v))
(v (let ((v* (writable-branch v edit)))
- (unless (eq? v v*)
+ (unless (eqv? v v*)
(vector-set! root idx v*))
v*)))))
(define (adjoin-branch! i shift root)
@@ -240,7 +240,7 @@
(if (= shift *leaf-bits*)
(set-transient-intset-root! bs (adjoin-leaf (- i min) root))
(let ((root* (writable-branch root edit)))
- (unless (eq? root root*)
+ (unless (eqv? root root*)
(set-transient-intset-root! bs root*))
(adjoin-branch! (- i min) shift root*))))
(else
@@ -279,7 +279,7 @@
(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)
+ (if (eqv? node new-node)
root
(clone-branch-and-set root idx new-node))))))
(match bs
@@ -297,7 +297,7 @@
;; Add element to set; level will not change.
(let ((old-root root)
(root (adjoin (- i min) shift root)))
- (if (eq? root old-root)
+ (if (eqv? root old-root)
bs
(make-intset min shift root))))
((< i min)
@@ -328,7 +328,7 @@
((vector-ref root idx)
=> (lambda (node)
(let ((new-node (remove i shift node)))
- (if (eq? node new-node)
+ (if (eqv? node new-node)
root
(let ((root (clone-branch-and-set root idx new-node)))
(and (or new-node (not (branch-empty? root)))
@@ -341,7 +341,7 @@
((and (<= min i) (< i (+ min (ash 1 shift))))
(let ((old-root root)
(root (remove (- i min) shift root)))
- (if (eq? root old-root)
+ (if (eqv? root old-root)
bs
(make-intset/prune min shift root))))
(else bs)))))
@@ -511,48 +511,48 @@
(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.
+ ;; Union A and B from index I; the result may be eqv? 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)
+ (if (eqv? a-child b-child)
(lp (1+ i))
(let ((child (union shift a-child b-child)))
(cond
- ((eq? a-child child)
+ ((eqv? 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.
+ ;; Union A and B; the may could be eqv? 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)
+ (if (eqv? a-child b-child)
(lp (1+ i))
(let ((child (union shift a-child b-child)))
(cond
- ((eq? a-child child)
+ ((eqv? a-child child)
(union-branches/a shift a b (1+ i)))
- ((eq? b-child child)
+ ((eqv? 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.
+ ;; Seems they are the same but not eqv?. 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)
+ ((eqv? 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)
@@ -576,8 +576,8 @@
;; 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)
+ ((eqv? root a-root) a)
+ ((eqv? root b-root) b)
(else (make-intset a-min a-shift root)))))))))
(define (intset-intersect a b)
@@ -596,47 +596,47 @@
(lp (1+ i))))
((branch-empty? fresh) #f)
(else fresh))))
- ;; Intersect A and B from index I; the result may be eq? to A.
+ ;; Intersect A and B from index I; the result may be eqv? 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)
+ (if (eqv? a-child b-child)
(lp (1+ i))
(let ((child (intersect shift a-child b-child)))
(cond
- ((eq? a-child child)
+ ((eqv? 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.
+ ;; Intersect A and B; the may could be eqv? 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)
+ (if (eqv? a-child b-child)
(lp (1+ i))
(let ((child (intersect shift a-child b-child)))
(cond
- ((eq? a-child child)
+ ((eqv? a-child child)
(intersect-branches/a shift a b (1+ i)))
- ((eq? b-child child)
+ ((eqv? 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.
+ ;; Seems they are the same but not eqv?. 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)
+ ((eqv? 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))))
@@ -691,8 +691,8 @@
;; 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)
+ ((eqv? root a-root) a)
+ ((eqv? root b-root) b)
(else (make-intset/prune a-min a-shift root)))))))))
(define (intset-subtract a b)
@@ -711,7 +711,7 @@
(lp (1+ i))))
((branch-empty? fresh) #f)
(else fresh))))
- ;; Subtract B from A. The result may be eq? to A.
+ ;; Subtract B from A. The result may be eqv? to A.
(define (subtract-branches shift a b)
(let lp ((i 0))
(cond
@@ -720,7 +720,7 @@
(b-child (vector-ref b i)))
(let ((child (subtract-nodes shift a-child b-child)))
(cond
- ((eq? a-child child)
+ ((eqv? a-child child)
(lp (1+ i)))
(else
(let ((result (clone-branch-and-set a i child)))
@@ -729,7 +729,7 @@
(define (subtract-nodes shift a-node b-node)
(cond
((or (not a-node) (not b-node)) a-node)
- ((eq? a-node b-node) #f)
+ ((eqv? a-node b-node) #f)
((= shift *leaf-bits*) (subtract-leaves a-node b-node))
(else (subtract-branches (- shift *branch-bits*) a-node b-node))))
@@ -737,7 +737,7 @@
((($ <intset> a-min a-shift a-root) . ($ <intset> b-min b-shift b-root))
(define (return root)
(cond
- ((eq? root a-root) a)
+ ((eqv? root a-root) a)
(else (make-intset/prune a-min a-shift root))))
(cond
((<= a-shift b-shift)
@@ -769,7 +769,7 @@
(< a-idx *branch-size*)
(vector-ref a-root a-idx)))
(new (lp a-min a-shift old)))
- (if (eq? old new)
+ (if (eqv? old new)
a-root
(let ((root (clone-branch-and-set a-root a-idx new)))
(and (or new (not (branch-empty? root)))
diff --git a/module/language/cps/specialize-numbers.scm
b/module/language/cps/specialize-numbers.scm
index 3bc9295..50746cd 100644
--- a/module/language/cps/specialize-numbers.scm
+++ b/module/language/cps/specialize-numbers.scm
@@ -284,7 +284,7 @@ BITS indicating the significant bits needed for a variable.
BITS may be
(let ((worklist (intset-remove worklist label))
(visited* (intset-add visited label)))
(define (continue out*)
- (if (and (eq? out out*) (eq? visited visited*))
+ (if (and (eqv? out out*) (eqv? visited visited*))
(lp worklist visited out)
(lp (intset-union worklist (intmap-ref preds label))
visited* out*)))
@@ -988,7 +988,7 @@ BITS indicating the significant bits needed for a variable.
BITS may be
(let* ((preds (compute-predecessors cps kfun #:labels body))
(defs (compute-defs cps body))
(phis (compute-specializable-phis cps body preds defs)))
- (if (eq? phis empty-intmap)
+ (if (eqv? phis empty-intmap)
cps
(apply-specialization cps kfun body preds defs phis))))
(compute-reachable-functions cps)
- [Guile-commits] branch wip-new-tagging created (now f08e08b), Mark H. Weaver, 2019/06/06
- [Guile-commits] 01/07: fix typo, Mark H. Weaver, 2019/06/06
- [Guile-commits] 05/07: DRAFT: Change f64->scm into an intrinsic., Mark H. Weaver, 2019/06/06
- [Guile-commits] 07/07: DRAFT: Add immediate fractions (fixrats)., Mark H. Weaver, 2019/06/06
- [Guile-commits] 03/07: DRAFT: Use 'eqv?' instead of 'eq?' in intmap.scm, intset.scm, etc.,
Mark H. Weaver <=
- [Guile-commits] 06/07: DRAFT: Add immediate floats (iflos)., Mark H. Weaver, 2019/06/06
- [Guile-commits] 02/07: DRAFT: Scheme eval: Add source annotations to generated procedures., Mark H. Weaver, 2019/06/06
- [Guile-commits] 04/07: WIP: New tagging v8, Mark H. Weaver, 2019/06/06