From: Christophe Rhodes <csr21@cam.ac.uk>
Date: Tue, 16 Sep 2003 12:07:39 +0000 (+0000)
Subject: 0.8.3.72:
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=dd357f3be290498fb7ef172696d986337f517a93;p=sbcl.git

0.8.3.72:
	Merge modular_arithmetic_branch
	... include untested modular arithmetic implementation for hppa
	... unkludge sb-md5: now implemented using natural, high-level
		lisp.  (and as a bonus, compiles to shorter code on x86
		at least).
	... passes self-tests and pfdietz-tests on x86 at least.
		More exhaustive testing on other platforms is probably
		needed, maybe with the torturer
---

dd357f3be290498fb7ef172696d986337f517a93
diff --cc contrib/sb-md5/README
index 9155f29,9155f29..f44c306
--- a/contrib/sb-md5/README
+++ b/contrib/sb-md5/README
@@@ -21,11 -21,11 +21,12 @@@ Notes
      ROTATE-BYTE on other platforms are welcome.
  
    * the algorithm includes an addition modulo 2^32.  This is
--    implemented here by (ab)using SB-EXT:TRULY-THE, to convince the
--    compiler to emit the low-level addition instruction.  This has the
--    desired consequences on 32-bit hardware, but may not work as one
--    might expect on 64-bit hardware, even if the overlying lisp is
--    32-bit.
++    implemented here for SBCL by compiler transforms on the high-level
++    description of this modular arithmetic, so although the code looks
++    like a naive implementation it actually compiles to the obvious
++    machine code.  The abuse of EXT:TRULY-THE was not robust and
++    turned out not to work on platforms where the underlying hardware
++    was 64-bit.
  
    * the "high-level" entry points to the md5 algorithm are
      MD5SUM-FILE, MD5SUM-STREAM and MD5SUM-SEQUENCE (despite its name,
diff --cc contrib/sb-md5/md5.lisp
index e362f74,e362f74..aa37da6
--- a/contrib/sb-md5/md5.lisp
+++ b/contrib/sb-md5/md5.lisp
@@@ -81,10 -81,10 +81,7 @@@ where a is the intended low-order byte 
    #+cmu
    (kernel:32bit-logical-or (kernel:32bit-logical-and x y)
  			   (kernel:32bit-logical-andc1 x z))
--  #+sbcl
--  (sb-kernel:32bit-logical-or (sb-kernel:32bit-logical-and x y)
--			      (sb-kernel:32bit-logical-andc1 x z))
--  #-(or cmu sbcl)
++  #-cmu
    (logior (logand x y) (logandc1 x z)))
  
  (defun g (x y z)
@@@ -93,10 -93,10 +90,7 @@@
    #+cmu
    (kernel:32bit-logical-or (kernel:32bit-logical-and x z)
  			   (kernel:32bit-logical-andc2 y z))
--  #+sbcl
--  (sb-kernel:32bit-logical-or (sb-kernel:32bit-logical-and x z)
--			      (sb-kernel:32bit-logical-andc2 y z))
--  #-(or cmu sbcl)
++  #-cmu
    (logior (logand x z) (logandc2 y z)))
  
  (defun h (x y z)
@@@ -104,9 -104,9 +98,7 @@@
  	   (optimize (speed 3) (safety 0) (space 0) (debug 0)))
    #+cmu
    (kernel:32bit-logical-xor x (kernel:32bit-logical-xor y z))
--  #+sbcl
--  (sb-kernel:32bit-logical-xor x (sb-kernel:32bit-logical-xor y z))  
--  #-(or cmu sbcl)
++  #-cmu
    (logxor x y z))
  
  (defun i (x y z)
@@@ -114,9 -114,9 +106,7 @@@
  	   (optimize (speed 3) (safety 0) (space 0) (debug 0)))
    #+cmu
    (kernel:32bit-logical-xor y (kernel:32bit-logical-orc2 x z))
--  #+sbcl
--  (sb-kernel:32bit-logical-xor y (sb-kernel:32bit-logical-orc2 x z))  
--  #-(or cmu sbcl)
++  #-cmu
    (ldb (byte 32 0) (logxor y (logorc2 x z))))
  
  (declaim (inline mod32+)
@@@ -129,11 -129,11 +119,11 @@@
  (define-compiler-macro mod32+ (a b)
    `(ext:truly-the ub32 (+ ,a ,b)))
  
++;;; Dunno why we need this, but without it MOD32+ wasn't being
++;;; inlined.  Oh well.  -- CSR, 2003-09-14
  #+sbcl
--;;; FIXME: Check whether this actually does the right thing on the
--;;; alpha.
  (define-compiler-macro mod32+ (a b)
--  `(sb-ext:truly-the ub32 (+ ,a ,b)))
++  `(ldb (byte 32 0) (+ ,a ,b)))
  
  (declaim (inline rol32)
  	 (ftype (function (ub32 (unsigned-byte 5)) ub32) rol32))
diff --cc src/compiler/generic/vm-tran.lisp
index 8280a8d,82627cf..9365c72
--- a/src/compiler/generic/vm-tran.lisp
+++ b/src/compiler/generic/vm-tran.lisp
@@@ -440,27 -440,27 +440,9 @@@
  
  
  ;;;; 32-bit operations
- #!-x86 ; on X86 it is a modular function
- (deftransform lognot ((x) ((unsigned-byte 32)) *
-                       :node node
-                       :result result)
-   "32-bit implementation"
-   (let ((dest (lvar-dest result)))
-     (unless (and (combination-p dest)
-                  (eq (lvar-fun-name (combination-fun dest))
-                      'logand))
-       (give-up-ir1-transform))
-     (unless (some (lambda (arg)
-                     (csubtypep (lvar-type arg)
-                                (specifier-type '(unsigned-byte 32))))
-                   (combination-args dest))
-       (give-up-ir1-transform))
-     (setf (node-derived-type node)
-           (values-specifier-type '(values (unsigned-byte 32) &optional)))
-     '(32bit-logical-not x)))
- 
 -#!-(or ppc sparc x86 mips alpha) ; on X86 it is a modular function
 -(deftransform lognot ((x) ((unsigned-byte 32)) *
 -                      :node node
 -                      :result result)
 -  "32-bit implementation"
 -  (let ((dest (continuation-dest result)))
 -    (unless (and (combination-p dest)
 -                 (eq (continuation-fun-name (combination-fun dest))
 -                     'logand))
 -      (give-up-ir1-transform))
 -    (unless (some (lambda (arg)
 -                    (csubtypep (continuation-type arg)
 -                               (specifier-type '(unsigned-byte 32))))
 -                  (combination-args dest))
 -      (give-up-ir1-transform))
 -    (setf (node-derived-type node)
 -          (values-specifier-type '(values (unsigned-byte 32) &optional)))
 -    '(32bit-logical-not x)))
 -
  (define-good-modular-fun logand)
  (define-good-modular-fun logior)
++;;; FIXME: XOR? ANDC1, ANDC2?  -- CSR, 2003-09-16
  
  ;;; There are two different ways the multiplier can be recoded. The
  ;;; more obvious is to shift X by the correct amount for each bit set
diff --cc src/compiler/hppa/arith.lisp
index 73cc856,73cc856..d47fc76
--- a/src/compiler/hppa/arith.lisp
+++ b/src/compiler/hppa/arith.lisp
@@@ -1,6 -1,6 +1,15 @@@
--(in-package "SB!VM")
++;;;; the VM definition arithmetic VOPs for HPPA
  
++;;;; 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.
  
++(in-package "SB!VM")
  
  ;;;; Unary operations.
  
@@@ -42,8 -42,8 +51,6 @@@
    (:translate lognot)
    (:generator 1
      (inst uaddcm zero-tn x res)))
--
--
  
  ;;;; Binary fixnum operations.
  
@@@ -82,7 -82,7 +89,7 @@@
    (:affected)
    (:policy :fast-safe))
  
--(defmacro define-binop (translate cost untagged-cost op)
++(defmacro define-binop (translate cost untagged-cost op &optional arg-swap)
    `(progn
       (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
  		  fast-fixnum-binop)
@@@ -90,26 -90,26 +97,33 @@@
  	      (y :target r :scs (any-reg)))
         (:translate ,translate)
         (:generator ,cost
--	 (inst ,op x y r)))
++	 ,(if arg-swap
++	      `(inst ,op y x r)
++	      `(inst ,op x y r))))
       (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
  		  fast-signed-binop)
         (:args (x :target r :scs (signed-reg))
  	      (y :target r :scs (signed-reg)))
         (:translate ,translate)
         (:generator ,untagged-cost
--	 (inst ,op x y r)))
++	 ,(if arg-swap
++	      `(inst ,op y x r)
++	      `(inst ,op x y r))))
       (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED")
  		  fast-unsigned-binop)
         (:args (x :target r :scs (unsigned-reg))
  	      (y :target r :scs (unsigned-reg)))
         (:translate ,translate)
         (:generator ,untagged-cost
--	 (inst ,op x y r)))))
++	 ,(if arg-swap
++	      `(inst ,op y x r)
++	      `(inst ,op x y r))))))
  
  (define-binop + 2 6 add)
  (define-binop - 2 6 sub)
  (define-binop logior 1 2 or)
  (define-binop logand 1 2 and)
++(define-binop logandc1 1 2 andcm t)
  (define-binop logandc2 1 2 andcm)
  (define-binop logxor 1 2 xor)
  
@@@ -562,61 -562,61 +576,87 @@@
    (:variant-cost 6))
    
  
--;;;; 32-bit logical operations
--
--(define-vop (32bit-logical)
--  (:args (x :scs (unsigned-reg))
--	 (y :scs (unsigned-reg)))
--  (:arg-types unsigned-num unsigned-num)
--  (:results (r :scs (unsigned-reg)))
--  (:result-types unsigned-num)
--  (:policy :fast-safe))
--
--(define-vop (32bit-logical-not 32bit-logical)
--  (:translate 32bit-logical-not)
++;;;; modular functions
++(define-modular-fun +-mod32 (x y) + 32)
++(define-vop (fast-+-mod32/unsigned=>unsigned fast-+/unsigned=>unsigned)
++  (:translate +-mod32))
++(define-vop (fast-+-mod32-c/unsigned=>unsigned fast-+-c/unsigned=>unsigned)
++  (:translate +-mod32))
++
++(define-modular-fun lognot-mod32 (x) lognot 32)
++(define-vop (lognot-mod32/unsigned=>unsigned)
++  (:translate lognot-mod32)
    (:args (x :scs (unsigned-reg)))
    (:arg-types unsigned-num)
++  (:results (res :scs (unsigned-reg)))
++  (:result-types unsigned-num)
++  (:policy :fast-safe)
    (:generator 1
--    (inst uaddcm zero-tn x r)))
++    (inst uaddcm zero-tn x res)))
  
--(define-vop (32bit-logical-and 32bit-logical)
--  (:translate 32bit-logical-and)
--  (:generator 1
--    (inst and x y r)))
++(macrolet
++    ((define-modular-backend (fun)
++       (let ((mfun-name (symbolicate fun '-mod32))
++	     ;; FIXME: if anyone cares, add constant-arg vops.  --
++	     ;; CSR, 2003-09-16
++	     (modvop (symbolicate 'fast- fun '-mod32/unsigned=>unsigned))
++	     (vop (symbolicate 'fast- fun '/unsigned=>unsigned)))
++	 `(progn
++	    (define-modular-fun ,mfun-name (x y) ,fun 32)
++	    (define-vop (,modvop ,vop)
++	      (:translate ,mfun-name))))))
++  (define-modular-backend logxor)
++  (define-modular-backend logandc1)
++  (define-modular-backend logandc2))
++
++(define-source-transform logeqv (&rest args)
++  (if (oddp (length args))
++      `(logxor ,@args)
++      `(lognot (logxor ,@args))))
++(define-source-transform logorc1 (x y)
++  `(logior (lognot ,x) ,y))
++(define-source-transform logorc2 (x y)
++  `(logior ,x (lognot ,y)))
++(define-source-transform lognand (x y)
++  `(lognot (logand ,x ,y)))
++(define-source-transform lognor (x y)
++  `(lognot (logior ,x y)))
++   
++;;;; 32-bit logical operations
  
--(deftransform 32bit-logical-nand ((x y) (* *))
--  '(32bit-logical-not (32bit-logical-and x y)))
++(define-source-transform 32bit-logical-not (x)
++  `(logand (lognot (the (unsigned-byte 32) ,x)) #.(1- (ash 1 32))))
  
--(define-vop (32bit-logical-or 32bit-logical)
--  (:translate 32bit-logical-or)
--  (:generator 1
--    (inst or x y r)))
++(deftransform 32bit-logical-and ((x y))
++  '(logand x y))
  
--(deftransform 32bit-logical-nor ((x y) (* *))
--  '(32bit-logical-not (32bit-logical-or x y)))
++(define-source-transform 32bit-logical-nand (x y)
++  `(32bit-logical-not (32bit-logical-and ,x ,y)))
  
--(define-vop (32bit-logical-xor 32bit-logical)
--  (:translate 32bit-logical-xor)
--  (:generator 1
--    (inst xor x y r)))
++(deftransform 32bit-logical-or ((x y))
++  '(logior x y))
  
--(deftransform 32bit-logical-eqv ((x y) (* *))
--  '(32bit-logical-not (32bit-logical-xor x y)))
++(define-source-transform 32bit-logical-nor (x y)
++  `(logand (lognor (the (unsigned-byte 32) ,x) (the (unsigned-byte 32) ,y))
++           #.(1- (ash 1 32))))
  
--(deftransform 32bit-logical-andc1 ((x y) (* *))
--  '(32bit-logical-and (32bit-logical-not x) y))
++(deftransform 32bit-logical-xor ((x y))
++  '(logxor x y))
  
--(define-vop (32bit-logical-andc2 32bit-logical)
--  (:translate 32bit-logical-andc2)
--  (:generator 1
--    (inst andcm x y r)))
++(define-source-transform 32bit-logical-eqv (x y)
++  `(32bit-logical-not (32bit-logical-xor ,x ,y)))
++
++(define-source-transform 32bit-logical-orc1 (x y)
++  `(32bit-logical-or (32bit-logical-not ,x) ,y))
  
--(deftransform 32bit-logical-orc1 ((x y) (* *))
--  '(32bit-logical-or (32bit-logical-not x) y))
++(define-source-transform 32bit-logical-orc2 (x y)
++  `(32bit-logical-or ,x (32bit-logical-not ,y)))
  
--(deftransform 32bit-logical-orc2 ((x y) (* *))
--  '(32bit-logical-or x (32bit-logical-not y)))
++(deftransform 32bit-logical-andc1 (x y)
++  '(logandc1 x y))
  
++(deftransform 32bit-logical-andc2 (x y)
++  '(logandc2 x y))
  
  (define-vop (shift-towards-someplace)
    (:policy :fast-safe)
diff --cc src/compiler/srctran.lisp
index 48eeb34,a435801..0482f1b
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@@ -172,21 -172,9 +172,15 @@@
    #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
    (deffrob ceiling))
  
- (define-source-transform lognand (x y) `(lognot (logand ,x ,y)))
- (define-source-transform lognor (x y) `(lognot (logior ,x ,y)))
- (define-source-transform logandc1 (x y) `(logand (lognot ,x) ,y))
- (define-source-transform logandc2 (x y) `(logand ,x (lognot ,y)))
- (define-source-transform logorc1 (x y) `(logior (lognot ,x) ,y))
- (define-source-transform logorc2 (x y) `(logior ,x (lognot ,y)))
  (define-source-transform logtest (x y) `(not (zerop (logand ,x ,y))))
 -(define-source-transform logbitp (index integer)
 -  `(not (zerop (logand (ash 1 ,index) ,integer))))
 +
 +(deftransform logbitp
 +    ((index integer) (unsigned-byte (or (signed-byte #.sb!vm:n-word-bits)
 +					(unsigned-byte #.sb!vm:n-word-bits))))
 +  `(if (>= index #.sb!vm:n-word-bits)
 +       (minusp integer)
 +       (not (zerop (logand integer (ash 1 index))))))
 +
  (define-source-transform byte (size position)
    `(cons ,size ,position))
  (define-source-transform byte-size (spec) `(car ,spec))
@@@ -729,21 -750,24 +723,25 @@@
  ;;; the types of both X and Y are integer types, then we compute a new
  ;;; integer type with bounds determined Fun when applied to X and Y.
  ;;; Otherwise, we use Numeric-Contagion.
+ (defun derive-integer-type-aux (x y fun)
+   (declare (type function fun))
+   (if (and (numeric-type-p x) (numeric-type-p y)
+ 	   (eq (numeric-type-class x) 'integer)
+ 	   (eq (numeric-type-class y) 'integer)
+ 	   (eq (numeric-type-complexp x) :real)
+ 	   (eq (numeric-type-complexp y) :real))
+       (multiple-value-bind (low high) (funcall fun x y)
+ 	(make-numeric-type :class 'integer
+ 			   :complexp :real
+ 			   :low low
+ 			   :high high))
+       (numeric-contagion x y)))
++
  (defun derive-integer-type (x y fun)
 -  (declare (type continuation x y) (type function fun))
 -  (let ((x (continuation-type x))
 -	(y (continuation-type y)))
 +  (declare (type lvar x y) (type function fun))
 +  (let ((x (lvar-type x))
 +	(y (lvar-type y)))
-     (if (and (numeric-type-p x) (numeric-type-p y)
- 	     (eq (numeric-type-class x) 'integer)
- 	     (eq (numeric-type-class y) 'integer)
- 	     (eq (numeric-type-complexp x) :real)
- 	     (eq (numeric-type-complexp y) :real))
- 	(multiple-value-bind (low high) (funcall fun x y)
- 	  (make-numeric-type :class 'integer
- 			     :complexp :real
- 			     :low low
- 			     :high high))
- 	(numeric-contagion x y))))
+     (derive-integer-type-aux x y fun)))
  
  ;;; simple utility to flatten a list
  (defun flatten-list (x)
@@@ -1339,16 -1360,19 +1337,19 @@@
    (defoptimizer (%negate derive-type) ((num))
      (derive-integer-type num num (frob -))))
  
+ (defun lognot-derive-type-aux (int)
+   (derive-integer-type-aux int int
+ 			   (lambda (type type2)
+ 			     (declare (ignore type2))
+ 			     (let ((lo (numeric-type-low type))
+ 				   (hi (numeric-type-high type)))
+ 			       (values (if hi (lognot hi) nil)
+ 				       (if lo (lognot lo) nil)
+ 				       (numeric-type-class type)
+ 				       (numeric-type-format type))))))
+ 
  (defoptimizer (lognot derive-type) ((int))
-   (derive-integer-type int int
- 		       (lambda (type type2)
- 			 (declare (ignore type2))
- 			 (let ((lo (numeric-type-low type))
- 			       (hi (numeric-type-high type)))
- 			   (values (if hi (lognot hi) nil)
- 				   (if lo (lognot lo) nil)
- 				   (numeric-type-class type)
- 				   (numeric-type-format type))))))
 -  (lognot-derive-type-aux (continuation-type int)))
++  (lognot-derive-type-aux (lvar-type int)))
  
  #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
  (defoptimizer (%negate derive-type) ((num))
@@@ -2172,12 -2206,14 +2173,12 @@@
  	    (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.
 -	(if (and x-len y-len (zerop x-len) (zerop y-len))
 -	    (specifier-type '(integer 0 0))
 -	    (specifier-type `(unsigned-byte ,(if (and x-len y-len)
 -					     (max x-len y-len)
 -					     '*)))))
 +	(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-neg) (not y-pos)))
- 	;; Either X is negative and Y is positive of vice-versa. The
+ 	;; 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))
diff --cc version.lisp-expr
index 69a5faa,2218577..3d711d5
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@@ -17,4 -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.8.3.71"
 -"0.8.3.45.modular7"
++"0.8.3.72"