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,
#+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)
#+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)
(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)
(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+)
(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))
\f
;;;; 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
\f
;;; 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
--(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")
\f
;;;; Unary operations.
(:translate lognot)
(:generator 1
(inst uaddcm zero-tn x res)))
--
--
\f
;;;; Binary fixnum operations.
(: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)
(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)
(:variant-cost 6))
\f
--;;;; 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)
#-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))
;;; 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)
(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))
(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))
;;; 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"
projects / sbcl.git / commitdiff