X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fconstraint.lisp;h=123322087a2616684c5ab3277112f45af78d7c7d;hb=cd12bb346dbbd1e077ed3e14a9db4e1cc227c244;hp=3d7bd357e09280254d6e9f6a85f5daefd7d08064;hpb=0c8643845555805048f50c783e118762e2c43a26;p=sbcl.git diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp index 3d7bd35..1233220 100644 --- a/src/compiler/constraint.lisp +++ b/src/compiler/constraint.lisp @@ -136,8 +136,8 @@ ;; 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 ()) @@ -149,22 +149,14 @@ :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) (with-unique-names (vector index start end - ignore constraint-universe-end) + #-sb-xc-host ignore + #-sb-xc-host constraint-universe-end) (let* ((constraint-universe #+sb-xc-host '*constraint-universe* #-sb-xc-host (gensym)) (with-array-data @@ -176,7 +168,7 @@ (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) @@ -193,7 +185,7 @@ ,@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) @@ -229,7 +221,7 @@ (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))))) @@ -237,11 +229,10 @@ (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)))))) @@ -280,54 +271,47 @@ (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) @@ -883,7 +867,7 @@ (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))