diff --git a/md5.lisp b/md5.lisp index 10c95e4..b6f4ed5 100644 --- a/md5.lisp +++ b/md5.lisp @@ -1,16 +1,20 @@ (defpackage :MD5 (:use :CL) - (:export #:+md5-magic-a+ #:+md5-magic-b+ #:+md5-magic-c+ #:+md5-magic-d+ - ;; Low-Level functions - #:md5sum-update #:md5sum-final #:md5sum-checksum - ;; Low-Level functions on character buffers - #:md5sum-update-char #:md5sum-final-char - ;; Mid-Level functions - #:make-md5-state #:update-md5-state #:finalize-md5-state - ;; High-Level functions on streams/files - #:md5sum-char-stream #:md5sum-byte-stream #:md5sum-file)) + (:export + ;; Low-Level types and functions + #:md5-regs #:initial-md5-regs #:md5regs-checksum + #:update-md5-block #:fill-block #:fill-block-ub8 #:fill-block-char + ;; Mid-Level types and functions + #:md5-state #:md5-state-p #:make-md5-state + #:update-md5-state #:finalize-md5-state + ;; High-Level functions on streams/files + #:md5sum-stream #:md5sum-file)) (in-package :MD5) +(eval-when (:compile-toplevel) + (defparameter *old-expansion-limit* ext:*inline-expansion-limit*) + (setq ext:*inline-expansion-limit* (max ext:*inline-expansion-limit* 1000))) + ;;; Section 3.4: Auxilliary functions (deftype ub32 () `(unsigned-byte 32)) @@ -84,12 +88,45 @@ finally (return `(progn ,@result)))) -(defun update-md5-block (a b c d block) - (declare (type ub32 a b c d) +;; Block-level operations + +(deftype md5-regs () `(simple-array (unsigned-byte 32) (4))) + +(defmacro md5-regs-a (regs) + `(aref ,regs 0)) + +(defmacro md5-regs-b (regs) + `(aref ,regs 1)) + +(defmacro md5-regs-c (regs) + `(aref ,regs 2)) + +(defmacro md5-regs-d (regs) + `(aref ,regs 3)) + +(defconstant +md5-magic-a+ #x67452301) +(defconstant +md5-magic-b+ #xefcdab89) +(defconstant +md5-magic-c+ #x98badcfe) +(defconstant +md5-magic-d+ #x10325476) + +(declaim (inline initial-md5-regs)) +(defun initial-md5-regs () + (declare (optimize (speed 3) (safety 0) (space 0) (debug 0))) + (let ((regs (make-array 4 :element-type '(unsigned-byte 32)))) + (declare (type md5-regs regs)) + (setf (md5-regs-a regs) +md5-magic-a+ + (md5-regs-b regs) +md5-magic-b+ + (md5-regs-c regs) +md5-magic-c+ + (md5-regs-d regs) +md5-magic-d+) + regs)) + +(defun update-md5-block (regs block) + (declare (type md5-regs regs) (type (simple-array ub32 (16)) block) (optimize (speed 3) (safety 0) (space 0) (debug 0))) - (let ((old-a a) (old-b b) (old-c c) (old-d d)) - (declare (type ub32 old-a old-b old-c old-d)) + (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)) ;; Round 1 (with-md5-round (f block) (A B C D 0 7 1)(D A B C 1 12 2)(C D A B 2 17 3)(B C D A 3 22 4) @@ -115,21 +152,31 @@ (A B C D 8 6 57)(D A B C 15 10 58)(C D A B 6 15 59)(B C D A 13 21 60) (A B C D 4 6 61)(D A B C 11 10 62)(C D A B 2 15 63)(B C D A 9 21 64)) ;; Update and return - (values - (mod32+ old-a a) - (mod32+ old-b b) - (mod32+ old-c c) - (mod32+ old-d d)))) + (setf (md5-regs-a regs) (mod32+ (md5-regs-a regs) a) + (md5-regs-b regs) (mod32+ (md5-regs-b regs) b) + (md5-regs-c regs) (mod32+ (md5-regs-c regs) c) + (md5-regs-d regs) (mod32+ (md5-regs-d regs) d)) + regs)) -(defconstant +md5-magic-a+ #x67452301) -(defconstant +md5-magic-b+ #xefcdab89) -(defconstant +md5-magic-c+ #x98badcfe) -(defconstant +md5-magic-d+ #x10325476) - -;; Low-level drivers - -(declaim (inline fill-block fill-block-char)) +(declaim (inline fill-block fill-block-ub8 fill-block-char)) (defun fill-block (block buffer offset) + (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))) + #+(and cmu x86) + (kernel:bit-bash-copy + buffer (+ (* vm:vector-data-offset vm:word-bits) (* offset vm:byte-bits)) + block (* vm:vector-data-offset vm:word-bits) + (* 64 vm:byte-bits)) + #-(and cmu x86) + (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) (declare (type (integer 0 #.(- most-positive-fixnum 64)) offset) (type (simple-array ub32 (16)) block) (type (simple-array (unsigned-byte 8) (*)) buffer) @@ -153,12 +200,7 @@ (aref buffer (+ j 2)) 16) (kernel:shift-towards-end (aref buffer (+ j 1)) 8) - (aref buffer j))) - #+NIL - (dpb (aref buffer (+ j 3)) (byte 8 24) - (dpb (aref buffer (+ j 2)) (byte 8 16) - (dpb (aref buffer (+ j 1)) (byte 8 8) - (aref buffer j))))))) + (aref buffer j)))))) (defun fill-block-char (block buffer offset) (declare (type (integer 0 #.(- most-positive-fixnum 64)) offset) @@ -186,107 +228,32 @@ (char-code (schar buffer (+ j 1))) 8) (char-code (schar buffer j))))))) -(declaim (inline md5sum-update md5sum-final - md5sum-update-char md5sum-final-char)) -(defun md5sum-update (a b c d block buffer offset) +(declaim (inline md5regs-checksum)) +(defun md5regs-checksum (regs) (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)) - (type ub32 a b c d) - (type (integer 0 #.(- most-positive-fixnum 64)) offset) - (type (simple-array ub32 (16)) block) - (type (simple-array (unsigned-byte 8) (*)) buffer)) - (fill-block block buffer offset) - (update-md5-block a b c d block)) - -(defun md5sum-final (a b c d block buffer offset bytes total-length) - (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)) - (type ub32 a b c d) - (type (unsigned-byte 29) total-length) - (type (integer 0 #.(- most-positive-fixnum 64)) offset) - (type (integer 0 63) bytes) - (type (simple-array ub32 (16)) block) - (type (simple-array (unsigned-byte 8) (*)) buffer)) - (setf (aref buffer (+ offset bytes)) #x80) - (loop for index of-type (integer 0 #.most-positive-fixnum) - from (+ offset bytes 1) to (+ offset 63) - do (setf (aref buffer index) #x00)) - (fill-block block buffer offset) - (when (< bytes 56) - (setf (aref block 14) (* total-length 8))) - (multiple-value-bind (a b c d) - (update-md5-block a b c d block) - (if (< 56 bytes 64) - (progn - (loop for index of-type (integer 0 16) from 0 to 15 - do (setf (aref block index) #x00000000)) - (setf (aref block 14) (* total-length 8)) - (update-md5-block a b c d block)) - (values a b c d)))) - -(defun md5sum-update-char (a b c d block buffer offset) - (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)) - (type ub32 a b c d) - (type (integer 0 #.(- most-positive-fixnum 64)) offset) - (type (simple-array ub32 (16)) block) - (type simple-string buffer)) - (fill-block-char block buffer offset) - (update-md5-block a b c d block)) - -(defun md5sum-final-char (a b c d block buffer offset bytes total-length) - (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)) - (type ub32 a b c d) - (type (unsigned-byte 29) total-length) - (type (integer 0 #.(- most-positive-fixnum 64)) offset) - (type (integer 0 63) bytes) - (type (simple-array ub32 (16)) block) - (type simple-string buffer)) - (setf (schar buffer (+ offset bytes)) (code-char #x80)) - (loop for index of-type (integer 0 #.most-positive-fixnum) - from (+ offset bytes 1) to (+ offset 63) - do (setf (schar buffer index) (code-char #x00))) - (fill-block-char block buffer offset) - (when (< bytes 56) - (setf (aref block 14) (* total-length 8))) - (multiple-value-bind (a b c d) - (update-md5-block a b c d block) - (if (< 56 bytes 64) - (progn - (loop for index of-type (integer 0 16) from 0 to 15 - do (setf (aref block index) #x00000000)) - (setf (aref block 14) (* total-length 8)) - (update-md5-block a b c d block)) - (values a b c d)))) - -(defun md5sum-checksum (a b c d) - (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)) - (type ub32 a b c d)) - (make-array 16 :element-type '(unsigned-byte 8) - :initial-contents - (list - (ldb (byte 8 0) a) - (ldb (byte 8 8) a) - (ldb (byte 8 16) a) - (ldb (byte 8 24) a) - (ldb (byte 8 0) b) - (ldb (byte 8 8) b) - (ldb (byte 8 16) b) - (ldb (byte 8 24) b) - (ldb (byte 8 0) c) - (ldb (byte 8 8) c) - (ldb (byte 8 16) c) - (ldb (byte 8 24) c) - (ldb (byte 8 0) d) - (ldb (byte 8 8) d) - (ldb (byte 8 16) d) - (ldb (byte 8 24) d)))) + (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)) + (declare (type ub32 ,var)) + (setf + (aref result ,offset) (ldb (byte 8 0) ,var) + (aref result ,(+ offset 1)) (ldb (byte 8 8) ,var) + (aref result ,(+ offset 2)) (ldb (byte 8 16) ,var) + (aref result ,(+ offset 3)) (ldb (byte 8 24) ,var)))))) + (frob (md5-regs-a regs) 0) + (frob (md5-regs-b regs) 4) + (frob (md5-regs-c regs) 8) + (frob (md5-regs-d regs) 12)) + result)) ;; Mid-Level Drivers (defstruct (md5-state (:constructor make-md5-state ())) - (a +md5-magic-a+ :type (unsigned-byte 32)) - (b +md5-magic-b+ :type (unsigned-byte 32)) - (c +md5-magic-c+ :type (unsigned-byte 32)) - (d +md5-magic-d+ :type (unsigned-byte 32)) + (regs (initial-md5-regs) :type md5-regs :read-only t) (amount 0 :type (unsigned-byte 29)) (block (make-array 16 :element-type '(unsigned-byte 32)) :read-only t :type (simple-array (unsigned-byte 32) (16))) @@ -298,7 +265,7 @@ (declaim (inline copy-to-buffer)) (defun copy-to-buffer (from from-offset count buffer buffer-offset) (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)) - (type fixnum from-offset) + (type (unsigned-byte 29) from-offset) (type (integer 0 63) count buffer-offset) (type (simple-array * (*)) from) (type (simple-array (unsigned-byte 8) (64)) buffer)) @@ -309,31 +276,32 @@ (* buffer-offset vm:byte-bits)) (* count vm:byte-bits)) #-(and cmu x86) - (if (typep from 'simple-string) - (loop for buffer-index of-type (integer 0 64) from buffer-offset - for from-index of-type fixnum from from-offset - below (+ from-offset count) - do - (setf (aref buffer buffer-index) - (char-code (schar from from-index)))) - (loop for buffer-index of-type (integer 0 64) from buffer-offset - for from-index of-type fixnum from from-offset - below (+ from-offset count) - do - (setf (aref buffer buffer-index) (aref from from-index))))) + (etypecase from + (simple-string + (loop for buffer-index of-type (integer 0 64) from buffer-offset + for from-index of-type fixnum from from-offset + below (+ from-offset count) + do + (setf (aref buffer buffer-index) + (char-code (schar from from-index))))) + ((simple-array (unsigned-byte 8) (*)) + (loop for buffer-index of-type (integer 0 64) from buffer-offset + for from-index of-type fixnum from from-offset + below (+ from-offset count) + do + (setf (aref buffer buffer-index) (aref from from-index)))))) (defun update-md5-state (state sequence &key (start 0) (end (length sequence))) (declare (type md5-state state) (type (simple-array * (*)) sequence) (type fixnum start end) (optimize (speed 3) (space 0) (debug 0))) - (let ((a (md5-state-a state)) (b (md5-state-b state)) - (c (md5-state-c state)) (d (md5-state-d state)) + (let ((regs (md5-state-regs state)) (block (md5-state-block state)) (buffer (md5-state-buffer state)) (buffer-index (md5-state-buffer-index state)) (length (- end start))) - (declare (type ub32 a b c d) (type fixnum length) + (declare (type md5-regs regs) (type fixnum length) (type (integer 0 63) buffer-index) (type (simple-array (unsigned-byte 32) (16)) block) (type (simple-array (unsigned-byte 8) (64)) buffer)) @@ -342,9 +310,12 @@ (let ((amount (min (- 64 buffer-index) length))) (declare (type (integer 0 63) amount)) (copy-to-buffer sequence start amount buffer buffer-index) - (setq start (the fixnum (+ start amount)))) - (multiple-value-setq (a b c d) - (md5sum-update a b c d block buffer 0))) + (setq start (the fixnum (+ start amount))) + (when (>= start end) + (setf (md5-state-buffer-index state) (+ buffer-index amount)) + (return-from update-md5-state state))) + (fill-block-ub8 block buffer 0) + (update-md5-block regs block)) ;; Handle main-part and new-rest (etypecase sequence ((simple-array (unsigned-byte 8) (*)) @@ -352,8 +323,9 @@ (declare (type (simple-array (unsigned-byte 8) (*)) sequence)) (loop for offset of-type (unsigned-byte 29) from start below end by 64 until (< (- end offset) 64) - do (multiple-value-setq (a b c d) - (md5sum-update a b c d block sequence offset)) + do + (fill-block-ub8 block sequence offset) + (update-md5-block regs block) finally (let ((amount (- end offset))) (unless (zerop amount) @@ -364,37 +336,46 @@ (declare (type simple-string sequence)) (loop for offset of-type (unsigned-byte 29) from start below end by 64 until (< (- end offset) 64) - do (multiple-value-setq (a b c d) - (md5sum-update-char a b c d block sequence offset)) + do + (fill-block-char block sequence offset) + (update-md5-block regs block) finally (let ((amount (- end offset))) (unless (zerop amount) (copy-to-buffer sequence offset amount buffer 0)) (setf (md5-state-buffer-index state) amount)))))) - (setf (md5-state-a state) a - (md5-state-b state) b - (md5-state-c state) c - (md5-state-d state) d - (md5-state-amount state) (+ (md5-state-amount state) length)) + (setf (md5-state-amount state) (+ (md5-state-amount state) length)) state)) (defun finalize-md5-state (state) (declare (type md5-state state) (optimize (speed 3) (space 0) (debug 0))) (or (md5-state-finalized-p state) - (multiple-value-bind (a b c d) - (md5sum-final (md5-state-a state) (md5-state-b state) - (md5-state-c state) (md5-state-d state) - (md5-state-block state) - (md5-state-buffer state) - 0 (md5-state-buffer-index state) - (md5-state-amount state)) - (setf (md5-state-a state) a - (md5-state-b state) b - (md5-state-c state) c - (md5-state-d state) d - (md5-state-finalized-p state) - (md5sum-checksum a b c d))))) + (let ((regs (md5-state-regs state)) + (block (md5-state-block state)) + (buffer (md5-state-buffer state)) + (buffer-index (md5-state-buffer-index state)) + (total-length (md5-state-amount state))) + (declare (type md5-regs regs) + (type (unsigned-byte 29) total-length) + (type (integer 0 63) buffer-index) + (type (simple-array ub32 (16)) block) + (type (simple-array (unsigned-byte 8) (*)) buffer)) + (setf (aref buffer buffer-index) #x80) + (loop for index of-type (integer 0 64) + from (1+ buffer-index) below 64 + do (setf (aref buffer index) #x00)) + (fill-block-ub8 block buffer 0) + (when (< buffer-index 56) + (setf (aref block 14) (* total-length 8))) + (update-md5-block regs block) + (when (< 56 buffer-index 64) + (loop for index of-type (integer 0 16) from 0 below 16 + do (setf (aref block index) #x00000000)) + (setf (aref block 14) (* total-length 8)) + (update-md5-block regs block)) + (setf (md5-state-finalized-p state) + (md5regs-checksum regs))))) ;; High-Level Drivers @@ -402,65 +383,36 @@ (deftype buffer-index () `(integer 0 ,+buffer-size+)) -(defun md5sum-byte-stream (stream) - (declare (type stream) - (optimize (speed 3) (space 0) (debug 0))) - (let ((block (make-array 16 :element-type 'ub32)) - (buffer (make-array +buffer-size+ :element-type '(unsigned-byte 8))) - (length 0) - (a +md5-magic-a+) (b +md5-magic-b+) - (c +md5-magic-c+) (d +md5-magic-d+)) - (declare (type ub32 a b c d length) - (type (simple-array ub32 (16)) block) - (type (simple-array (unsigned-byte 8) (*)) buffer)) - (loop for bytes of-type buffer-index = (read-sequence buffer stream) - do - (incf length bytes) - (loop for offset of-type buffer-index - from 0 below +buffer-size+ by 64 - for rest-size of-type buffer-index = bytes - then (- rest-size block-size) - for block-size of-type (integer 0 64) = (min 64 rest-size) - do - (multiple-value-setq (a b c d) - (if (< block-size 64) - (md5sum-final a b c d block buffer offset - block-size length) - (md5sum-update a b c d block buffer offset))) - until (< block-size 64)) - until (< bytes +buffer-size+) - finally (return (md5sum-checksum a b c d))))) - -(defun md5sum-char-stream (stream) - (declare (type stream) - (optimize (speed 3) (space 0) (debug 0))) - (let ((block (make-array 16 :element-type 'ub32)) - (buffer (make-string +buffer-size+)) - (length 0) - (a +md5-magic-a+) (b +md5-magic-b+) - (c +md5-magic-c+) (d +md5-magic-d+)) - (declare (type ub32 a b c d length) - (type (simple-array ub32 (16)) block) - (type simple-string buffer)) - (loop for bytes of-type buffer-index = (read-sequence buffer stream) - do - (incf length bytes) - (loop for offset of-type buffer-index - from 0 below +buffer-size+ by 64 - for rest-size of-type buffer-index = bytes - then (- rest-size block-size) - for block-size of-type (integer 0 64) = (min 64 rest-size) - do - (multiple-value-setq (a b c d) - (if (< block-size 64) - (md5sum-final-char a b c d block buffer offset - block-size length) - (md5sum-update-char a b c d block buffer offset))) - until (< block-size 64)) - until (< bytes +buffer-size+) - finally (return (md5sum-checksum a b c d))))) +(defun md5sum-stream (stream) + (declare (optimize (speed 3) (space 0) (debug 0))) + (let ((state (make-md5-state))) + (declare (type md5-state state)) + (cond + ((equal (stream-element-type stream) '(unsigned-byte 8)) + (let ((buffer (make-array +buffer-size+ :element-type '(unsigned-byte 8)))) + (declare (type (simple-array (unsigned-byte 8) (#.md5::+buffer-size+)) + buffer)) + (loop for bytes of-type buffer-index = (read-sequence buffer stream) + do (update-md5-state state buffer :end bytes) + until (< bytes +buffer-size+) + finally + (return (finalize-md5-state state))))) + ((equal (stream-element-type stream) 'character) + (let ((buffer (make-string +buffer-size+))) + (declare (type (simple-string #.md5::+buffer-size+) buffer)) + (loop for bytes of-type buffer-index = (read-sequence buffer stream) + do (update-md5-state state buffer :end bytes) + until (< bytes +buffer-size+) + finally + (return (finalize-md5-state state))))) + (t + (error "Unsupported stream element-type ~S for stream ~S." + (stream-element-type stream) stream))))) (defun md5sum-file (pathname) (declare (optimize (speed 3) (space 0) (debug 0))) (with-open-file (stream pathname :element-type '(unsigned-byte 8)) - (md5sum-byte-stream stream))) + (md5sum-stream stream))) + +(eval-when (:compile-toplevel) + (setq ext:*inline-expansion-limit* *old-expansion-limit*))