Integrated Lispworks-specific optimizations, refactored types a bit.

This is based on the LW4.4 port of MD5 by Dmitriy Ivanov, with some
modernizations and fixes/updates for newer LW.

md5.lisp

@@ -66,16 +66,42 @@
   (defparameter *old-features* *features*)
   (pushnew sb-c:*backend-byte-order* *features*))
 
+#+(and :lispworks (or (not :lispworks4) :lispworks4.4))
+(eval-when (:compile-toplevel :execute)
+  (defparameter *old-features* *features*)
+  (pushnew :lw-int32 *features*))
+
 ;;; Section 2:  Basic Datatypes
 
 (deftype ub32 ()
   "Corresponds to the 32bit quantity word of the MD5 Spec"
-  `(unsigned-byte 32))
+  #+lw-int32 'sys:int32
+  #-lw-int32 '(unsigned-byte 32))
 
-(defmacro assemble-ub32 (a b c d)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defmacro assemble-ub32 (a b c d)
     "Assemble an ub32 value from the given (unsigned-byte 8) values,
 where a is the intended low-order byte and d the high-order byte."
-  `(the ub32 (logior (ash ,d 24) (ash ,c 16) (ash ,b 8) ,a)))
+    #+lw-int32
+    `(sys:int32-logior (sys:int32<< ,d 24)
+                       (sys:int32-logior (sys:int32<< ,c 16)
+                                         (sys:int32-logior (sys:int32<< ,b 8) ,a)))
+    #-lw-int32
+    `(the ub32 (logior (ash ,d 24) (ash ,c 16) (ash ,b 8) ,a))))
+
+(deftype ub32-vector (length)
+  #+lw-int32 `(sys:simple-int32-vector ,length)
+  #-lw-int32 `(simple-array (unsigned-byte 32) (,length)))
+
+(defmacro make-ub32-vector (length &rest args)
+  #+lw-int32 `(sys:make-simple-int32-vector ,length ,@args)
+  #-lw-int32 `(make-array ,length :element-type 'ub32 ,@args))
+
+(defmacro ub32-aref (vector index)
+  #+lw-int32
+  `(sys:int32-aref ,vector ,index)
+  #-lw-int32
+  `(aref ,vector ,index))
 
 ;;; Section 3.4:  Auxilliary functions
 
@@ -84,43 +110,53 @@ where a is the intended low-order byte and d the high-order byte."
 
 (defun f (x y z)
   (declare (type ub32 x y z)
-	   (optimize (speed 3) (safety 0) (space 0) (debug 0)))
+	   (optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32 (float 0)))
   #+cmu
   (kernel:32bit-logical-or (kernel:32bit-logical-and x y)
 			   (kernel:32bit-logical-andc1 x z))
-  #-cmu
+  #+lw-int32
+  (sys:int32-logior (sys:int32-logand x y) (sys:int32-logandc1 x z))
+  #-(or :cmu :lw-int32)
   (logior (logand x y) (logandc1 x z)))
 
 (defun g (x y z)
   (declare (type ub32 x y z)
-	   (optimize (speed 3) (safety 0) (space 0) (debug 0)))
+	   (optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32 (float 0)))
   #+cmu
   (kernel:32bit-logical-or (kernel:32bit-logical-and x z)
 			   (kernel:32bit-logical-andc2 y z))
-  #-cmu
+  #+lw-int32
+  (sys:int32-logior (sys:int32-logand x z) (sys:int32-logandc2 y z))
+  #-(or :cmu :lw-int32)
   (logior (logand x z) (logandc2 y z)))
 
 (defun h (x y z)
   (declare (type ub32 x y z)
-	   (optimize (speed 3) (safety 0) (space 0) (debug 0)))
+	   (optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32 (float 0)))
   #+cmu
   (kernel:32bit-logical-xor x (kernel:32bit-logical-xor y z))
-  #-cmu
+  #+lw-int32
+  (sys:int32-logxor x (sys:int32-logxor y z))
+  #-(or :cmu :lw-int32)
   (logxor x y z))
 
 (defun i (x y z)
   (declare (type ub32 x y z)
-	   (optimize (speed 3) (safety 0) (space 0) (debug 0)))
+	   (optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32 (float 0)))
   #+cmu
   (kernel:32bit-logical-xor y (kernel:32bit-logical-orc2 x z))
-  #-cmu
+  #+lw-int32
+  (sys:int32-logxor y (sys:int32-logorc2 x z))
+  #-(or :cmu :lw-int32)
   (ldb (byte 32 0) (logxor y (logorc2 x z))))
 
 (declaim (inline mod32+)
 	 (ftype (function (ub32 ub32) ub32) mod32+))
 (defun mod32+ (a b)
-  (declare (type ub32 a b) (optimize (speed 3) (safety 0) (space 0) (debug 0)))
+  (declare (type ub32 a b)
-  (ldb (byte 32 0) (+ a b)))
+           (optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32 (float 0)))
+  #+lw-int32 (sys:int32+ a b)
+  #-lw-int32 (ldb (byte 32 0) (+ a b)))
 
 #+cmu
 (define-compiler-macro mod32+ (a b)
@@ -132,18 +168,31 @@ where a is the intended low-order byte and d the high-order byte."
 (define-compiler-macro mod32+ (a b)
   `(ldb (byte 32 0) (+ ,a ,b)))
 
+#+lw-int32
+(declaim (inline int32>>logical)
+	 (ftype (function (sys:int32 (unsigned-byte 5)) sys:int32) int32>>logical))
+#+lw-int32
+(defun int32>>logical (a s)
+  (declare (type ub32 a) (type (unsigned-byte 5) s)
+           (optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32 (float 0)))
+  (if (sys:int32-minusp a)
+      (sys:int32-logandc2 (sys:int32>> a s) (sys:int32<< -1 (- 32 s)))
+      (sys:int32>> a s)))
+
 (declaim (inline rol32)
 	 (ftype (function (ub32 (unsigned-byte 5)) ub32) rol32))
 (defun rol32 (a s)
   (declare (type ub32 a) (type (unsigned-byte 5) s)
-	   (optimize (speed 3) (safety 0) (space 0) (debug 0)))
+	   (optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32 (float 0)))
   #+cmu
   (kernel:32bit-logical-or #+little-endian (kernel:shift-towards-end a s)
                            #+big-endian (kernel:shift-towards-start a s)
                            (ash a (- s 32)))
   #+sbcl
   (sb-rotate-byte:rotate-byte s (byte 32 0) a)
-  #-(or cmu sbcl)
+  #+lw-int32
+  (sys:int32-logior (sys:int32<< a s) (int32>>logical a (- 32 s)))
+  #-(or cmu sbcl lw-int32)
   (logior (ldb (byte 32 0) (ash a s)) (ash a (- s 32))))
 
 ;;; Section 3.4:  Table T
@@ -159,35 +208,54 @@ where a is the intended low-order byte and d the high-order byte."
 
 ;;; Section 3.4:  Helper Macro for single round definitions
 
+#-lw-int32
 (defmacro with-md5-round ((op block) &rest clauses)
   (loop for (a b c d k s i) in clauses
 	collect
 	`(setq ,a (mod32+ ,b (rol32 (mod32+ (mod32+ ,a (,op ,b ,c ,d))
-					    (mod32+ (aref ,block ,k)
+					    (mod32+ (ub32-aref ,block ,k)
 						    ,(aref *t* (1- i))))
 			            ,s)))
 	into result
 	finally
 	(return `(progn ,@result))))
 
+#+lw-int32
+(defmacro with-md5-round ((op block) &rest clauses)
+  (loop for (a b c d k s i) in clauses
+	collect
+	`(setq ,a (mod32+ ,b (rol32 (mod32+ (mod32+ ,a (,op ,b ,c ,d))
+					    (mod32+ (ub32-aref ,block ,k)
+						    (sys:integer-to-int32 
+                                                     ,(let ((t-val (aref *t* (1- i))))
+                                                        (dpb (ldb (byte 32 0) t-val)
+                                                             (byte 32 0) 
+                                                             (if (logbitp 31 t-val)
+                                                                 -1
+                                                                 0))))))
+			            ,s)))
+	into result
+	finally
+	(return `(progn ,@result))))
+
 ;;; Section 3.3:  (Initial) MD5 Working Set
 
 (deftype md5-regs ()
   "The working state of the MD5 algorithm, which contains the 4 32-bit
 registers A, B, C and D."
-  `(simple-array (unsigned-byte 32) (4)))
+  `(ub32-vector 4))
 
 (defmacro md5-regs-a (regs)
-  `(aref ,regs 0))
+  `(ub32-aref ,regs 0))
 
 (defmacro md5-regs-b (regs)
-  `(aref ,regs 1))
+  `(ub32-aref ,regs 1))
 
 (defmacro md5-regs-c (regs)
-  `(aref ,regs 2))
+  `(ub32-aref ,regs 2))
 
 (defmacro md5-regs-d (regs)
-  `(aref ,regs 3))
+  `(ub32-aref ,regs 3))
 
 (defconstant +md5-magic-a+ (assemble-ub32 #x01 #x23 #x45 #x67)
   "Initial value of Register A of the MD5 working state.")
@@ -201,8 +269,8 @@ registers A, B, C and D."
 (declaim (inline initial-md5-regs))
 (defun initial-md5-regs ()
   "Create the initial working state of an MD5 run."
-  (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)))
+  (declare (optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32 (float 0)))
-  (let ((regs (make-array 4 :element-type '(unsigned-byte 32))))
+  (let ((regs (make-ub32-vector 4)))
     (declare (type md5-regs regs))
     (setf (md5-regs-a regs) +md5-magic-a+
 	  (md5-regs-b regs) +md5-magic-b+
@@ -212,13 +280,17 @@ registers A, B, C and D."
 
 ;;; Section 3.4:  Operation on 16-Word Blocks
 
+(deftype md5-block ()
+  "The basic 16x32-bit word blocks that MD5 operates on."
+  `(ub32-vector 16))
+
 (defun update-md5-block (regs block)
   "This is the core part of the MD5 algorithm.  It takes a complete 16
 word block of input, and updates the working state in A, B, C, and D
 accordingly."
   (declare (type md5-regs regs)
-	   (type (simple-array ub32 (16)) block)
+	   (type md5-block block)
-	   (optimize (speed 3) (safety 0) (space 0) (debug 0)))
+	   (optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32 (float 0)))
   (let ((A (md5-regs-a regs)) (B (md5-regs-b regs))
 	(C (md5-regs-c regs)) (D (md5-regs-d regs)))
     (declare (type ub32 A B C D))
@@ -256,28 +328,14 @@ accordingly."
 ;;; Section 3.4:  Converting 8bit-vectors into 16-Word Blocks
 
 (declaim (inline fill-block fill-block-ub8 fill-block-char))
-(defun fill-block (block buffer offset)
-  "Convert a complete 64 byte input vector segment into the given 16
-word MD5 block.  This currently works on (unsigned-byte 8) and
-character simple-arrays, via the functions `fill-block-ub8' and
-`fill-block-char' respectively."
-  (declare (type (integer 0 #.(- most-positive-fixnum 64)) offset)
-	   (type (simple-array ub32 (16)) block)
-	   (type (simple-array * (*)) buffer)
-	   (optimize (speed 3) (safety 0) (space 0) (debug 0)))
-  (etypecase buffer
-    ((simple-array (unsigned-byte 8) (*))
-     (fill-block-ub8 block buffer offset))
-    (simple-string
-     (fill-block-char block buffer offset))))
-
 (defun fill-block-ub8 (block buffer offset)
   "Convert a complete 64 (unsigned-byte 8) input vector segment
 starting from offset into the given 16 word MD5 block."
   (declare (type (integer 0 #.(- most-positive-fixnum 64)) offset)
-	   (type (simple-array ub32 (16)) block)
+	   (type md5-block block)
 	   (type (simple-array (unsigned-byte 8) (*)) buffer)
-	   (optimize (speed 3) (safety 0) (space 0) (debug 0)))
+	   (optimize (speed 3) (safety 0) (space 0) (debug 0)
+                     #+lw-int32 (float 0) #+lw-int32 (hcl:fixnum-safety 0)))
   #+(and :cmu :little-endian)
   (kernel:bit-bash-copy
    buffer (+ (* vm:vector-data-offset vm:word-bits) (* offset vm:byte-bits))
@@ -290,7 +348,7 @@ starting from offset into the given 16 word MD5 block."
 	for j of-type (integer 0 #.most-positive-fixnum)
 	from offset to (+ offset 63) by 4
 	do
-	(setf (aref block i)
+	(setf (ub32-aref block i)
 	      (assemble-ub32 (aref buffer j)
 			     (aref buffer (+ j 1))
 			     (aref buffer (+ j 2))
@@ -300,9 +358,10 @@ starting from offset into the given 16 word MD5 block."
   "Convert a complete 64 character input string segment starting from
 offset into the given 16 word MD5 block."
   (declare (type (integer 0 #.(- most-positive-fixnum 64)) offset)
-	   (type (simple-array ub32 (16)) block)
+	   (type md5-block block)
 	   (type simple-string buffer)
-	   (optimize (speed 3) (safety 0) (space 0) (debug 0)))
+	   (optimize (speed 3) (safety 0) (space 0) (debug 0)
+                     #+lw-int32 (float 0) #+lw-int32 (hcl:fixnum-safety 0)))
   #+(and :cmu :little-endian)
   (kernel:bit-bash-copy
    buffer (+ (* vm:vector-data-offset vm:word-bits) (* offset vm:byte-bits))
@@ -315,26 +374,44 @@ offset into the given 16 word MD5 block."
 	for j of-type (integer 0 #.most-positive-fixnum)
 	from offset to (+ offset 63) by 4
 	do
-	(setf (aref block i)
+	(setf (ub32-aref block i)
 	      (assemble-ub32 (char-code (schar buffer j))
 			     (char-code (schar buffer (+ j 1)))
 			     (char-code (schar buffer (+ j 2)))
 			     (char-code (schar buffer (+ j 3)))))))
 
+(defun fill-block (block buffer offset)
+  "Convert a complete 64 byte input vector segment into the given 16
+word MD5 block.  This currently works on (unsigned-byte 8) and
+character simple-arrays, via the functions `fill-block-ub8' and
+`fill-block-char' respectively."
+  (declare (type (integer 0 #.(- most-positive-fixnum 64)) offset)
+	   (type md5-block block)
+	   (type (simple-array * (*)) buffer)
+	   (optimize (speed 3) (safety 0) (space 0) (debug 0)
+                     #+lw-int32 (float 0) #+lw-int32 (hcl:fixnum-safety 0)))
+  (etypecase buffer
+    ((simple-array (unsigned-byte 8) (*))
+     (fill-block-ub8 block buffer offset))
+    (simple-string
+     (fill-block-char block buffer offset))))
+
 ;;; Section 3.5:  Message Digest Output
 
 (declaim (inline md5regs-digest))
 (defun md5regs-digest (regs)
   "Create the final 16 byte message-digest from the MD5 working state
 in regs.  Returns a (simple-array (unsigned-byte 8) (16))."
-  (declare (optimize (speed 3) (safety 0) (space 0) (debug 0))
+  (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)
+                     #+lw-int32 (float 0) #+lw-int32 (hcl:fixnum-safety 0))
 	   (type md5-regs regs))
   (let ((result (make-array 16 :element-type '(unsigned-byte 8))))
     (declare (type (simple-array (unsigned-byte 8) (16)) result))
     (macrolet ((frob (reg offset)
 		 (let ((var (gensym)))
-		   `(let ((,var ,reg))
+		   `(let ((,var #+lw-int32 (sys:int32-to-integer ,reg)
-		      (declare (type ub32 ,var))
+                                #-lw-int32 ,reg))
+		      (declare (type (unsigned-byte 32) ,var))
 		      (setf
 		       (aref result ,offset) (ldb (byte 8 0) ,var)
 		       (aref result ,(+ offset 1)) (ldb (byte 8 8) ,var)
@@ -355,8 +432,7 @@ in regs.  Returns a (simple-array (unsigned-byte 8) (16))."
   (amount 0 :type
 	  #-md5-small-length (integer 0 *)
 	  #+md5-small-length (unsigned-byte 29))
-  (block (make-array 16 :element-type '(unsigned-byte 32)) :read-only t
+  (block (make-ub32-vector 16) :read-only t :type md5-block)
-	 :type (simple-array (unsigned-byte 32) (16)))
   (buffer (make-array 64 :element-type '(unsigned-byte 8)) :read-only t
 	 :type (simple-array (unsigned-byte 8) (64)))
   (buffer-index 0 :type (integer 0 63))
@@ -367,7 +443,8 @@ in regs.  Returns a (simple-array (unsigned-byte 8) (16))."
   "Copy a partial segment from input vector from starting at
 from-offset and copying count elements into the 64 byte buffer
 starting at buffer-offset."
-  (declare (optimize (speed 3) (safety 0) (space 0) (debug 0))
+  (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)
+                     #+lw-int32 (float 0) #+lw-int32 (hcl:fixnum-safety 0))
 	   (type (unsigned-byte 29) from-offset)
 	   (type (integer 0 63) count buffer-offset)
 	   (type (simple-array * (*)) from)
@@ -405,7 +482,8 @@ bounded by start and end, which must be numeric bounding-indices."
   (declare (type md5-state state)
 	   (type (simple-array * (*)) sequence)
 	   (type fixnum start end)
-	   (optimize (speed 3) (safety 1) (space 0) (debug 1)))
+	   (optimize (speed 3) (safety 1) (space 0) (debug 1)
+                     #+lw-int32 (float 0) #+lw-int32 (hcl:fixnum-safety 0)))
   (locally 
       (declare (optimize (safety 0) (debug 0)))
     (let ((regs (md5-state-regs state))
@@ -415,7 +493,7 @@ bounded by start and end, which must be numeric bounding-indices."
           (length (- end start)))
       (declare (type md5-regs regs) (type fixnum length)
                (type (integer 0 63) buffer-index)
-               (type (simple-array (unsigned-byte 32) (16)) block)
+               (type md5-block block)
                (type (simple-array (unsigned-byte 8) (64)) buffer))
       ;; Handle old rest
       (unless (zerop buffer-index)
@@ -478,7 +556,7 @@ The resulting MD5 message-digest is returned as an array of sixteen
 (unsigned-byte 8) values.  Calling `update-md5-state' after a call to
 `finalize-md5-state' results in unspecified behaviour."
   (declare (type md5-state state)
-	   (optimize (speed 3) (safety 1) (space 0) (debug 1)))
+	   (optimize (speed 3) (safety 1) (space 0) (debug 1) #+lw-int32 (float 0)))
   (locally
       (declare (optimize (safety 0) (debug 0)))
     (or (md5-state-finalized-p state)
@@ -489,7 +567,7 @@ The resulting MD5 message-digest is returned as an array of sixteen
               (total-length (* 8 (md5-state-amount state))))
           (declare (type md5-regs regs)
                    (type (integer 0 63) buffer-index)
-                   (type (simple-array ub32 (16)) block)
+                   (type md5-block block)
                    (type (simple-array (unsigned-byte 8) (*)) buffer))
           ;; Add mandatory bit 1 padding
           (setf (aref buffer buffer-index) #x80)
@@ -503,11 +581,11 @@ The resulting MD5 message-digest is returned as an array of sixteen
             (update-md5-block regs block)
             ;; Create new fully 0 padded block
             (loop for index of-type (integer 0 16) from 0 below 16
-                  do (setf (aref block index) #x00000000)))
+                  do (setf (ub32-aref block index) #x00000000)))
           ;; Add 64bit message bit length
-          (setf (aref block 14) (ldb (byte 32 0) total-length))
+          (setf (ub32-aref block 14) (ldb (byte 32 0) total-length))
           #-md5-small-length
-          (setf (aref block 15) (ldb (byte 32 32) total-length))
+          (setf (ub32-aref block 15) (ldb (byte 32 32) total-length))
           ;; Flush last block
           (update-md5-block regs block)
           ;; Done, remember digest for later calls
@@ -798,3 +876,7 @@ according to my additional test suite")
 #+sbcl
 (eval-when (:compile-toplevel :execute)
   (setq *features* *old-features*))
+
+#+(and :lispworks (or (not :lispworks4) :lispworks4.4))
+(eval-when (:compile-toplevel :execute)
+  (setq *features* *old-features*))