;; from the following declarations. Probably you'll want to
;; disable these declarations when debugging consets.
(declare #-sb-xc-host (optimize (speed 3) (safety 0) (space 0)))
- (declaim (inline constraint-number))
- (defun constraint-number (constraint)
+ (declaim (inline %constraint-number))
+ (defun %constraint-number (constraint)
(sset-element-number constraint))
(defstruct (conset
(:constructor make-conset ())
:type simple-bit-vector)
;; Bit-vectors win over lightweight hashes for copy, union,
;; intersection, difference, but lose for iteration if you iterate
- ;; over the whole vector. Under some measurements in 2008, it
- ;; turned out that constraint sets elements were normally clumped
- ;; together: for compiling SBCL, the average difference between
- ;; the maximum and minimum constraint-number was 90 (with the
- ;; average constraint set having around 25 elements). So using
- ;; the minimum and maximum constraint-number for iteration bounds
- ;; makes iteration over a subrange of the bit-vector comparable to
- ;; iteration across the hash storage. Note that the CONSET-MIN is
- ;; NIL when the set is known to be empty. CONSET-MAX is a normal
- ;; end bounding index.
- (min nil :type (or fixnum null))
+ ;; over the whole vector. Tracking extrema helps a bit.
+ (min 0 :type fixnum)
(max 0 :type fixnum))
(defmacro do-conset-elements ((constraint conset &optional result) &body body)
(declare (ignore ,ignore))
(aver (<= ,end ,constraint-universe-end)))))
`(let* ((,vector (conset-vector ,conset))
- (,start (or (conset-min ,conset) 0))
+ (,start (conset-min ,conset))
(,end (min (conset-max ,conset) (length ,vector))))
(,@with-array-data
(do ((,index ,start (1+ ,index))) ((>= ,index ,end) ,result)
,@body)))
(defun conset-empty (conset)
- (or (null (conset-min conset))
+ (or (= (conset-min conset) (conset-max conset))
;; TODO: I bet FIND on bit-vectors can be optimized, if it
;; isn't.
(not (find 1 (conset-vector conset)
(values))
(defun conset-member (constraint conset)
- (let ((number (constraint-number constraint))
+ (let ((number (%constraint-number constraint))
(vector (conset-vector conset)))
(when (< number (length vector))
(plusp (sbit vector number)))))
(defun conset-adjoin (constraint conset)
(prog1
(not (conset-member constraint conset))
- (let ((number (constraint-number constraint)))
+ (let ((number (%constraint-number constraint)))
(conset-grow conset (1+ number))
(setf (sbit (conset-vector conset) number) 1)
- (setf (conset-min conset) (min number (or (conset-min conset)
- most-positive-fixnum)))
+ (setf (conset-min conset) (min number (conset-min conset)))
(when (>= number (conset-max conset))
(setf (conset-max conset) (1+ number))))))
(declare (simple-bit-vector vector1 vector2))
(setf (conset-vector conset-1) (,bit-op vector1 vector2 t))
;; Update the extrema.
- (setf (conset-min conset-1)
- ,(ecase name
- ((conset-union)
- `(min (or (conset-min conset-1)
- most-positive-fixnum)
- (or (conset-min conset-2)
- most-positive-fixnum)))
- ((conset-intersection)
- `(position 1 (conset-vector conset-1)
- :start
- (max (or (conset-min conset-1) 0)
- (or (conset-min conset-2) 0))
- :end (min (conset-max conset-1)
- (conset-max conset-1))))
- ((conset-difference)
- `(position 1 (conset-vector conset-1)
- :start (or (conset-min conset-1) 0)
- :end (conset-max conset-1)
- )))
- (conset-max conset-1)
- ,(ecase name
- ((conset-union)
- `(max (conset-max conset-1)
- (conset-max conset-2)))
- ((conset-intersection)
- `(let ((position
+ ,(ecase name
+ ((conset-union)
+ `(setf (conset-min conset-1)
+ (min (conset-min conset-1)
+ (conset-min conset-2))
+ (conset-max conset-1)
+ (max (conset-max conset-1)
+ (conset-max conset-2))))
+ ((conset-intersection)
+ `(let ((start (max (conset-min conset-1)
+ (conset-min conset-2)))
+ (end (min (conset-max conset-1)
+ (conset-max conset-2))))
+ (setf (conset-min conset-1)
+ (if (> start end)
+ 0
+ (or (position 1 (conset-vector conset-1)
+ :start start :end end)
+ 0))
+ (conset-max conset-1)
+ (if (> start end)
+ 0
+ (let ((position
+ (position
+ 1 (conset-vector conset-1)
+ :start start :end end :from-end t)))
+ (if position
+ (1+ position)
+ 0))))))
+ ((conset-difference)
+ `(setf (conset-min conset-1)
+ (or (position 1 (conset-vector conset-1)
+ :start (conset-min conset-1)
+ :end (conset-max conset-1))
+ 0)
+ (conset-max conset-1)
+ (let ((position
(position
1 (conset-vector conset-1)
- :start (let ((max
- (min (conset-max conset-1)
- (conset-max conset-2))))
- (if (plusp max)
- (1- max)
- 0))
- :end (conset-min conset-1)
- :from-end t)))
- (if position
- (1+ position)
- 0)))
- ((conset-difference)
- `(let ((position
- (position
- 1 (conset-vector conset-1)
- :start (let ((max (conset-max conset-1)))
- (if (plusp max)
- (1- max)
- 0))
- :end (or (conset-min conset-1) 0)
+ :start (conset-min conset-1)
+ :end (conset-max conset-1)
:from-end t)))
(if position
(1+ position)
(frob let)))))
;;; Return the constraints that flow from PRED to SUCC. This is
-;;; BLOCK-OUT unless PRED ends with and IF and test constraints were
+;;; BLOCK-OUT unless PRED ends with an IF and test constraints were
;;; added.
(defun block-out-for-successor (pred succ)
(declare (type cblock pred succ))
projects / sbcl.git / blobdiff