Permalink
Browse files

rfe8018. Optimize inflate.cl. Add inflate tests.

Add declarations to inflate.cl to improve performance.
Add t-iperf.cl for performance testing on inflate.cl
Add test for the inflate module, to existing deflate
tests in t-gzip.cl

Are there user visible changes in this commit?  no

Are tests included for new features?  yes, but no new features.

Tests run:  make all

Change-Id: I0ea48cf01c2c7cbb3f057360946d9ac9f3116ca0
  • Loading branch information...
1 parent 6673000 commit abf01f567884390845f55179e8779ed5ac6bc2f8 Mikel Bancroft committed with dklayer Apr 20, 2011
Showing with 135 additions and 15 deletions.
  1. +41 −14 inflate.cl
  2. +40 −1 t-gzip.cl
  3. +54 −0 t-iperf.cl
View
@@ -286,13 +286,18 @@ that describe the custome huffman tree are themselves huffman coded.
;; return a value from the current bit reader.
;; the count can be from 1 to 16
;;
+ (declare (optimize (speed 3) (safety 1))
+ (type bit-reader br)
+ (type (integer 0 16) count))
(if* (eql count 0)
then (return-from read-bits 0))
(let ((last-byte (bit-reader-last-byte br))
(bits (bit-reader-bits br)))
+ (declare (type (unsigned-byte 16) last-byte)
+ (type (integer 0 8) bits))
(loop
(if* (>= bits count)
then ;we have enough now
@@ -301,7 +306,8 @@ that describe the custome huffman tree are themselves huffman coded.
(setf (bit-reader-last-byte br)
(ash last-byte (- count)))
(setf (bit-reader-bits br) (- bits count))
- (return (logand last-byte (svref *maskarray* count)))
+ (return (logand last-byte (the (unsigned-byte 16)
+ (svref *maskarray* count))))
else ; no bits left
(setf (bit-reader-bits br) 0)
(setf (bit-reader-last-byte br) 0)
@@ -314,7 +320,7 @@ that describe the custome huffman tree are themselves huffman coded.
then (error "end of file on bit reader"))
(let ((new-byte (read-byte (bit-reader-stream br))))
-
+ (declare (type (unsigned-byte 8) new-byte))
(incf (bit-reader-bytes-read br))
(if* bytes-left
then (setf (bit-reader-bytes-to-read br) (1- bytes-left)))
@@ -506,7 +512,7 @@ that describe the custome huffman tree are themselves huffman coded.
;; If the value of the specified pos selects a specific value
;; and no further bits need be read to identify that value then
;; we return that value rather than a list of conses.
-
+ (declare (optimize (speed 3) (safety 1)))
(let (zero one)
(dolist (mm minmaxes)
(do ((v (car mm) (1+ v)))
@@ -612,6 +618,11 @@ that describe the custome huffman tree are themselves huffman coded.
(defun put-byte-in-buffer (op byte buffer end)
;; store the next output byte in the buffer
+ (declare (optimize (speed 3) (safety 1))
+ (type (unsigned-byte 8) byte)
+ (type (simple-array (unsigned-byte 8) (*)) buffer)
+ (type (integer 0 #.(1- array-total-size-limit)) end))
+
(if* (>= end (length buffer))
then (flush-buffer op buffer end)
(setq end 0))
@@ -635,7 +646,7 @@ that describe the custome huffman tree are themselves huffman coded.
;;
(process-huffman-block br op *fixed-huffman-tree* 7 *fixed-huffman-distance-tree* 5
buffer end))
-
+;; non-inline call to mod
(defun process-huffman-block (br op
lengthlit-tree minwidth
distance-tree mindistwidth
@@ -646,14 +657,20 @@ that describe the custome huffman tree are themselves huffman coded.
;; If the distance tree is nil then we use the trivial huffman
;; code from the algorithm.
;;
+ (declare (optimize (speed 3) (safety 1))
+ (type (simple-array (unsigned-byte 8) (*)) buffer)
+ (type (integer 0 #.array-total-size-limit) end))
+
(let* ((bufflen (length buffer))
length
distance
)
-
+ (declare (type (unsigned-byte 16) distance)
+ (type (integer 0 258) length))
(loop
(let ((value (decode-huffman-tree br lengthlit-tree minwidth)))
+ (declare (type (integer 0 287) value))
(if* (< value 256)
then ; output and add to buffer
(setq end (put-byte-in-buffer op value buffer end))
@@ -664,24 +681,29 @@ that describe the custome huffman tree are themselves huffman coded.
; compute length, distance
(let ((adj-code (- value 257)))
- (setq length (+ (svref *base-length* adj-code)
- (read-bits br (svref *length-extra-bits*
- adj-code)))))
+ (setq length (+ (the (integer 0 258)
+ (svref *base-length* adj-code))
+ (the (unsigned-byte 16)
+ (read-bits br (svref *length-extra-bits*
+ adj-code))))))
(let ((dist-code (if* distance-tree
then (decode-huffman-tree br
distance-tree
mindistwidth)
else (read-bits br 5))))
(setq distance
- (+ (svref *base-distance* dist-code)
- (read-bits br (svref *distance-extra-bits*
- dist-code)))))
+ (+ (the (unsigned-byte 16) (svref *base-distance* dist-code))
+ (the (unsigned-byte 16)
+ (read-bits br (svref *distance-extra-bits*
+ dist-code))))))
; copy in bytes
(do ((i (mod (- end distance) bufflen) (1+ i))
(count length (1- count)))
((<= count 0))
+ (declare (type (integer 0 #.(1- array-total-size-limit)) i)
+ (type (integer 0 258) count))
(if* (>= i bufflen) then (setf i 0))
(setq end (put-byte-in-buffer op
(aref buffer i)
@@ -780,8 +802,13 @@ that describe the custome huffman tree are themselves huffman coded.
; the minimum length of a huffman code is minbits so
; grab that many bits right away to speed processing and the
; go bit by bit until the answer is found
+ (declare (optimize (speed 3) (safety 1))
+ (type (integer 0 16) minbits))
+
(let ((startval (read-bits br minbits)))
+ (declare (type (unsigned-byte 16) startval))
(dotimes (i minbits)
+ (declare (type (integer 0 16) i))
(if* (logtest 1 startval)
then (setq tree (cdr tree))
else (setq tree (car tree)))
@@ -974,7 +1001,7 @@ into the inflate buffer.
(defmethod device-read ((p inflate-stream) buffer start end blocking)
- (declare (ignore blocking)) ; we only read from file streams
+ (declare (ignore blocking)) ; we only read from file streams
(if* (null buffer) then (setq buffer (slot-value p 'excl::buffer)))
@@ -1000,7 +1027,7 @@ into the inflate buffer.
:end2 fromend)
(let ((copied (min (- end start) (- fromend fromstart))))
(incf fromstart copied)
- (incf (inflate-passed-to-user p) copied)
+ (incf (the fixnum (inflate-passed-to-user p)) copied)
(if* (>= fromstart fromend)
then ; the buffer's all used up
(setf (cached-buffs p) (cdr cbs))
@@ -1023,7 +1050,7 @@ into the inflate buffer.
:start2 i-start
:end2 i-end)
(let ((copied (min (- end start) (- i-end i-start))))
- (incf (inflate-passed-to-user p) copied)
+ (incf (the fixnum (inflate-passed-to-user p)) copied)
(setf (inflate-buffer-start p) (+ i-start copied))
(return-from device-read copied)))
View
@@ -44,6 +44,18 @@
; finish compression
(close deflate)))))
+(defun inflate-file (input-filename output-filename)
+ (with-open-file (in input-filename :direction :input)
+ (with-open-file (out output-filename
+ :direction :output
+ :if-exists :supersede)
+ (let ((inflate (make-instance 'util.zip::inflate-stream
+ :input-handle in
+ :skip-gzip-header t))
+ byte)
+ (while (setq byte (read-byte inflate nil nil))
+ (write-byte byte out))))))
+
(defun deflate-test (input-filename)
;; compress input-file to temp-file1, uncompress it back to temp-file2
;; and compare temp-file2 to input-filename, error if not same.
@@ -70,14 +82,41 @@
(when temp-file1 (ignore-errors (delete-file temp-file1)))
(when temp-file2 (ignore-errors (delete-file temp-file2)))))))
+(defun inflate-test (input-filename)
+ ;; compress input-file to temp-file1, uncompress it back to temp-file2
+ ;; and compare temp-file2 to input-filename, error if not same.
+ (flet ((cygwin-namestring (p)
+ #+mswindows (substitute #\/ #\\ (namestring p))
+ #-mswindows p))
+ (let (temp-file1 temp-file2)
+ (unwind-protect
+ (progn
+ (setq temp-file1 (sys:make-temp-file-name "inflate1x"))
+ (setq temp-file2 (sys:make-temp-file-name "inflate2x"))
+ (format t "; uncompress test on ~a~%"
+ (enough-namestring input-filename))
+ (format t "; compress ~a to ~a~%" temp-file1 temp-file2)
+ (or (eql 0 (run-shell-command
+ (format nil "sh -c 'gzip -c ~a > ~a'"
+ (cygwin-namestring input-filename)
+ (cygwin-namestring temp-file1))
+ :show-window :hide))
+ (error "gzip failed on ~a" temp-file1))
+ (inflate-file temp-file1 temp-file2)
+ ;;(format t "; compare ~a to ~a~%" input-filename temp-file2)
+ (test-t (excl::compare-files input-filename temp-file2)))
+ (when temp-file1 (ignore-errors (delete-file temp-file1)))
+ (when temp-file2 (ignore-errors (delete-file temp-file2)))))))
+
(defun test-gzip ()
(map-over-directory
(lambda (p)
;; Don't check .out files, since the output of the tests themselves
;; might be going to one, and that means the files would be changing
;; and the tests will fail.
(when (not (string-equal "out" (pathname-type p)))
- (deflate-test p)))
+ (deflate-test p)
+ (inflate-test p)))
"./"
:recurse nil))
View
@@ -0,0 +1,54 @@
+;; copyright (c) 2011 Franz Inc, Oakland, CA - All rights reserved.
+;;
+;; The software, data and information contained herein are proprietary
+;; to, and comprise valuable trade secrets of, Franz, Inc. They are
+;; given in confidence by Franz, Inc. pursuant to a written license
+;; agreement, and may be stored and used only in accordance with the terms
+;; of such license.
+;;
+;; Restricted Rights Legend
+;; ------------------------
+;; Use, duplication, and disclosure of the software, data and information
+;; contained herein by any agency, department or entity of the U.S.
+;; Government are subject to restrictions of Restricted Rights for
+;; Commercial Software developed at private expense as specified in
+;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
+
+(in-package :user)
+
+(eval-when (compile load eval)
+ (require :inflate "./inflate.fasl")
+ (use-package :util.zip))
+
+(defun test-inflate-1 ()
+ (with-open-file (p "foo.n.gz")
+ (skip-gzip-header p)
+ (let ((comp (make-instance 'inflate-stream :input-handle p)))
+ ;; inflate-stream, testing performance.
+ ;; after, compare that the inflated stream is the same as the orig.
+ (with-open-file (of "foo.n" :direction :output :if-exists :supersede)
+ (let (byte)
+ (while (setq byte (read-byte comp nil nil))
+ (write-byte byte of)))))))
+
+(defun test-inflate-2 ()
+ (with-open-file (p "foo.n.gz")
+ (let ((comp (make-instance 'inflate-stream :input-handle p
+ :skip-gzip-header t)))
+ ;; inflate-stream, testing performance.
+ ;; after, compare that the inflated stream is the same as the orig.
+ (with-open-file (of "foo.n" :direction :output :if-exists :supersede)
+ (let (byte)
+ (while (setq byte (read-byte comp nil nil))
+ (write-byte byte of)))))))
+
+(defun test-inflate (&optional (count 10))
+ (declare (ignorable i))
+ (time (map-over-directory (lambda (p)
+ (when (not (string-equal "out" (pathname-type p)))
+ (dotimes (i count)
+ (run-shell-command (format nil "gzip -c ~a > foo.n.gz" p))
+ (test-inflate-1)
+ (test-inflate-2))))
+ "./" :recurse nil))
+ (delete-file "foo.n.gz"))

0 comments on commit abf01f5

Please sign in to comment.