diff options
author | Felix Lange <fjl@twurst.com> | 2022-01-21 11:29:31 +0100 |
---|---|---|
committer | GitHub <noreply@github.com> | 2022-01-21 10:29:31 +0000 |
commit | bf4a2366518b0fcaa3476b10e5d2d8ab33131355 (patch) | |
tree | 6e80a305c27f741891ddbcfc12ce417ec3739cb8 | |
parent | 6ad3a482105e1a46b461b1e65bafa769113abf7c (diff) |
Support DIGEST-SEQUENCE of non-simple arrays on all implementations (#49)
This changes makes DIGEST-SEQUENCE work with non-simple argument vectors
on all implementations by using a temporary buffer in the slow case.
-rw-r--r-- | README.org | 2 | ||||
-rw-r--r-- | src/digests/digest.lisp | 60 | ||||
-rw-r--r-- | src/generic.lisp | 6 | ||||
-rw-r--r-- | testing/testfuns.lisp | 2 |
4 files changed, 43 insertions, 27 deletions
@@ -538,7 +538,7 @@ The second form comes in handy if you plan on [[*Miscellaneous][reusing the dige Returns the digest of the subsequence of /sequence/ bounded by /start/ and /end/, according to /digest-name/. /sequence/ must be -a ~(simple-array (unsigned-byte 8) (*))~. /digest/ and /digest-start/ +a ~(vector (unsigned-byte 8))~. /digest/ and /digest-start/ are as in [[produce-digest][produce-digest]]. diff --git a/src/digests/digest.lisp b/src/digests/digest.lisp index 4056aa0..b5f2926 100644 --- a/src/digests/digest.lisp +++ b/src/digests/digest.lisp @@ -7,7 +7,8 @@ ;;; defining digest (hash) functions (eval-when (:compile-toplevel :load-toplevel) -(defconstant +buffer-size+ (* 128 1024)) + (defconstant +buffer-size+ (* 128 1024)) + (defconstant +seq-copy-buffer-size+ 512) ) ; EVAL-WHEN (deftype buffer-index () `(integer 0 (,+buffer-size+))) @@ -24,8 +25,7 @@ finally (return digest)))) (if buffer (frob buffer start (or end (length buffer))) - (let ((buffer (make-array +buffer-size+ - :element-type '(unsigned-byte 8)))) + (let ((buffer (make-array +buffer-size+ :element-type '(unsigned-byte 8)))) (declare (dynamic-extent buffer)) (frob buffer 0 +buffer-size+))))) (t @@ -33,6 +33,37 @@ :format-control "Unsupported stream element-type ~S for stream ~S." :format-arguments (list (stream-element-type stream) stream))))) +(declaim (inline update-digest-from-vector)) + +#+(or cmucl sbcl) +(defun update-digest-from-vector (digest vector start end) + ;; SBCL and CMUCL have with-array-data, so copying can be avoided even + ;; for non-simple vectors. + (declare (type (vector (unsigned-byte 8)) vector) + (type index start end)) + (#+cmucl lisp::with-array-data + #+sbcl sb-kernel:with-array-data ((data vector) (real-start start) (real-end end)) + (declare (ignore real-end)) + (update-digest digest data :start real-start :end (+ real-start (- end start))))) + +#-(or cmu sbcl) +(defun update-digest-from-vector (state vector start end) + (declare (optimize speed) + (type (vector (unsigned-byte 8)) vector) + (type index start end)) + (if (typep vector 'simple-octet-vector) + (update-digest state vector :start start :end end) + ;; It's a non-simple vector. Update the digest using a temporary buffer. + (let ((buffer (make-array +seq-copy-buffer-size+ :element-type '(unsigned-byte 8)))) + (declare (dynamic-extent buffer)) + (loop with offset of-type index = start + for length of-type index = (min +seq-copy-buffer-size+ (- end offset)) + while (< offset end) do + (replace buffer vector :start1 0 :end1 length + :start2 offset :end2 (+ offset length)) + (update-digest state buffer :start 0 :end length) + (incf offset length))))) + ;;; Storing a length at the end of the hashed data is very common and ;;; can be a small bottleneck when generating lots of hashes over small ;;; quantities of data. We assume that the appropriate locations have @@ -284,22 +315,11 @@ (apply #'digest-sequence (make-digest digest-name) sequence kwargs)) (defmethod digest-sequence (state sequence &key (start 0) end - digest (digest-start 0)) - #+(or cmu sbcl) - (locally - (declare (type (vector (unsigned-byte 8)) sequence) (type index start)) - ;; respect the fill-pointer - (let ((end (or end (length sequence)))) - (declare (type index end)) - (#+cmu lisp::with-array-data - #+sbcl sb-kernel:with-array-data ((data sequence) (real-start start) (real-end end)) - (declare (ignore real-end)) - (update-digest state data - :start real-start :end (+ real-start (- end start)))))) - #-(or cmu sbcl) - (let ((real-end (or end (length sequence)))) - (update-digest state sequence - :start start :end (or real-end (length sequence)))) + digest (digest-start 0)) + (declare (type index start)) + (check-type sequence (vector (unsigned-byte 8))) + (let ((end (or end (length sequence)))) + (update-digest-from-vector state sequence start end)) (produce-digest state :digest digest :digest-start digest-start)) ;;; These four functions represent the common interface for digests in @@ -317,7 +337,7 @@ (error 'unsupported-digest :name digest-name)))) (t (error 'type-error :datum digest-name :expected-type 'symbol)))) - + ;;; the digest-defining macro diff --git a/src/generic.lisp b/src/generic.lisp index 90d236a..13b564a 100644 --- a/src/generic.lisp +++ b/src/generic.lisp @@ -102,10 +102,8 @@ be used to hold data read from the stream.")) (defgeneric digest-sequence (digest-spec sequence &rest args &key start end digest digest-start) (:documentation "Return the digest of the subsequence of SEQUENCE -specified by START and END using the algorithm DIGEST-NAME. For CMUCL -and SBCL, SEQUENCE can be any vector with an element-type -of (UNSIGNED-BYTE 8); for other implementations, SEQUENCE must be a -(SIMPLE-ARRAY (UNSIGNED-BYTE 8) (*)). +specified by START and END using the algorithm DIGEST-SPEC. +SEQUENCE can be any vector with an element-type of (UNSIGNED-BYTE 8). If DIGEST is provided, the digest will be placed into DIGEST starting at DIGEST-START. DIGEST must be a (SIMPLE-ARRAY (UNSIGNED-BYTE 8) (*)). diff --git a/testing/testfuns.lisp b/testing/testfuns.lisp index 981fd8b..5fbabd0 100644 --- a/testing/testfuns.lisp +++ b/testing/testfuns.lisp @@ -224,7 +224,6 @@ (when (mismatch result expected-digest) (error "incremental ~A digest of ~S failed" digest-name input))))) -#+(or sbcl cmucl) (defun digest-test/fill-pointer (digest-name octets expected-digest) (let* ((input (let ((x (make-array (* 2 (length octets)) :fill-pointer 0 @@ -284,7 +283,6 @@ (cons :digest-bit-test 'ignore-test) (cons :xof-digest-test 'ignore-test))) -#+(or sbcl cmucl) (defparameter *digest-fill-pointer-tests* (list (cons :digest-test 'digest-test/fill-pointer) (cons :digest-bit-test 'ignore-test) |