mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-23 13:00:34 +02:00
Code Activity

Intmaps do not treat #f specially as a value

Browse source 
* module/language/cps/intmap.scm: Intmaps can now contain any value;
  #f does not indicate the absence of a value.  Instead we use a unique
  private sentinel to mark absent values or branches.
  (*absent*, absent?, present?): New helpers.
  (new-branch): Initialize empty elements to *absent*.
  (clone-branch-with-edit): New helper.
  (clone-branch-and-set): Use clone-branch-with-edit.
  (writable-branch): Use clone-branch-with-edit
  (empty-intmap): Initialize value to *absent*.
  (add-level): clone-branch-and-set doesn't take #f as a branch any
  more; use new-branch.
  (branch-empty?, make-intmap/prune, intmap-add!):
  (intmap-add, intmap-remove, intmap-next, intmap-prev):
  (intmap-fold, intmap-union, intmap-intersect): Use absent? to detect
  absent branches / values.
  (intmap-ref): Likewise.  Instead of returning #f if the value is not
  found, call the optional not-found procedure.  By default this will
  signal an error.

* module/language/cps/types.scm:
* module/language/cps2/renumber.scm:
* module/language/cps2/simplify.scm: Adapt to intmap-ref signalling an
  error by default if the value is not found.

* module/language/tree-il/compile-cps2.scm: Adapt to intmap-add
  signalling an error if #f was in the intmap as a value.
This commit is contained in:
Andy Wingo 2015-05-14 13:46:09 +02:00
parent cb7aa0b3b1
commit 2b06e90ca4
5 changed files with 144 additions and 129 deletions
Download patch file Download diff file Expand all files Collapse all files

198
module/language/cps/intmap.scm
View file

@ -84,13 +84,22 @@
(root transient-intmap-root set-transient-intmap-root!) (root transient-intmap-root set-transient-intmap-root!)
(edit transient-intmap-edit set-transient-intmap-edit!)) (edit transient-intmap-edit set-transient-intmap-edit!))
(define *absent* (list 'absent))
(define-inlinable (absent? x)
(eq? x *absent*))
(define-inlinable (present? x)
(not (absent? x)))
(define-inlinable (new-branch edit) (define-inlinable (new-branch edit)
(let ((vec (make-vector *branch-size-with-edit* #f))) (let ((vec (make-vector *branch-size-with-edit* *absent*)))
(when edit (vector-set! vec *edit-index* edit)) (vector-set! vec *edit-index* edit)
vec)) vec))
(define-inlinable (clone-branch-with-edit branch edit)
(let ((new (vector-copy branch)))
(vector-set! new *edit-index* edit)
new))
(define (clone-branch-and-set branch i elt) (define (clone-branch-and-set branch i elt)
(let ((new (new-branch #f))) (let ((new (clone-branch-with-edit branch #f)))
(when branch (vector-move-left! branch 0 *branch-size* new 0))
(vector-set! new i elt) (vector-set! new i elt)
new)) new))
(define-inlinable (assert-readable! root-edit) (define-inlinable (assert-readable! root-edit)
@ -100,24 +109,26 @@
(let ((edit (vector-ref branch *edit-index*))) (let ((edit (vector-ref branch *edit-index*)))
(if (eq? root-edit edit) (if (eq? root-edit edit)
branch branch
(clone-branch-and-set branch *edit-index* root-edit)))) (clone-branch-with-edit branch root-edit))))
(define (branch-empty? branch) (define (branch-empty? branch)
(let lp ((i 0)) (let lp ((i 0))
(or (= i *branch-size*) (or (= i *branch-size*)
(and (not (vector-ref branch i)) (and (absent? (vector-ref branch i))
(lp (1+ i)))))) (lp (1+ i))))))
(define-inlinable (round-down min shift) (define-inlinable (round-down min shift)
(logand min (lognot (1- (ash 1 shift))))) (logand min (lognot (1- (ash 1 shift)))))
(define empty-intmap (make-intmap 0 0 #f)) (define empty-intmap (make-intmap 0 0 *absent*))
(define (add-level min shift root) (define (add-level min shift root)
(let* ((shift* (+ shift *branch-bits*)) (let* ((shift* (+ shift *branch-bits*))
(min* (round-down min shift*)) (min* (round-down min shift*))
(idx (logand (ash (- min min*) (- shift)) (idx (logand (ash (- min min*) (- shift))
*branch-mask*))) *branch-mask*))
(make-intmap min* shift* (clone-branch-and-set #f idx root)))) (root* (new-branch #f)))
(vector-set! root* idx root)
(make-intmap min* shift* root*)))
(define (make-intmap/prune min shift root) (define (make-intmap/prune min shift root)
(if (zero? shift) (if (zero? shift)
@ -125,7 +136,7 @@
(let lp ((i 0) (elt #f)) (let lp ((i 0) (elt #f))
(cond (cond
((< i *branch-size*) ((< i *branch-size*)
(if (vector-ref root i) (if (present? (vector-ref root i))
(if elt (if elt
(make-intmap min shift root) (make-intmap min shift root)
(lp (1+ i) i)) (lp (1+ i) i))
@ -169,25 +180,24 @@
(define* (intmap-add! map i val #:optional (meet meet-error)) (define* (intmap-add! map i val #:optional (meet meet-error))
(define (ensure-branch! root idx) (define (ensure-branch! root idx)
(let ((edit (vector-ref root *edit-index*))) (let ((edit (vector-ref root *edit-index*))
(match (vector-ref root idx) (v (vector-ref root idx)))
(#f (let ((v (new-branch edit))) (if (absent? v)
(let ((v (new-branch edit)))
(vector-set! root idx v) (vector-set! root idx v)
v)) v)
(v (let ((v* (writable-branch v edit))) (let ((v* (writable-branch v edit)))
(unless (eq? v v*) (unless (eq? v v*)
(vector-set! root idx v*)) (vector-set! root idx v*))
v*))))) v*))))
(define (adjoin! i shift root) (define (adjoin! i shift root)
(let* ((shift (- shift *branch-bits*)) (let* ((shift (- shift *branch-bits*))
(idx (logand (ash i (- shift)) *branch-mask*))) (idx (logand (ash i (- shift)) *branch-mask*)))
(cond (if (zero? shift)
((zero? shift)
(let ((node (vector-ref root idx))) (let ((node (vector-ref root idx)))
(unless (eq? node val) (unless (eq? node val)
(vector-set! root idx (if node (meet node val) val))))) (vector-set! root idx (if (present? node) (meet node val) val))))
(else (adjoin! i shift (ensure-branch! root idx)))))
(adjoin! i shift (ensure-branch! root idx))))))
(match map (match map
(($ <transient-intmap> min shift root edit) (($ <transient-intmap> min shift root edit)
(assert-readable! edit) (assert-readable! edit)
@ -195,7 +205,7 @@
((< i 0) ((< i 0)
;; The power-of-two spanning trick doesn't work across 0. ;; The power-of-two spanning trick doesn't work across 0.
(error "Intmaps can only map non-negative integers." i)) (error "Intmaps can only map non-negative integers." i))
((not root) ((absent? root)
(set-transient-intmap-min! map i) (set-transient-intmap-min! map i)
(set-transient-intmap-shift! map 0) (set-transient-intmap-shift! map 0)
(set-transient-intmap-root! map val)) (set-transient-intmap-root! map val))
@ -230,30 +240,32 @@
(($ <intmap>) (($ <intmap>)
(intmap-add! (transient-intmap map) i val meet)))) (intmap-add! (transient-intmap map) i val meet))))
(define* (intmap-add bs i val #:optional (meet meet-error)) (define* (intmap-add map i val #:optional (meet meet-error))
(define (adjoin i shift root) (define (adjoin i shift root)
(cond (if (zero? shift)
((zero? shift)
(cond (cond
((eq? root val) root) ((eq? root val) root)
((not root) val) ((absent? root) val)
(else (meet root val)))) (else (meet root val)))
(else
(let* ((shift (- shift *branch-bits*)) (let* ((shift (- shift *branch-bits*))
(idx (logand (ash i (- shift)) *branch-mask*)) (idx (logand (ash i (- shift)) *branch-mask*)))
(node (and root (vector-ref root idx))) (if (absent? root)
(new-node (adjoin i shift node))) (let ((root* (new-branch #f))
(if (eq? node new-node) (node* (adjoin i shift root)))
(vector-set! root* idx node*)
root*)
(let* ((node (vector-ref root idx))
(node* (adjoin i shift node)))
(if (eq? node node*)
root root
(clone-branch-and-set root idx new-node)))))) (clone-branch-and-set root idx node*)))))))
(match bs (match map
(($ <intmap> min shift root) (($ <intmap> min shift root)
(cond (cond
((< i 0) ((< i 0)
;; The power-of-two spanning trick doesn't work across 0. ;; The power-of-two spanning trick doesn't work across 0.
(error "Intmaps can only map non-negative integers." i)) (error "Intmaps can only map non-negative integers." i))
((not val) (intmap-remove bs i)) ((absent? root)
((not root)
;; Add first element. ;; Add first element.
(make-intmap i 0 val)) (make-intmap i 0 val))
((and (<= min i) (< i (+ min (ash 1 shift)))) ((and (<= min i) (< i (+ min (ash 1 shift))))
@ -261,71 +273,75 @@
(let ((old-root root) (let ((old-root root)
(root (adjoin (- i min) shift root))) (root (adjoin (- i min) shift root)))
(if (eq? root old-root) (if (eq? root old-root)
bs map
(make-intmap min shift root)))) (make-intmap min shift root))))
((< i min) ((< i min)
;; Rebuild the tree by unioning two intmaps. ;; Rebuild the tree by unioning two intmaps.
(intmap-union (intmap-add empty-intmap i val error) bs error)) (intmap-union (intmap-add empty-intmap i val error) map error))
(else (else
;; Add a new level and try again. ;; Add a new level and try again.
(intmap-add (add-level min shift root) i val error)))) (intmap-add (add-level min shift root) i val error))))
(($ <transient-intmap>) (($ <transient-intmap>)
(intmap-add (persistent-intmap bs) i val meet)))) (intmap-add (persistent-intmap map) i val meet))))
(define (intmap-remove bs i) (define (intmap-remove map i)
(define (remove i shift root) (define (remove i shift root)
(cond (cond
((zero? shift) #f) ((zero? shift) *absent*)
(else (else
(let* ((shift (- shift *branch-bits*)) (let* ((shift (- shift *branch-bits*))
(idx (logand (ash i (- shift)) *branch-mask*))) (idx (logand (ash i (- shift)) *branch-mask*))
(cond (node (vector-ref root idx)))
((vector-ref root idx) (if (absent? node)
=> (lambda (node)
(let ((new-node (remove i shift node)))
(if (eq? node new-node)
root root
(let ((root (clone-branch-and-set root idx new-node))) (let ((node* (remove i shift node)))
(and (or new-node (not (branch-empty? root))) (if (eq? node node*)
root)))))) root
(else root)))))) (clone-branch-and-set root idx node*))))))))
(match bs (match map
(($ <intmap> min shift root) (($ <intmap> min shift root)
(cond (cond
((not root) bs) ((absent? root) map)
((and (<= min i) (< i (+ min (ash 1 shift)))) ((and (<= min i) (< i (+ min (ash 1 shift))))
;; Add element to map; level will not change. ;; Add element to map; level will not change.
(let ((old-root root) (let ((root* (remove (- i min) shift root)))
(root (remove (- i min) shift root))) (if (eq? root root*)
(if (eq? root old-root) map
bs (make-intmap/prune min shift root*))))
(make-intmap/prune min shift root)))) (else map)))
(else bs)))
(($ <transient-intmap>) (($ <transient-intmap>)
(intmap-remove (persistent-intmap bs) i)))) (intmap-remove (persistent-intmap map) i))))
(define (intmap-ref bs i) (define* (intmap-ref map i #:optional (not-found (lambda (i)
(error "not found" i))))
(define (ref min shift root) (define (ref min shift root)
(if (zero? shift) (if (zero? shift)
(and (= i min) root) (if (and min (= i min) (present? root))
(and (<= min i) (< i (+ min (ash 1 shift))) root
(not-found i))
(if (and (<= min i) (< i (+ min (ash 1 shift))))
(let ((i (- i min))) (let ((i (- i min)))
(let lp ((node root) (shift shift)) (let lp ((node root) (shift shift))
(and node (if (present? node)
(if (= shift *branch-bits*) (if (= shift *branch-bits*)
(vector-ref node (logand i *branch-mask*)) (let ((node (vector-ref node (logand i *branch-mask*))))
(if (present? node)
node
(not-found i)))
(let* ((shift (- shift *branch-bits*)) (let* ((shift (- shift *branch-bits*))
(idx (logand (ash i (- shift)) (idx (logand (ash i (- shift))
*branch-mask*))) *branch-mask*)))
(lp (vector-ref node idx) shift))))))))) (lp (vector-ref node idx) shift)))
(match bs (not-found i))))
(not-found i))))
(match map
(($ <intmap> min shift root) (($ <intmap> min shift root)
(ref min shift root)) (ref min shift root))
(($ <transient-intmap> min shift root edit) (($ <transient-intmap> min shift root edit)
(assert-readable! edit) (assert-readable! edit)
(ref min shift root)))) (ref min shift root))))
(define* (intmap-next bs #:optional i) (define* (intmap-next map #:optional i)
(define (visit-branch node shift i) (define (visit-branch node shift i)
(let lp ((i i) (idx (logand (ash i (- shift)) *branch-mask*))) (let lp ((i i) (idx (logand (ash i (- shift)) *branch-mask*)))
(and (< idx *branch-size*) (and (< idx *branch-size*)
@ -333,7 +349,7 @@
(let ((inc (ash 1 shift))) (let ((inc (ash 1 shift)))
(lp (+ (round-down i shift) inc) (1+ idx))))))) (lp (+ (round-down i shift) inc) (1+ idx)))))))
(define (visit-node node shift i) (define (visit-node node shift i)
(and node (and (present? node)
(if (zero? shift) (if (zero? shift)
i i
(visit-branch node (- shift *branch-bits*) i)))) (visit-branch node (- shift *branch-bits*) i))))
@ -344,21 +360,21 @@
(and (< i (ash 1 shift)) (and (< i (ash 1 shift))
(let ((i (visit-node root shift i))) (let ((i (visit-node root shift i)))
(and i (+ min i)))))) (and i (+ min i))))))
(match bs (match map
(($ <intmap> min shift root) (($ <intmap> min shift root)
(next min shift root)) (next min shift root))
(($ <transient-intmap> min shift root edit) (($ <transient-intmap> min shift root edit)
(assert-readable! edit) (assert-readable! edit)
(next min shift root)))) (next min shift root))))
(define* (intmap-prev bs #:optional i) (define* (intmap-prev map #:optional i)
(define (visit-branch node shift i) (define (visit-branch node shift i)
(let lp ((i i) (idx (logand (ash i (- shift)) *branch-mask*))) (let lp ((i i) (idx (logand (ash i (- shift)) *branch-mask*)))
(and (<= 0 idx) (and (<= 0 idx)
(or (visit-node (vector-ref node idx) shift i) (or (visit-node (vector-ref node idx) shift i)
(lp (1- (round-down i shift)) (1- idx)))))) (lp (1- (round-down i shift)) (1- idx))))))
(define (visit-node node shift i) (define (visit-node node shift i)
(and node (and (present? node)
(if (zero? shift) (if (zero? shift)
i i
(visit-branch node (- shift *branch-bits*) i)))) (visit-branch node (- shift *branch-bits*) i))))
@ -369,7 +385,7 @@
(and (<= 0 i) (and (<= 0 i)
(let ((i (visit-node root shift i))) (let ((i (visit-node root shift i)))
(and i (+ min i)))))) (and i (+ min i))))))
(match bs (match map
(($ <intmap> min shift root) (($ <intmap> min shift root)
(prev min shift root)) (prev min shift root))
(($ <transient-intmap> min shift root edit) (($ <transient-intmap> min shift root edit)
@ -384,7 +400,7 @@
(if (< i *branch-size*) (if (< i *branch-size*)
(let ((elt (vector-ref node i))) (let ((elt (vector-ref node i)))
(lp (1+ i) (lp (1+ i)
(if elt (if (present? elt)
(f (+ i min) elt seed) (f (+ i min) elt seed)
seed))) seed)))
seed)) seed))
@ -392,14 +408,14 @@
(if (< i *branch-size*) (if (< i *branch-size*)
(let ((elt (vector-ref node i))) (let ((elt (vector-ref node i)))
(lp (1+ i) (lp (1+ i)
(if elt (if (present? elt)
(visit-branch elt shift (+ min (ash i shift)) seed) (visit-branch elt shift (+ min (ash i shift)) seed)
seed))) seed)))
seed))))) seed)))))
(match map (match map
(($ <intmap> min shift root) (($ <intmap> min shift root)
(cond (cond
((not root) seed) ((absent? root) seed)
((zero? shift) (f min root seed)) ((zero? shift) (f min root seed))
(else (visit-branch root shift min seed)))) (else (visit-branch root shift min seed))))
(($ <transient-intmap>) (($ <transient-intmap>)
@ -455,8 +471,8 @@
(else a)))) (else a))))
(define (union shift a-node b-node) (define (union shift a-node b-node)
(cond (cond
((not a-node) b-node) ((absent? a-node) b-node)
((not b-node) a-node) ((absent? b-node) a-node)
((eq? a-node b-node) a-node) ((eq? a-node b-node) a-node)
((zero? shift) (meet a-node b-node)) ((zero? shift) (meet a-node b-node))
(else (union-branches (- shift *branch-bits*) a-node b-node)))) (else (union-branches (- shift *branch-bits*) a-node b-node))))
@ -494,7 +510,7 @@
(b-child (vector-ref b i))) (b-child (vector-ref b i)))
(vector-set! fresh i (intersect shift a-child b-child)) (vector-set! fresh i (intersect shift a-child b-child))
(lp (1+ i)))) (lp (1+ i))))
((branch-empty? fresh) #f) ((branch-empty? fresh) *absent*)
(else fresh)))) (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 eq? to A.
(define (intersect-branches/a shift a b i) (define (intersect-branches/a shift a b i)
@ -535,7 +551,7 @@
(else a)))) (else a))))
(define (intersect shift a-node b-node) (define (intersect shift a-node b-node)
(cond (cond
((or (not a-node) (not b-node)) #f) ((or (absent? a-node) (absent? b-node)) *absent*)
((eq? a-node b-node) a-node) ((eq? a-node b-node) a-node)
((zero? shift) (meet a-node b-node)) ((zero? shift) (meet a-node b-node))
(else (intersect-branches (- shift *branch-bits*) a-node b-node)))) (else (intersect-branches (- shift *branch-bits*) a-node b-node))))
@ -550,31 +566,29 @@
(else (else
(let* ((lo-shift (- lo-shift *branch-bits*)) (let* ((lo-shift (- lo-shift *branch-bits*))
(lo-idx (ash (- hi-min lo-min) (- lo-shift)))) (lo-idx (ash (- hi-min lo-min) (- lo-shift))))
(cond (if (>= lo-idx *branch-size*)
((>= lo-idx *branch-size*)
;; HI has a lower shift, but it not within LO. ;; HI has a lower shift, but it not within LO.
empty-intmap) empty-intmap
((vector-ref lo-root lo-idx) (let ((lo-root (vector-ref lo-root lo-idx)))
=> (lambda (lo-root) (if (absent? lo-root)
empty-intmap
(let ((lo (make-intmap (+ lo-min (ash lo-idx lo-shift)) (let ((lo (make-intmap (+ lo-min (ash lo-idx lo-shift))
lo-shift lo-shift
lo-root))) lo-root)))
(if lo-is-a? (if lo-is-a?
(intmap-intersect lo hi meet) (intmap-intersect lo hi meet)
(intmap-intersect hi lo meet))))) (intmap-intersect hi lo meet))))))))))
(else empty-intmap))))))
(define (different-shifts-same-min min hi-shift hi-root lo lo-is-a?) (define (different-shifts-same-min min hi-shift hi-root lo lo-is-a?)
(cond (let ((hi-root (vector-ref hi-root 0)))
((vector-ref hi-root 0) (if (absent? hi-root)
=> (lambda (hi-root) empty-intmap
(let ((hi (make-intmap min (let ((hi (make-intmap min
(- hi-shift *branch-bits*) (- hi-shift *branch-bits*)
hi-root))) hi-root)))
(if lo-is-a? (if lo-is-a?
(intmap-intersect lo hi meet) (intmap-intersect lo hi meet)
(intmap-intersect hi lo meet))))) (intmap-intersect hi lo meet))))))
(else empty-intmap)))
(match (cons a b) (match (cons a b)
((($ <intmap> a-min a-shift a-root) . ($ <intmap> b-min b-shift b-root)) ((($ <intmap> a-min a-shift a-root) . ($ <intmap> b-min b-shift b-root))

2
module/language/cps/types.scm
View file

@ -228,7 +228,7 @@
(define all-types-entry (make-type-entry &all-types -inf.0 +inf.0)) (define all-types-entry (make-type-entry &all-types -inf.0 +inf.0))
(define* (var-type-entry typeset var #:optional (default all-types-entry)) (define* (var-type-entry typeset var #:optional (default all-types-entry))
(or (intmap-ref typeset var) default)) (intmap-ref typeset var (lambda (_) default)))
(define (var-type typeset var) (define (var-type typeset var)
(type-entry-type (var-type-entry typeset var))) (type-entry-type (var-type-entry typeset var)))

14
module/language/cps2/renumber.scm
View file

@ -43,7 +43,7 @@
(define (compute-next labels lengths) (define (compute-next labels lengths)
(intset-fold (lambda (label labels) (intset-fold (lambda (label labels)
(fold1 (lambda (pred labels) (fold1 (lambda (pred labels)
(if (intmap-ref lengths pred) (if (intmap-ref lengths pred (lambda (_) #f))
labels labels
(intset-add! labels pred))) (intset-add! labels pred)))
(intmap-ref preds label) (intmap-ref preds label)
@ -78,8 +78,10 @@
;; to the tail first, so that if the branches are ;; to the tail first, so that if the branches are
;; unsorted, the longer path length will appear ;; unsorted, the longer path length will appear
;; first. This will move a loop exit out of a loop. ;; first. This will move a loop exit out of a loop.
(let ((k-len (intmap-ref path-lengths k)) (let ((k-len (intmap-ref path-lengths k
(kt-len (intmap-ref path-lengths kt))) (lambda (_) #f)))
(kt-len (intmap-ref path-lengths kt
(lambda (_) #f))))
(cond (cond
((if kt-len ((if kt-len
(or (not k-len) (or (not k-len)
@ -159,10 +161,8 @@
(define* (renumber conts #:optional (kfun 0)) (define* (renumber conts #:optional (kfun 0))
(let-values (((label-map var-map) (compute-renaming conts kfun))) (let-values (((label-map var-map) (compute-renaming conts kfun)))
(define (rename-label label) (define (rename-label label) (intmap-ref label-map label))
(or (intmap-ref label-map label) (error "what" label))) (define (rename-var var) (intmap-ref var-map var))
(define (rename-var var)
(or (intmap-ref var-map var) (error "what2" var)))
(define (rename-exp exp) (define (rename-exp exp)
(rewrite-exp exp (rewrite-exp exp
((or ($ $const) ($ $prim)) ,exp) ((or ($ $const) ($ $prim)) ,exp)

2
module/language/cps2/simplify.scm
View file

@ -197,7 +197,7 @@
(let* ((label-set (compute-beta-reductions conts kfun)) (let* ((label-set (compute-beta-reductions conts kfun))
(var-map (compute-beta-var-substitutions conts label-set))) (var-map (compute-beta-var-substitutions conts label-set)))
(define (subst var) (define (subst var)
(match (intmap-ref var-map var) (match (intmap-ref var-map var (lambda (_) #f))
(#f var) (#f var)
(val (subst val)))) (val (subst val))))
(define (transform-exp label k src exp) (define (transform-exp label k src exp)

3
module/language/tree-il/compile-cps2.scm
View file

@ -915,7 +915,8 @@ integer."
($ ((lambda (cps) ($ ((lambda (cps)
(let ((init (build-cont (let ((init (build-cont
($kfun (tree-il-src exp) '() init ktail kclause)))) ($kfun (tree-il-src exp) '() init ktail kclause))))
(with-cps (persistent-intmap (intmap-add! cps kinit init)) (with-cps (persistent-intmap (intmap-add! cps kinit init
(lambda (old new) new)))
kinit)))))))) kinit))))))))
(define *comp-module* (make-fluid)) (define *comp-module* (make-fluid))