(in-package :chipz) (deftype index () '(mod #.array-dimension-limit)) (deftype simple-octet-vector (&optional length) (let ((length (or length '*))) `(simple-array (unsigned-byte 8) (,length)))) (deftype deflate-code-length () '(integer 0 #.+max-code-length+)) (deftype deflate-code () '(unsigned-byte #.+max-code-length+)) (deftype deflate-code-value () '(integer 0 (#.+max-codes+))) (defparameter *distance-code-extra-bits* ;; codes 30 and 31 will never actually appear, but we represent them ;; for completeness' sake #(0 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 10 10 11 11 12 12 13 13 0 0)) (defparameter *distance-code-base-distances* #(1 2 3 4 5 7 9 13 17 25 33 49 65 97 129 193 257 385 513 769 1025 1537 2049 3073 4097 6145 8193 12289 16385 24577)) (declaim (inline n-length-extra-bits n-distance-extra-bits length-base distance-base)) (defun n-length-extra-bits (value) (aref +length-code-extra-bits+ value)) (defun n-distance-extra-bits (distance-code) (svref *distance-code-extra-bits* distance-code)) (defun length-base (value) (aref +length-code-base-lengths+ value)) (defun distance-base (distance-code) (svref *distance-code-base-distances* distance-code)) (defparameter *code-length-code-order* #(16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15)) (eval-when (:compile-toplevel :load-toplevel :execute) (defstruct (code-range-descriptor (:conc-name code-) (:constructor make-crd (n-bits start-value end-value))) (n-bits 0 :type deflate-code-length) (start-value 0 :type deflate-code-value) (end-value 0 :type deflate-code-value)) (defstruct (huffman-decode-table (:conc-name hdt-) (:constructor make-hdt (counts offsets symbols bits))) ;; FIXME: look into combining these two into one array for speed. (counts #1=(error "required parameter") :type (simple-array (unsigned-byte 16) (#.+max-code-length+)) :read-only t) (offsets #1# :type (simple-array (unsigned-byte 16) (#.(1+ +max-code-length+))) :read-only t) (symbols nil :read-only t :type (simple-array fixnum (*))) (bits nil :read-only t)) ) ; EVAL-WHEN ;;; decode table construction (defun construct-huffman-decode-table (code-lengths &optional n-syms) (let* ((n-syms (or n-syms (length code-lengths))) (min-code-length +max-code-length+) (max-code-length 0) (counts (make-array +max-code-length+ :initial-element 0 :element-type '(unsigned-byte 16))) (offsets (make-array (1+ +max-code-length+) :initial-element 0 :element-type '(unsigned-byte 16))) (symbols (make-array n-syms :initial-element 0 :element-type 'fixnum))) (declare (type (simple-array (unsigned-byte 16) (*)) counts) (type (simple-array fixnum (*)) symbols)) (dotimes (i n-syms) (let ((c (aref code-lengths i))) (setf min-code-length (min min-code-length c)) (setf max-code-length (max max-code-length c)) (incf (aref counts c)))) ;; generate offsets (loop for i from 1 below +deflate-max-bits+ do (setf (aref offsets (1+ i)) (+ (aref offsets i) (aref counts i)))) (dotimes (i n-syms (make-hdt counts offsets symbols max-code-length)) (let ((l (aref code-lengths i))) (unless (zerop l) (setf (aref symbols (aref offsets l)) i) (incf (aref offsets l))))))) ;;; decoders for fixed compression blocks (defparameter *fixed-block-code-lengths* (map 'list #'make-crd '(8 9 7 8) ; lengths '(0 144 256 280) ; start values '(143 255 279 287))) ; end values (defparameter *fixed-block-distance-lengths* (list (make-crd 5 0 29))) (defun code-n-values (c) (1+ (- (code-end-value c) (code-start-value c)))) (defun compute-huffman-decode-structure (code-descriptors) (let* ((n-syms (loop for cd in code-descriptors sum (code-n-values cd))) (code-lengths (make-array n-syms :element-type '(unsigned-byte 16)))) (dolist (cd code-descriptors) (fill code-lengths (code-n-bits cd) :start (code-start-value cd) :end (1+ (code-end-value cd)))) (construct-huffman-decode-table code-lengths))) (defparameter *fixed-literal/length-table* (compute-huffman-decode-structure *fixed-block-code-lengths*)) (defparameter *fixed-distance-table* (compute-huffman-decode-structure *fixed-block-distance-lengths*)) (defmacro probably-the-fixnum (form) #+sbcl `(sb-ext:truly-the fixnum ,form) #-sbcl form) ;;; I want to make this work, but it drastically slows the code down in ;;; sbcl. Part of this is due to bad code generation (jump to jump to ;;; jump, yuck). #+nil (defun decode-value (table state) (declare (type huffman-decode-table table)) (declare (type inflate-state state)) (declare (optimize (speed 3))) (do ((bits (inflate-state-bits state)) (n-bits (inflate-state-n-bits state)) (counts (hdt-counts table)) (len 1) (first 0) (code 0)) (nil nil) (declare (type (unsigned-byte 32) bits)) (declare (type (integer 0 32) n-bits)) (declare (type (and fixnum (integer 0 *)) first code)) (do () ((zerop n-bits) (when (= (inflate-state-input-index state) (inflate-state-input-end state)) (throw 'inflate-done nil)) (setf bits (aref (inflate-state-input state) (inflate-state-input-index state))) (setf (inflate-state-input-index state) (sb-ext:truly-the fixnum (1+ (inflate-state-input-index state)))) (setf n-bits 8)) ;; We would normally do this with READ-BITS, but DECODE-VALUE ;; is a hotspot in profiles along with this would-be call to ;; READ-BITS, so we inline it all here. (setf code (logior code (logand bits 1)) bits (ash bits -1)) (decf n-bits) (let ((count (aref counts len))) (when (< (- code count) first) (setf (inflate-state-bits state) bits) (setf (inflate-state-n-bits state) n-bits) (return-from decode-value (aref (hdt-symbols table) #+sbcl (sb-ext:truly-the fixnum #3=(+ (aref (hdt-offsets table) (1- len)) (- code first))) #-sbcl #3#))) (setf first #+sbcl (sb-ext:truly-the fixnum (+ first count)) #-sbcl (+ first count) first #+sbcl (sb-ext:truly-the fixnum #1=(ash first 1)) #-sbcl #1# code #+sbcl (sb-ext:truly-the fixnum #2=(ash code 1)) #-sbcl #2# len (1+ len))))))