-
Notifications
You must be signed in to change notification settings - Fork 5
/
types-and-tables.lisp
175 lines (152 loc) · 6.88 KB
/
types-and-tables.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
(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 start)
(let* ((n-syms (or n-syms (length code-lengths)))
(start (or start 0))
(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))
(loop for i from start below (+ start n-syms) do
(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 (+ start 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 31)))
(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))))))