From b9bcc1984aa9a82f45236f8b1415399e14d43a0e Mon Sep 17 00:00:00 2001 From: Nathan Froyd Date: Wed, 1 Jun 2005 13:41:40 +0000 Subject: [PATCH] 0.9.1.15: Improve modular arithmetic by: * Making bounds of (unsigned) modular function type derivation more precise; * Being less pessimistic when deriving bounds for LOGAND in the case when its arguments are known to be bounded and unsigned. As a bonus, LOGIOR type derivation in the same case is now more precise as well. The upshot of all this is that a function like: (defun foo (x y) (declare (type (integer 0 3) x y)) (mod (- (+ x 4) y) 4)) now uses only fixnum arithmetic. --- src/compiler/srctran.lisp | 119 ++++++++++++++++++++++++++++++++++++++++++--- version.lisp-expr | 2 +- 2 files changed, 114 insertions(+), 7 deletions(-) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 5e76032..f137b49 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -2131,6 +2131,59 @@ (or (null min) (minusp min)))) (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. + +(defun logand-derive-unsigned-low-bound (x y length) + (let ((mask (1- (ash 1 length))) + (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) + 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)))) + (when (<= temp b) + (setf a temp) + (loop-finish)) + (setf temp (logand (logior c m) + (logand (- m) mask))) + (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)) + (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) + until (zerop m) do + (cond + ((not (zerop (logand b + (logand (lognot d) mask) + m))) + (let ((temp (logior (logand b (lognot m) mask) + (- m 1)))) + (when (>= temp a) + (setf b temp) + (loop-finish)))) + ((not (zerop (logand (logand (lognot b) mask) + d + m))) + (let ((temp (logior (logand d (lognot b) mask) + (- m 1)))) + (when (>= temp c) + (setf d temp) + (loop-finish))))) + finally (return (logand b d))))) + (defun logand-derive-type-aux (x y &optional same-leaf) (when same-leaf (return-from logand-derive-type-aux x)) @@ -2149,7 +2202,10 @@ ((null y-len) (specifier-type `(unsigned-byte* ,x-len))) (t - (specifier-type `(unsigned-byte* ,(min x-len y-len))))) + (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))) + (specifier-type `(integer ,low ,high))))) ;; X is positive, but Y might be negative. (cond ((null x-len) (specifier-type 'unsigned-byte)) @@ -2168,6 +2224,52 @@ ;; 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)) + (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) + until (zerop m) do + (cond + ((not (zerop (logand (logand (lognot a mask)) + c + m))) + (let ((temp (logand (logior a m) (logand (- m) mask)))) + (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)))) + (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)) + (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) + until (zerop m) do + (unless (zerop (logand b d m)) + (let ((temp (logior (logand (- b m) mask) + (logand (1- m) mask)))) + (when (>= temp a) + (setf b temp) + (loop-finish)) + (setf temp (logior (logand (- d m) mask) + (logand (1- m) mask))) + (when (>= temp c) + (setf d temp) + (loop-finish)))) + finally (return (logior b d))))) + (defun logior-derive-type-aux (x y &optional same-leaf) (when same-leaf (return-from logior-derive-type-aux x)) @@ -2176,9 +2278,12 @@ (cond ((and (not x-neg) (not y-neg)) ;; Both are positive. - (specifier-type `(unsigned-byte* ,(if (and x-len y-len) - (max x-len y-len) - '*)))) + (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))) + (specifier-type `(integer ,low ,high))) + (specifier-type `(unsigned-byte* *)))) ((not x-pos) ;; X must be negative. (if (not y-pos) @@ -2575,7 +2680,8 @@ (fun (fun-info-derive-type info) :exit-if-null) (mask-type (specifier-type (ecase class - (:unsigned `(unsigned-byte* ,width)) + (:unsigned (let ((mask (1- (ash 1 width)))) + `(integer ,mask ,mask))) (:signed `(signed-byte ,width)))))) (lambda (call) (let ((res (funcall fun call))) @@ -2589,7 +2695,8 @@ (res (funcall fun call) :exit-if-null) (mask-type (specifier-type (ecase class - (:unsigned `(unsigned-byte* ,width)) + (:unsigned (let ((mask (1- (ash 1 width)))) + `(integer ,mask ,mask))) (:signed `(signed-byte ,width)))))) (if (eq class :unsigned) (logand-derive-type-aux res mask-type))))) diff --git a/version.lisp-expr b/version.lisp-expr index 25c65ff..9a41525 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.14" +"0.9.1.15" -- 1.7.10.4