From 4a96ec6005851c044a36028c051e8beae82a7155 Mon Sep 17 00:00:00 2001 From: Nathan Froyd Date: Thu, 2 Jun 2005 04:02:07 +0000 Subject: [PATCH] 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. --- src/compiler/srctran.lisp | 168 +++++++++++++++++++++++++-------------------- tests/type.pure.lisp | 33 +++++++++ version.lisp-expr | 2 +- 3 files changed, 129 insertions(+), 74 deletions(-) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 982c382..369f705 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -2132,53 +2132,43 @@ (values nil t t))) ;;; See _Hacker's Delight_, Henry S. Warren, Jr. pp 58-63 for an -;;; explanation of {LOGAND,LOGIOR}-DERIVE-UNSIGNED-{LOW,HIGH}-BOUND. +;;; explanation of LOG{AND,IOR,XOR}-DERIVE-UNSIGNED-{LOW,HIGH}-BOUND. +;;; Credit also goes to Raymond Toy for writing (and debugging!) similar +;;; versions in CMUCL, from which these functions copy liberally. -(defun logand-derive-unsigned-low-bound (x y length) - (let ((mask (1- (ash 1 length))) - (a (numeric-type-low x)) +(defun logand-derive-unsigned-low-bound (x y) + (let ((a (numeric-type-low x)) (b (numeric-type-high x)) (c (numeric-type-low y)) (d (numeric-type-high y))) - (loop for m = (ash 1 (1- length)) then (ash m -1) + (loop for m = (ash 1 (integer-length (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) (loop-finish)) - (setf temp (logand (logior c m) - (logand (- m) mask))) + (setf temp (logandc2 (logior c m) (1- m))) (when (<= temp d) (setf c temp) (loop-finish)))) finally (return (logand a c))))) -(defun logand-derive-unsigned-high-bound (x y length) - (let ((mask (1- (ash 1 length))) - (a (numeric-type-low x)) +(defun logand-derive-unsigned-high-bound (x y) + (let ((a (numeric-type-low x)) (b (numeric-type-high x)) (c (numeric-type-low y)) (d (numeric-type-high y))) - (loop for m = (ash 1 (1- length)) then (ash m -1) + (loop for m = (ash 1 (integer-length (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) (loop-finish)))) - ((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) (loop-finish))))) @@ -2202,9 +2192,8 @@ ((null y-len) (specifier-type `(unsigned-byte* ,x-len))) (t - (let* ((length (max x-len y-len)) - (low (logand-derive-unsigned-low-bound x y length)) - (high (logand-derive-unsigned-high-bound x y length))) + (let ((low (logand-derive-unsigned-low-bound x y)) + (high (logand-derive-unsigned-high-bound x y))) (specifier-type `(integer ,low ,high))))) ;; X is positive, but Y might be negative. (cond ((null x-len) @@ -2224,47 +2213,39 @@ ;; We can't tell squat about the result. (specifier-type 'integer))))))) -(defun logior-derive-unsigned-low-bound (x y length) - (let ((mask (1- (ash 1 length))) - (a (numeric-type-low x)) +(defun logior-derive-unsigned-low-bound (x y) + (let ((a (numeric-type-low x)) (b (numeric-type-high x)) (c (numeric-type-low y)) (d (numeric-type-high y))) - (loop for m = (ash 1 (1- length)) then (ash m -1) + (loop for m = (ash 1 (integer-length (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) (loop-finish)))) - ((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) (loop-finish))))) finally (return (logior a c))))) -(defun logior-derive-unsigned-high-bound (x y length) - (let ((mask (1- (ash 1 length))) - (a (numeric-type-low x)) +(defun logior-derive-unsigned-high-bound (x y) + (let ((a (numeric-type-low x)) (b (numeric-type-high x)) (c (numeric-type-low y)) (d (numeric-type-high y))) - (loop for m = (ash 1 (1- length)) then (ash m -1) + (loop for m = (ash 1 (integer-length (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) (loop-finish)) - (setf temp (logior (logand (- d m) mask) - (logand (1- m) mask))) + (setf temp (logior (- d m) (1- m))) (when (>= temp c) (setf d temp) (loop-finish)))) @@ -2279,9 +2260,8 @@ ((and (not x-neg) (not y-neg)) ;; Both are positive. (if (and x-len y-len) - (let* ((length (max x-len y-len)) - (low (logior-derive-unsigned-low-bound x y length)) - (high (logior-derive-unsigned-high-bound x y length))) + (let ((low (logior-derive-unsigned-low-bound x y)) + (high (logior-derive-unsigned-high-bound x y))) (specifier-type `(integer ,low ,high))) (specifier-type `(unsigned-byte* *)))) ((not x-pos) @@ -2313,33 +2293,75 @@ ;; Unbounded. (specifier-type 'integer)))))))) +(defun logxor-derive-unsigned-low-bound (x y) + (let ((a (numeric-type-low x)) + (b (numeric-type-high x)) + (c (numeric-type-low y)) + (d (numeric-type-high y))) + (loop for m = (ash 1 (integer-length (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 logxor-derive-unsigned-high-bound (x y) + (let ((a (numeric-type-low x)) + (b (numeric-type-high x)) + (c (numeric-type-low y)) + (d (numeric-type-high y))) + (loop for m = (ash 1 (integer-length (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 logxor-derive-type-aux (x y &optional same-leaf) (when same-leaf (return-from logxor-derive-type-aux (specifier-type '(eql 0)))) (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x) (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y) (cond - ((or (and (not x-neg) (not y-neg)) - (and (not x-pos) (not y-pos))) - ;; Either both are negative or both are positive. The result - ;; will be positive, and as long as the longer. - (specifier-type `(unsigned-byte* ,(if (and x-len y-len) - (max x-len y-len) - '*)))) - ((or (and (not x-pos) (not y-neg)) - (and (not y-pos) (not x-neg))) - ;; Either X is negative and Y is positive or vice-versa. The - ;; result will be negative. - (specifier-type `(integer ,(if (and x-len y-len) - (ash -1 (max x-len y-len)) - '*) - -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 x-len y-len) - (specifier-type `(signed-byte ,(1+ (max x-len y-len))))) - (t - (specifier-type 'integer)))))) + ((and (not x-neg) (not y-neg)) + ;; Both are positive + (if (and x-len y-len) + (let ((low (logxor-derive-unsigned-low-bound x y)) + (high (logxor-derive-unsigned-high-bound x y))) + (specifier-type `(integer ,low ,high))) + (specifer-type '(unsigned-byte* *)))) + ((and (not x-pos) (not y-pos)) + ;; Both are negative. The result will be positive, and as long + ;; as the longer. + (specifier-type `(unsigned-byte* ,(if (and x-len y-len) + (max x-len y-len) + '*)))) + ((or (and (not x-pos) (not y-neg)) + (and (not y-pos) (not x-neg))) + ;; Either X is negative and Y is positive or vice-versa. The + ;; result will be negative. + (specifier-type `(integer ,(if (and x-len y-len) + (ash -1 (max x-len y-len)) + '*) + -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 x-len y-len) + (specifier-type `(signed-byte ,(1+ (max x-len y-len))))) + (t + (specifier-type 'integer)))))) (macrolet ((deffrob (logfun) (let ((fun-aux (symbolicate logfun "-DERIVE-TYPE-AUX"))) diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp index 0ea08e0..6a0351a 100644 --- a/tests/type.pure.lisp +++ b/tests/type.pure.lisp @@ -233,3 +233,36 @@ (type (type-of x))) (assert (subtypep type '(complex rational))) (assert (typep x type))) + +;;; Test derivation of LOG{AND,IOR,XOR} bounds for unsigned arguments. +;;; +;;; Fear the Loop of Doom! +(let* ((bits 5) + (size (ash 1 bits))) + (flet ((brute-force (a b c d op minimize) + (loop with extreme = (if minimize (ash 1 bits) 0) + with collector = (if minimize #'min #'max) + for i from a upto b do + (loop for j from c upto d do + (setf extreme (funcall collector + extreme + (funcall op i j)))) + finally (return extreme)))) + (dolist (op '(logand logior logxor)) + (dolist (minimize '(t nil)) + (let ((deriver (intern (format nil "~A-DERIVE-UNSIGNED-~:[HIGH~;LOW~]-BOUND" + op minimize) + (find-package :sb-c)))) + (loop for a from 0 below size do + (loop for b from a below size do + (loop for c from 0 below size do + (loop for d from c below size do + (let* ((brute (brute-force a b c d op minimize)) + (x-type (sb-c::specifier-type `(integer ,a ,b))) + (y-type (sb-c::specifier-type `(integer ,c ,d))) + (derived (funcall deriver x-type y-type))) + (unless (= brute derived) + (format t "FAIL: ~A [~D,~D] [~D,~D] ~A~% +ACTUAL ~D DERIVED ~D~%" + op a b c d minimize brute derived) + (assert (= brute derived))))))))))))) diff --git a/version.lisp-expr b/version.lisp-expr index f9e2c4d..57550e8 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.1.20" +"0.9.1.21" -- 1.7.10.4