From: Lutz Euler <leuler@us...>  20130429 20:40:02

The branch "master" has been updated in SBCL: via 423b1f8cba83d16e57e852a51cf5d51ef709b2ed (commit) from a92a8d84d5b97d7504437bdcb04917162609a66c (commit)  Log  commit 423b1f8cba83d16e57e852a51cf5d51ef709b2ed Author: Lutz Euler <lutz.euler@...> Date: Mon Apr 29 22:35:01 2013 +0200 Split bitopsderivetype.lisp out of srctran.lisp. The moved part contains DERIVETYPE methods for LOGAND, LOGIOR, and friends. The split is motivated by srctran.lisp being too large and by planned changes to these type derivers.  buildorder.lispexpr  1 + src/compiler/bitopsderivetype.lisp  310 ++++++++++++++++++++++++++++++++++ src/compiler/srctran.lisp  299  3 files changed, 311 insertions(+), 299 deletions() diff git a/buildorder.lispexpr b/buildorder.lispexpr index 8b58ee1..0bab9bc 100644  a/buildorder.lispexpr +++ b/buildorder.lispexpr @@ 518,6 +518,7 @@ ("src/compiler/floattran") ("src/compiler/saptran") ("src/compiler/srctran") + ("src/compiler/bitopsderivetype") ("src/compiler/generic/vmtran") ("src/compiler/locall") ("src/compiler/dfo") diff git a/src/compiler/bitopsderivetype.lisp b/src/compiler/bitopsderivetype.lisp new file mode 100644 index 0000000..32d7ae0  /dev/null +++ b/src/compiler/bitopsderivetype.lisp @@ 0,0 +1,310 @@ +;;;; This file contains DERIVETYPE methods for LOGAND, LOGIOR, and +;;;; friends. + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(inpackage "SB!C") + +;;; Return the maximum number of bits an integer of the supplied type +;;; can take up, or NIL if it is unbounded. The second (third) value +;;; is T if the integer can be positive (negative) and NIL if not. +;;; Zero counts as positive. +(defun integertypelength (type) + (if (numerictypep type) + (let ((min (numerictypelow type)) + (max (numerictypehigh type))) + (values (and min max (max (integerlength min) (integerlength max))) + (or (null max) (not (minusp max))) + (or (null min) (minusp min)))) + (values nil t t))) + +;;; See _Hacker's Delight_, Henry S. Warren, Jr. pp 5863 for an +;;; 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) + (let ((a (numerictypelow x)) + (b (numerictypehigh x)) + (c (numerictypelow y)) + (d (numerictypehigh y))) + (loop for m = (ash 1 (integerlength (lognor a c))) then (ash m 1) + until (zerop m) do + (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 (logandc2 (logior c m) (1 m))) + (when (<= temp d) + (setf c temp) + (loopfinish)))) + finally (return (logand a c))))) + +(defun logandderiveunsignedhighbound (x y) + (let ((a (numerictypelow x)) + (b (numerictypehigh x)) + (c (numerictypelow y)) + (d (numerictypehigh y))) + (loop for m = (ash 1 (integerlength (logxor b d))) then (ash m 1) + until (zerop m) do + (cond + ((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 (lognot b) d m))) + (let ((temp (logior (logandc2 d m) (1 m)))) + (when (>= temp c) + (setf d temp) + (loopfinish))))) + finally (return (logand b d))))) + +(defun logandderivetypeaux (x y &optional sameleaf) + (when sameleaf + (returnfrom logandderivetypeaux x)) + (multiplevaluebind (xlen xpos xneg) (integertypelength x) + (declare (ignore xpos)) + (multiplevaluebind (ylen ypos yneg) (integertypelength y) + (declare (ignore ypos)) + (if (not xneg) + ;; X must be positive. + (if (not yneg) + ;; They must both be positive. + (cond ((and (null xlen) (null ylen)) + (specifiertype 'unsignedbyte)) + ((null xlen) + (specifiertype `(unsignedbyte* ,ylen))) + ((null ylen) + (specifiertype `(unsignedbyte* ,xlen))) + (t + (let ((low (logandderiveunsignedlowbound x y)) + (high (logandderiveunsignedhighbound x y))) + (specifiertype `(integer ,low ,high))))) + ;; X is positive, but Y might be negative. + (cond ((null xlen) + (specifiertype 'unsignedbyte)) + (t + (specifiertype `(unsignedbyte* ,xlen))))) + ;; X might be negative. + (if (not yneg) + ;; Y must be positive. + (cond ((null ylen) + (specifiertype 'unsignedbyte)) + (t (specifiertype `(unsignedbyte* ,ylen)))) + ;; Either might be negative. + (if (and xlen ylen) + ;; The result is bounded. + (specifiertype `(signedbyte ,(1+ (max xlen ylen)))) + ;; We can't tell squat about the result. + (specifiertype 'integer))))))) + +(defun logiorderiveunsignedlowbound (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) + (loopfinish)))) + ((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) + (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)))) + (when (>= temp a) + (setf b temp) + (loopfinish)) + (setf temp (logior ( d m) (1 m))) + (when (>= temp c) + (setf d temp) + (loopfinish)))) + finally (return (logior b d))))) + +(defun logiorderivetypeaux (x y &optional sameleaf) + (when sameleaf + (returnfrom logiorderivetypeaux x)) + (multiplevaluebind (xlen xpos xneg) (integertypelength x) + (multiplevaluebind (ylen ypos yneg) (integertypelength y) + (cond + ((and (not xneg) (not yneg)) + ;; Both are positive. + (if (and xlen ylen) + (let ((low (logiorderiveunsignedlowbound x y)) + (high (logiorderiveunsignedhighbound x y))) + (specifiertype `(integer ,low ,high))) + (specifiertype `(unsignedbyte* *)))) + ((not xpos) + ;; X must be negative. + (if (not ypos) + ;; Both are negative. The result is going to be negative + ;; and be the same length or shorter than the smaller. + (if (and xlen ylen) + ;; It's bounded. + (specifiertype `(integer ,(ash 1 (min xlen ylen)) 1)) + ;; It's unbounded. + (specifiertype '(integer * 1))) + ;; X is negative, but we don't know about Y. The result + ;; will be negative, but no more negative than X. + (specifiertype + `(integer ,(or (numerictypelow x) '*) + 1)))) + (t + ;; X might be either positive or negative. + (if (not ypos) + ;; But Y is negative. The result will be negative. + (specifiertype + `(integer ,(or (numerictypelow y) '*) + 1)) + ;; We don't know squat about either. It won't get any bigger. + (if (and xlen ylen) + ;; Bounded. + (specifiertype `(signedbyte ,(1+ (max xlen ylen)))) + ;; 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 + ((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))) + (specifiertype '(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"))) + `(defoptimizer (,logfun derivetype) ((x y)) + (twoargderivetype x y #',funaux #',logfun))))) + (deffrob logand) + (deffrob logior) + (deffrob logxor)) + +(defoptimizer (logeqv derivetype) ((x y)) + (twoargderivetype x y (lambda (x y sameleaf) + (lognotderivetypeaux + (logxorderivetypeaux x y sameleaf))) + #'logeqv)) +(defoptimizer (lognand derivetype) ((x y)) + (twoargderivetype x y (lambda (x y sameleaf) + (lognotderivetypeaux + (logandderivetypeaux x y sameleaf))) + #'lognand)) +(defoptimizer (lognor derivetype) ((x y)) + (twoargderivetype x y (lambda (x y sameleaf) + (lognotderivetypeaux + (logiorderivetypeaux x y sameleaf))) + #'lognor)) +(defoptimizer (logandc1 derivetype) ((x y)) + (twoargderivetype x y (lambda (x y sameleaf) + (if sameleaf + (specifiertype '(eql 0)) + (logandderivetypeaux + (lognotderivetypeaux x) y nil))) + #'logandc1)) +(defoptimizer (logandc2 derivetype) ((x y)) + (twoargderivetype x y (lambda (x y sameleaf) + (if sameleaf + (specifiertype '(eql 0)) + (logandderivetypeaux + x (lognotderivetypeaux y) nil))) + #'logandc2)) +(defoptimizer (logorc1 derivetype) ((x y)) + (twoargderivetype x y (lambda (x y sameleaf) + (if sameleaf + (specifiertype '(eql 1)) + (logiorderivetypeaux + (lognotderivetypeaux x) y nil))) + #'logorc1)) +(defoptimizer (logorc2 derivetype) ((x y)) + (twoargderivetype x y (lambda (x y sameleaf) + (if sameleaf + (specifiertype '(eql 1)) + (logiorderivetypeaux + x (lognotderivetypeaux y) nil))) + #'logorc2)) diff git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index f6369e6..298c8a6 100644  a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ 2393,305 +2393,6 @@ (defoptimizer (random derivetype) ((bound &optional state)) (oneargderivetype bound #'randomderivetypeaux nil)) ;;;; DERIVETYPE methods for LOGAND, LOGIOR, and friends  ;;; Return the maximum number of bits an integer of the supplied type ;;; can take up, or NIL if it is unbounded. The second (third) value ;;; is T if the integer can be positive (negative) and NIL if not. ;;; Zero counts as positive. (defun integertypelength (type)  (if (numerictypep type)  (let ((min (numerictypelow type))  (max (numerictypehigh type)))  (values (and min max (max (integerlength min) (integerlength max)))  (or (null max) (not (minusp max)))  (or (null min) (minusp min))))  (values nil t t)))  ;;; See _Hacker's Delight_, Henry S. Warren, Jr. pp 5863 for an ;;; 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)  (let ((a (numerictypelow x))  (b (numerictypehigh x))  (c (numerictypelow y))  (d (numerictypehigh y)))  (loop for m = (ash 1 (integerlength (lognor a c))) then (ash m 1)  until (zerop m) do  (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 (logandc2 (logior c m) (1 m)))  (when (<= temp d)  (setf c temp)  (loopfinish))))  finally (return (logand a c)))))  (defun logandderiveunsignedhighbound (x y)  (let ((a (numerictypelow x))  (b (numerictypehigh x))  (c (numerictypelow y))  (d (numerictypehigh y)))  (loop for m = (ash 1 (integerlength (logxor b d))) then (ash m 1)  until (zerop m) do  (cond  ((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 (lognot b) d m)))  (let ((temp (logior (logandc2 d m) (1 m))))  (when (>= temp c)  (setf d temp)  (loopfinish)))))  finally (return (logand b d)))))  (defun logandderivetypeaux (x y &optional sameleaf)  (when sameleaf  (returnfrom logandderivetypeaux x))  (multiplevaluebind (xlen xpos xneg) (integertypelength x)  (declare (ignore xpos))  (multiplevaluebind (ylen ypos yneg) (integertypelength y)  (declare (ignore ypos))  (if (not xneg)  ;; X must be positive.  (if (not yneg)  ;; They must both be positive.  (cond ((and (null xlen) (null ylen))  (specifiertype 'unsignedbyte))  ((null xlen)  (specifiertype `(unsignedbyte* ,ylen)))  ((null ylen)  (specifiertype `(unsignedbyte* ,xlen)))  (t  (let ((low (logandderiveunsignedlowbound x y))  (high (logandderiveunsignedhighbound x y)))  (specifiertype `(integer ,low ,high)))))  ;; X is positive, but Y might be negative.  (cond ((null xlen)  (specifiertype 'unsignedbyte))  (t  (specifiertype `(unsignedbyte* ,xlen)))))  ;; X might be negative.  (if (not yneg)  ;; Y must be positive.  (cond ((null ylen)  (specifiertype 'unsignedbyte))  (t (specifiertype `(unsignedbyte* ,ylen))))  ;; Either might be negative.  (if (and xlen ylen)  ;; The result is bounded.  (specifiertype `(signedbyte ,(1+ (max xlen ylen))))  ;; We can't tell squat about the result.  (specifiertype 'integer)))))))  (defun logiorderiveunsignedlowbound (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)  (loopfinish))))  ((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)  (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))))  (when (>= temp a)  (setf b temp)  (loopfinish))  (setf temp (logior ( d m) (1 m)))  (when (>= temp c)  (setf d temp)  (loopfinish))))  finally (return (logior b d)))))  (defun logiorderivetypeaux (x y &optional sameleaf)  (when sameleaf  (returnfrom logiorderivetypeaux x))  (multiplevaluebind (xlen xpos xneg) (integertypelength x)  (multiplevaluebind (ylen ypos yneg) (integertypelength y)  (cond  ((and (not xneg) (not yneg))  ;; Both are positive.  (if (and xlen ylen)  (let ((low (logiorderiveunsignedlowbound x y))  (high (logiorderiveunsignedhighbound x y)))  (specifiertype `(integer ,low ,high)))  (specifiertype `(unsignedbyte* *))))  ((not xpos)  ;; X must be negative.  (if (not ypos)  ;; Both are negative. The result is going to be negative  ;; and be the same length or shorter than the smaller.  (if (and xlen ylen)  ;; It's bounded.  (specifiertype `(integer ,(ash 1 (min xlen ylen)) 1))  ;; It's unbounded.  (specifiertype '(integer * 1)))  ;; X is negative, but we don't know about Y. The result  ;; will be negative, but no more negative than X.  (specifiertype  `(integer ,(or (numerictypelow x) '*)  1))))  (t  ;; X might be either positive or negative.  (if (not ypos)  ;; But Y is negative. The result will be negative.  (specifiertype  `(integer ,(or (numerictypelow y) '*)  1))  ;; We don't know squat about either. It won't get any bigger.  (if (and xlen ylen)  ;; Bounded.  (specifiertype `(signedbyte ,(1+ (max xlen ylen))))  ;; 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  ((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)))  (specifiertype '(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")))  `(defoptimizer (,logfun derivetype) ((x y))  (twoargderivetype x y #',funaux #',logfun)))))  (deffrob logand)  (deffrob logior)  (deffrob logxor))  (defoptimizer (logeqv derivetype) ((x y))  (twoargderivetype x y (lambda (x y sameleaf)  (lognotderivetypeaux  (logxorderivetypeaux x y sameleaf)))  #'logeqv)) (defoptimizer (lognand derivetype) ((x y))  (twoargderivetype x y (lambda (x y sameleaf)  (lognotderivetypeaux  (logandderivetypeaux x y sameleaf)))  #'lognand)) (defoptimizer (lognor derivetype) ((x y))  (twoargderivetype x y (lambda (x y sameleaf)  (lognotderivetypeaux  (logiorderivetypeaux x y sameleaf)))  #'lognor)) (defoptimizer (logandc1 derivetype) ((x y))  (twoargderivetype x y (lambda (x y sameleaf)  (if sameleaf  (specifiertype '(eql 0))  (logandderivetypeaux  (lognotderivetypeaux x) y nil)))  #'logandc1)) (defoptimizer (logandc2 derivetype) ((x y))  (twoargderivetype x y (lambda (x y sameleaf)  (if sameleaf  (specifiertype '(eql 0))  (logandderivetypeaux  x (lognotderivetypeaux y) nil)))  #'logandc2)) (defoptimizer (logorc1 derivetype) ((x y))  (twoargderivetype x y (lambda (x y sameleaf)  (if sameleaf  (specifiertype '(eql 1))  (logiorderivetypeaux  (lognotderivetypeaux x) y nil)))  #'logorc1)) (defoptimizer (logorc2 derivetype) ((x y))  (twoargderivetype x y (lambda (x y sameleaf)  (if sameleaf  (specifiertype '(eql 1))  (logiorderivetypeaux  x (lognotderivetypeaux y) nil)))  #'logorc2))  ;;;; miscellaneous derivetype methods (defoptimizer (integerlength derivetype) ((x))  hooks/postreceive  SBCL 