<br><br><div class="gmail_quote">---------- Forwarded message ----------<br>From: <b class="gmail_sendername">Pierre R. Mai</b> <span dir="ltr"><<a href="mailto:pmai@pmsf.de">pmai@pmsf.de</a>></span><br>Date: 2010/10/5<br>
Subject: Re: [Ecls-list] ECL failure with Pierre Mai's Deflate library<br>To: Zach Beane <<a href="mailto:xach@xach.com">xach@xach.com</a>>, Juan Jose Garcia-Ripoll <<a href="mailto:juanjose.garciaripoll@googlemail.com">juanjose.garciaripoll@googlemail.com</a>><br>
<br><br><br>
Am 05.10.2010 um 12:01 schrieb Pierre R. Mai:<br>
<div><div></div><div class="h5"><br>
><br>
> Am 04.10.2010 um 21:59 schrieb Zach Beane:<br>
><br>
>> Juan Jose Garcia-Ripoll <<a href="mailto:juanjose.garciaripoll@googlemail.com">juanjose.garciaripoll@googlemail.com</a>> writes:<br>
>><br>
>>> Zach, thanks a lot for a self-contained test. Could you please provide us with<br>
>>> some more information about the platform where you tested ECL? I mean at<br>
>>> least configuration flags, chipset, 32/64 bits, operating system and value of<br>
>>> *features*<br>
>><br>
>> Sure, sorry for omitting that important info!<br>
>><br>
>> I am running ECL from git://<a href="http://ecls.git.sourceforge.net/gitroot/ecls/ecl" target="_blank">ecls.git.sourceforge.net/gitroot/ecls/ecl</a><br>
>> with the last commit date of "Tue Sep 28 12:14:30 2010 +0200". I am<br>
>> building it on a 64-bit Core 2 Duo Linux (Ubuntu 10.04) system. I am not<br>
>> using any configuration flags. Here is the *FEATURES* list:<br>
>><br>
>> (:LINUX :FORMATTER :LONG-LONG :UINT64-T :UINT32-T :UINT16-T<br>
>> :RELATIVE-PACKAGE-NAMES :DFFI :CLOS-STREAMS :CMU-FORMAT :UNIX<br>
>> :ECL-PDE :DLOPEN :CLOS :BOEHM-GC :ANSI-CL :COMMON-LISP<br>
>> :IEEE-FLOATING-POINT :PREFIXED-API :FFI :X86_64 :COMMON :ECL)<br>
>><br>
>> Thanks,<br>
>> Zach<br>
><br>
> Hi everyone,<br>
><br>
> I've had a chance to look at what seems to be happening and found at least one source of trouble:<br>
><br>
> The first error occurs due to the code trying to copy a literal block where it should huffman decode a block, and this seems to happen due to a problem with bit-stream-read-bits returning 0 where it should return 1 (as called from decode-block):<br>
><br>
> (defun bit-stream-read-bits (stream bits)<br>
> (declare (type bit-stream stream) (type (unsigned-byte 8) bits))<br>
> "Read single or multiple bits from the given bit-stream."<br>
> (loop while (< (bit-stream-bit-count stream) bits)<br>
> do<br>
> ;; Fill bits<br>
> (setf (bit-stream-bits stream)<br>
> (logior (bit-stream-bits stream)<br>
> (the (unsigned-byte 29)<br>
> (ash (bit-stream-get-byte stream)<br>
> (bit-stream-bit-count stream))))<br>
> (bit-stream-bit-count stream) (+ (bit-stream-bit-count stream) 8)))<br>
> ;; Return properly masked bits<br>
> (if (= (bit-stream-bit-count stream) bits)<br>
> (prog1 (bit-stream-bits stream)<br>
> (setf (bit-stream-bits stream) 0<br>
> (bit-stream-bit-count stream) 0)) (prog1 (ldb (byte bits 0) (bit-stream-bits stream))<br>
> (setf (bit-stream-bits stream) (ash (bit-stream-bits stream) (- bits))<br>
> (bit-stream-bit-count stream) (- (bit-stream-bit-count stream) bit<br>
> s)))))<br>
><br>
> If I remove the (type (unsigned-byte 8) bits) declaration, the function suddenly seems to perform as intended. Given that the declaration is correct, i.e. bits is always between 0 and 255 (actually it is much smaller), the removal of the declaration should have no effect, but it does, which might be indicative of a bug somewhere...<br>
><br>
> Once this problem is dealt with the code errors out due to huffman decode corruption, which seems indicative of further problems, but I have not yet been able to look at that in more detail.<br>
<br>
</div></div>I have now looked at that problem, too, and it seems there are two further sources of error in that area. The first is that make-huffman-decode-tree does not seem to work properly, because its changes of the length-count and next-code arrays seem to not have any effect (or mutate data outside the proper position):<br>
<br>
(defun make-huffman-decode-tree (code-lengths)<br>
"Construct a huffman decode-tree for the canonical huffman code with<br>
the code lengths of each symbol given in the input array."<br>
(let* ((max-length (reduce #'max code-lengths :initial-value 0))<br>
(next-code (make-array (1+ max-length) :element-type 'fixnum<br>
:initial-element 0))<br>
(code-symbols (make-array (length code-lengths) :element-type 'fixnum<br>
:initial-element 0))<br>
(length-count (make-array (1+ max-length) :element-type 'fixnum<br>
:initial-element 0)))<br>
;; Count length occurences and calculate offsets of smallest codes<br>
(loop for index from 1 to max-length<br>
for code = 0 then (+ code (aref length-count (1- index)))<br>
do<br>
(setf (aref next-code index) code)<br>
initially<br>
;; Count length occurences<br>
(loop for length across code-lengths<br>
do<br>
(incf (aref length-count length))<br>
finally<br>
(setf (aref length-count 0) 0)))<br>
;; Construct code symbols mapping<br>
(loop for length across code-lengths<br>
for index upfrom 0<br>
unless (zerop length)<br>
do<br>
(setf (aref code-symbols (aref next-code length)) index)<br>
(incf (aref next-code length)))<br>
;; Return result<br>
(make-decode-tree :length-count length-count :code-symbols code-symbols)))<br>
<br>
The moment I move the looping constructs to their own function, the code seems to work fine, however:<br>
<br>
(defun helper (length-count max-length next-code code-lengths code-symbols)<br>
;; Count length occurences and calculate offsets of smallest codes<br>
(loop for index from 1 to max-length<br>
for code = 0 then (+ code (aref length-count (1- index)))<br>
do<br>
(setf (aref next-code index) code)<br>
initially<br>
;; Count length occurences<br>
(loop for length across code-lengths<br>
do<br>
(incf (aref length-count length))<br>
finally<br>
(setf (aref length-count 0) 0)))<br>
;; Construct code symbols mapping<br>
(loop for length across code-lengths<br>
for index upfrom 0<br>
unless (zerop length)<br>
do<br>
(setf (aref code-symbols (aref next-code length)) index)<br>
(incf (aref next-code length))))<br>
<br>
(defun make-huffman-decode-tree (code-lengths)<br>
"Construct a huffman decode-tree for the canonical huffman code with<br>
the code lengths of each symbol given in the input array."<br>
(let* ((max-length (reduce #'max code-lengths :initial-value 0))<br>
(next-code (make-array (1+ max-length) :element-type 'fixnum<br>
:initial-element 0))<br>
(code-symbols (make-array (length code-lengths) :element-type 'fixnum<br>
:initial-element 0))<br>
(length-count (make-array (1+ max-length) :element-type 'fixnum<br>
:initial-element 0)))<br>
(helper length-count max-length next-code code-lengths code-symbols)<br>
;; Return result<br>
(make-decode-tree :length-count length-count :code-symbols code-symbols)))<br>
<br>
This seems very strange, and maybe is indicative of an error in type-propagation?<br>
<br>
Once that problem is resolved, there remain problems with the use of of-type declarations in read-huffman-code, i.e. the of-type declarations for length-count and code-symbols have to be removed, otherwise the accesses to those arrays seem to also be off/wrong (which also seems indicative that the compiler somehow gets confused on array accesses to fixnum arrays, maybe due to the discrepancy between declared and upgraded element type fixnum vs. SI:INTEGER64):<br>
<br>
(defun read-huffman-code (bit-stream decode-tree)<br>
(declare (type bit-stream bit-stream) (type decode-tree decode-tree)<br>
(optimize (speed 3) (safety 0) (space 0) (debug 0)))<br>
"Read the next huffman code word from the given bit-stream and<br>
return its decoded symbol, for the huffman code given by decode-tree."<br>
(loop with length-count of-type (simple-array fixnum (*))<br>
= (decode-tree-length-count decode-tree)<br>
with code-symbols of-type (simple-array fixnum (*))<br>
= (decode-tree-code-symbols decode-tree)<br>
for code of-type fixnum = (bit-stream-read-bits bit-stream 1)<br>
then (+ (* code 2) (bit-stream-read-bits bit-stream 1))<br>
for index of-type fixnum = 0 then (+ index count)<br>
for first of-type fixnum = 0 then (* (+ first count) 2)<br>
for length of-type fixnum upfrom 1 below (length length-count)<br>
for count = (aref length-count length)<br>
thereis (when (< code (the fixnum (+ first count)))<br>
(aref code-symbols (+ index (- code first))))<br>
finally<br>
(error 'deflate-decompression-error<br>
:format-control<br>
"Corrupted Data detected during decompression: ~<br>
Incorrect huffman code (~X) in huffman decode!"<br>
:format-arguments (list code))))<br>
<br>
has to be turned into<br>
<br>
(defun read-huffman-code (bit-stream decode-tree)<br>
(declare (type bit-stream bit-stream) (type decode-tree decode-tree)<br>
(optimize (speed 3) (safety 0) (space 0) (debug 0)))<br>
"Read the next huffman code word from the given bit-stream and<br>
return its decoded symbol, for the huffman code given by decode-tree."<br>
(loop with length-count<br>
= (decode-tree-length-count decode-tree)<br>
with code-symbols<br>
= (decode-tree-code-symbols decode-tree)<br>
for code of-type fixnum = (bit-stream-read-bits bit-stream 1)<br>
then (+ (* code 2) (bit-stream-read-bits bit-stream 1))<br>
for index of-type fixnum = 0 then (+ index count)<br>
for first of-type fixnum = 0 then (* (+ first count) 2)<br>
for length of-type fixnum upfrom 1 below (length length-count)<br>
for count = (aref length-count length)<br>
thereis (when (< code (the fixnum (+ first count)))<br>
(aref code-symbols (+ index (- code first))))<br>
finally<br>
(error 'deflate-decompression-error<br>
:format-control<br>
"Corrupted Data detected during decompression: ~<br>
Incorrect huffman code (~X) in huffman decode!"<br>
:format-arguments (list code))))<br>
<br>
Attached you can find a patch file detailing the necessary changes to make it work on ECL. Given that the declarations and code in question seems to be perfectly conforming, I'd be very interested in the source of these problems (note that the code might still have other problems on ECL, which have not been tickled by the current test case).<br>
<br>
Regs, Pierre.<br>
<br>
PS: Feel free to forward this mail to the ecl list, since I have no posting rights for the list.<br>
<br>
<br>
<br><br>
<br>
--<br>
Pierre R. Mai <<a href="mailto:pmai@pmsf.de">pmai@pmsf.de</a>><br>
PMSF IT Consulting Pierre R. Mai <a href="http://www.pmsf.de/" target="_blank">http://www.pmsf.de/</a><br>
Blumenstr. 4 Goethestr. 32<br>
85417 Marzling 87724 Ottobeuren<br>
Tel. +49(0)8161/935 35 12 +49(0)8332/936 69 13<br>
Fax +49(0)8161/935 35 08 +49(0)8332/936 69 03<br>
VAT ID / USt-ID Nr: DE 212838159 Germany<br>
<br>
<br></div><br><br clear="all"><br>-- <br>Instituto de Física Fundamental, CSIC<br>c/ Serrano, 113b, Madrid 28006 (Spain) <br><a href="http://juanjose.garciaripoll.googlepages.com">http://juanjose.garciaripoll.googlepages.com</a><br>