From: Nathan Froyd <nfroyd@us...>  20050602 04:02:18

Update of /cvsroot/sbcl/sbcl/src/compiler In directory sc8prcvs1.sourceforge.net:/tmp/cvsserv12117/src/compiler Modified Files: srctran.lisp Log Message: 0.9.1.21: * Add unsigned bounds derivers for LOGXOR, based on the ones present in CMUCL; * Convert existing unsigned bounds derivers to a more idiomatic CL style, eliminating unnecessary work along the way; * Belatedly add tests for bounds derivation. Index: srctran.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/srctran.lisp,v retrieving revision 1.122 retrieving revision 1.123 diff u d r1.122 r1.123  srctran.lisp 1 Jun 2005 22:31:35 0000 1.122 +++ srctran.lisp 2 Jun 2005 04:02:08 0000 1.123 @@ 2132,53 +2132,43 @@ (values nil t t))) ;;; See _Hacker's Delight_, Henry S. Warren, Jr. pp 5863 for an ;;; explanation of {LOGAND,LOGIOR}DERIVEUNSIGNED{LOW,HIGH}BOUND. +;;; explanation of LOG{AND,IOR,XOR}DERIVEUNSIGNED{LOW,HIGH}BOUND. +;;; Credit also goes to Raymond Toy for writing (and debugging!) similar +;;; versions in CMUCL, from which these functions copy liberally. (defun logandderiveunsignedlowbound (x y length)  (let ((mask (1 (ash 1 length)))  (a (numerictypelow x)) +(defun logandderiveunsignedlowbound (x y) + (let ((a (numerictypelow x)) (b (numerictypehigh x)) (c (numerictypelow y)) (d (numerictypehigh y)))  (loop for m = (ash 1 (1 length)) then (ash m 1) + (loop for m = (ash 1 (integerlength (lognor a c))) then (ash m 1) until (zerop m) do  (unless (zerop (logand (logand (lognot a) mask)  (logand (lognot c) mask)  m))  (let ((temp (logand (logior a m)  (logand ( m) mask)))) + (unless (zerop (logand m (lognot a) (lognot c))) + (let ((temp (logandc2 (logior a m) (1 m)))) (when (<= temp b) (setf a temp) (loopfinish))  (setf temp (logand (logior c m)  (logand ( m) mask))) + (setf temp (logandc2 (logior c m) (1 m))) (when (<= temp d) (setf c temp) (loopfinish)))) finally (return (logand a c))))) (defun logandderiveunsignedhighbound (x y length)  (let ((mask (1 (ash 1 length)))  (a (numerictypelow x)) +(defun logandderiveunsignedhighbound (x y) + (let ((a (numerictypelow x)) (b (numerictypehigh x)) (c (numerictypelow y)) (d (numerictypehigh y)))  (loop for m = (ash 1 (1 length)) then (ash m 1) + (loop for m = (ash 1 (integerlength (logxor b d))) then (ash m 1) until (zerop m) do (cond  ((not (zerop (logand b  (logand (lognot d) mask)  m)))  (let ((temp (logior (logand b (lognot m) mask)  ( m 1)))) + ((not (zerop (logand b (lognot d) m))) + (let ((temp (logior (logandc2 b m) (1 m)))) (when (>= temp a) (setf b temp) (loopfinish))))  ((not (zerop (logand (logand (lognot b) mask)  d  m)))  (let ((temp (logior (logand d (lognot m) mask)  ( m 1)))) + ((not (zerop (logand (lognot b) d m))) + (let ((temp (logior (logandc2 d m) (1 m)))) (when (>= temp c) (setf d temp) (loopfinish))))) @@ 2202,9 +2192,8 @@ ((null ylen) (specifiertype `(unsignedbyte* ,xlen))) (t  (let* ((length (max xlen ylen))  (low (logandderiveunsignedlowbound x y length))  (high (logandderiveunsignedhighbound x y length))) + (let ((low (logandderiveunsignedlowbound x y)) + (high (logandderiveunsignedhighbound x y))) (specifiertype `(integer ,low ,high))))) ;; X is positive, but Y might be negative. (cond ((null xlen) @@ 2224,47 +2213,39 @@ ;; We can't tell squat about the result. (specifiertype 'integer))))))) (defun logiorderiveunsignedlowbound (x y length)  (let ((mask (1 (ash 1 length)))  (a (numerictypelow x)) +(defun logiorderiveunsignedlowbound (x y) + (let ((a (numerictypelow x)) (b (numerictypehigh x)) (c (numerictypelow y)) (d (numerictypehigh y)))  (loop for m = (ash 1 (1 length)) then (ash m 1) + (loop for m = (ash 1 (integerlength (logxor a c))) then (ash m 1) until (zerop m) do (cond  ((not (zerop (logand (logand (lognot a) mask)  c  m)))  (let ((temp (logand (logior a m) (logand ( m) mask)))) + ((not (zerop (logandc2 (logand c m) a))) + (let ((temp (logand (logior a m) (1+ (lognot m))))) (when (<= temp b) (setf a temp) (loopfinish))))  ((not (zerop (logand a  (logand (lognot c) mask)  m)))  (let ((temp (logand (logior c m) (logand ( m) mask)))) + ((not (zerop (logandc2 (logand a m) c))) + (let ((temp (logand (logior c m) (1+ (lognot m))))) (when (<= temp d) (setf c temp) (loopfinish))))) finally (return (logior a c))))) (defun logiorderiveunsignedhighbound (x y length)  (let ((mask (1 (ash 1 length)))  (a (numerictypelow x)) +(defun logiorderiveunsignedhighbound (x y) + (let ((a (numerictypelow x)) (b (numerictypehigh x)) (c (numerictypelow y)) (d (numerictypehigh y)))  (loop for m = (ash 1 (1 length)) then (ash m 1) + (loop for m = (ash 1 (integerlength (logand b d))) then (ash m 1) until (zerop m) do (unless (zerop (logand b d m))  (let ((temp (logior (logand ( b m) mask)  (logand (1 m) mask)))) + (let ((temp (logior ( b m) (1 m)))) (when (>= temp a) (setf b temp) (loopfinish))  (setf temp (logior (logand ( d m) mask)  (logand (1 m) mask))) + (setf temp (logior ( d m) (1 m))) (when (>= temp c) (setf d temp) (loopfinish)))) @@ 2279,9 +2260,8 @@ ((and (not xneg) (not yneg)) ;; Both are positive. (if (and xlen ylen)  (let* ((length (max xlen ylen))  (low (logiorderiveunsignedlowbound x y length))  (high (logiorderiveunsignedhighbound x y length))) + (let ((low (logiorderiveunsignedlowbound x y)) + (high (logiorderiveunsignedhighbound x y))) (specifiertype `(integer ,low ,high))) (specifiertype `(unsignedbyte* *)))) ((not xpos) @@ 2313,33 +2293,75 @@ ;; Unbounded. (specifiertype 'integer)))))))) +(defun logxorderiveunsignedlowbound (x y) + (let ((a (numerictypelow x)) + (b (numerictypehigh x)) + (c (numerictypelow y)) + (d (numerictypehigh y))) + (loop for m = (ash 1 (integerlength (logxor a c))) then (ash m 1) + until (zerop m) do + (cond + ((not (zerop (logandc2 (logand c m) a))) + (let ((temp (logand (logior a m) + (1+ (lognot m))))) + (when (<= temp b) + (setf a temp)))) + ((not (zerop (logandc2 (logand a m) c))) + (let ((temp (logand (logior c m) + (1+ (lognot m))))) + (when (<= temp d) + (setf c temp))))) + finally (return (logxor a c))))) + +(defun logxorderiveunsignedhighbound (x y) + (let ((a (numerictypelow x)) + (b (numerictypehigh x)) + (c (numerictypelow y)) + (d (numerictypehigh y))) + (loop for m = (ash 1 (integerlength (logand b d))) then (ash m 1) + until (zerop m) do + (unless (zerop (logand b d m)) + (let ((temp (logior ( b m) (1 m)))) + (cond + ((>= temp a) (setf b temp)) + (t (let ((temp (logior ( d m) (1 m)))) + (when (>= temp c) + (setf d temp))))))) + finally (return (logxor b d))))) + (defun logxorderivetypeaux (x y &optional sameleaf) (when sameleaf (returnfrom logxorderivetypeaux (specifiertype '(eql 0)))) (multiplevaluebind (xlen xpos xneg) (integertypelength x) (multiplevaluebind (ylen ypos yneg) (integertypelength y) (cond  ((or (and (not xneg) (not yneg))  (and (not xpos) (not ypos)))  ;; Either both are negative or both are positive. The result  ;; will be positive, and as long as the longer.  (specifiertype `(unsignedbyte* ,(if (and xlen ylen)  (max xlen ylen)  '*))))  ((or (and (not xpos) (not yneg))  (and (not ypos) (not xneg)))  ;; Either X is negative and Y is positive or viceversa. The  ;; result will be negative.  (specifiertype `(integer ,(if (and xlen ylen)  (ash 1 (max xlen ylen))  '*)  1)))  ;; We can't tell what the sign of the result is going to be.  ;; All we know is that we don't create new bits.  ((and xlen ylen)  (specifiertype `(signedbyte ,(1+ (max xlen ylen)))))  (t  (specifiertype 'integer)))))) + ((and (not xneg) (not yneg)) + ;; Both are positive + (if (and xlen ylen) + (let ((low (logxorderiveunsignedlowbound x y)) + (high (logxorderiveunsignedhighbound x y))) + (specifiertype `(integer ,low ,high))) + (specifertype '(unsignedbyte* *)))) + ((and (not xpos) (not ypos)) + ;; Both are negative. The result will be positive, and as long + ;; as the longer. + (specifiertype `(unsignedbyte* ,(if (and xlen ylen) + (max xlen ylen) + '*)))) + ((or (and (not xpos) (not yneg)) + (and (not ypos) (not xneg))) + ;; Either X is negative and Y is positive or viceversa. The + ;; result will be negative. + (specifiertype `(integer ,(if (and xlen ylen) + (ash 1 (max xlen ylen)) + '*) + 1))) + ;; We can't tell what the sign of the result is going to be. + ;; All we know is that we don't create new bits. + ((and xlen ylen) + (specifiertype `(signedbyte ,(1+ (max xlen ylen))))) + (t + (specifiertype 'integer)))))) (macrolet ((deffrob (logfun) (let ((funaux (symbolicate logfun "DERIVETYPEAUX"))) 