[zlib-cvs] CVS zlib/src
mvilleneuve
mvilleneuve at common-lisp.net
Thu Jan 4 09:03:37 UTC 2007
Update of /project/zlib/cvsroot/zlib/src
In directory clnet:/tmp/cvs-serv7863/src
Modified Files:
zlib.lisp
Log Message:
Optimize distance and length computations thanks to Pascal Bourguignon's decision-tree macro
--- /project/zlib/cvsroot/zlib/src/zlib.lisp 2004/09/21 21:27:16 1.1.1.1
+++ /project/zlib/cvsroot/zlib/src/zlib.lisp 2007/01/04 09:03:37 1.2
@@ -1,7 +1,7 @@
;;; ZLIB
;;;
;;; Copyright (C) 2001-2004 Harald Musum (musum at pvv.org)
-;;; Copyright (C) 2004 Matthieu Villeneuve (matthieu.villeneuve at free.fr)
+;;; Copyright (C) 2004-2006 Matthieu Villeneuve (matthieu.villeneuve at free.fr)
;;;
;;; The authors grant you the rights to distribute
;;; and use this software as governed by the terms
@@ -314,64 +314,127 @@
do (setf (aref result i) (ldb (byte 1 i) code))
finally (return result)))
-;; FIXME. It should be possible to do this smarter
+
+;;; DECISION-TREE macro
+;;; Thanks to Pascal Bourguignon
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+ (defun infix-to-tree (sequence)
+ (labels ((itt (items start end)
+ (cond
+ ((= start end) nil)
+ ((= (1+ start) end) (list (aref items start)))
+ (t (let ((pivot (truncate (/ (+ start end) 2))))
+ (list (aref items pivot)
+ (itt items start pivot)
+ (itt items (1+ pivot) end)))))))
+ (let ((vect (coerce sequence 'vector)))
+ (itt vect 0 (length vect)))))
+
+ (defun map-tree-postfix (fun tree)
+ (if (null tree)
+ nil
+ (funcall fun
+ (first tree)
+ (map-tree-postfix fun (second tree))
+ (map-tree-postfix fun (third tree))))))
+
+(defmacro decision-tree (expression &rest clauses)
+ "
+CLAUSES: Each clause is of the forms:
+ (less|:less . <body>) ; must be the first clause if present.
+ (<real> . <body>)
+DO: Evaluate the expression, which must be a real,
+ and generate a binary decision tree to select the <body>
+ of the clause whose limit is <= the expression and
+ the next clause limit is > the expression.
+"
+ (let ((vexpr (gensym))
+ (less (when (and (symbolp (first (first clauses)))
+ (string-equal 'less (first (first clauses))))
+ (pop clauses)))
+ (clauses (sort (coerce clauses 'vector) (function <)
+ :key (function car))))
+ `(let ((,vexpr ,expression))
+ ,(map-tree-postfix
+ (let ((index -1))
+ (flet ((gen-case ()
+ (incf index)
+ (if (zerop index)
+ `(progn ,@(cdr less))
+ `(progn ,@(cdr (aref clauses (1- index)))))))
+ (lambda (node left right)
+ (if (and (null left) (null right))
+ `(if (< ,vexpr ,(car node))
+ ,(gen-case)
+ ,(gen-case))
+ `(if (< ,vexpr ,(car node))
+ ,left
+ ,(if (null right)
+ (gen-case)
+ right))))))
+ (infix-to-tree clauses)))))
+
(defun distance-code (distance)
"Return the distance-code for a given DISTANCE"
- (cond ((< distance 5) (1- distance))
- ((<= 5 distance 6) 4)
- ((<= 7 distance 8) 5)
- ((<= 9 distance 12) 6)
- ((<= 13 distance 16) 7)
- ((<= 17 distance 24) 8)
- ((<= 25 distance 32) 9)
- ((<= 33 distance 48) 10)
- ((<= 49 distance 64) 11)
- ((<= 65 distance 96) 12)
- ((<= 97 distance 128) 13)
- ((<= 129 distance 192) 14)
- ((<= 193 distance 256) 15)
- ((<= 257 distance 384) 16)
- ((<= 385 distance 512) 17)
- ((<= 513 distance 768) 18)
- ((<= 769 distance 1024) 19)
- ((<= 1025 distance 1536) 20)
- ((<= 1537 distance 2048) 21)
- ((<= 2049 distance 3072) 22)
- ((<= 3073 distance 4096) 23)
- ((<= 4097 distance 6144) 24)
- ((<= 6145 distance 8192) 25)
- ((<= 8193 distance 12288) 26)
- ((<= 12289 distance 16384) 27)
- ((<= 16385 distance 24576) 28)
- ((<= 24577 distance 32768) 29)
- (t (error "A distance larger than 32768 is illegal"))))
+ (decision-tree distance
+ (less (1- distance))
+ (5 4)
+ (7 5)
+ (9 6)
+ (13 7)
+ (17 8)
+ (25 9)
+ (33 10)
+ (49 11)
+ (65 12)
+ (97 13)
+ (129 14)
+ (193 15)
+ (257 16)
+ (385 17)
+ (513 18)
+ (769 19)
+ (1025 20)
+ (1537 21)
+ (2049 22)
+ (3073 23)
+ (4097 24)
+ (6145 25)
+ (8193 26)
+ (12289 27)
+ (16385 28)
+ (24577 29)
+ (32769 (error "A distance larger than 32768 is illegal"))))
+
-;; FIXME. It should be possible to do this smarter
(defun length-code (length)
"Return the length-code for a given LENGTH"
- (cond ((<= length 10) (+ 254 length))
- ((<= 11 length 12) 265)
- ((<= 13 length 14) 266)
- ((<= 15 length 16) 267)
- ((<= 17 length 18) 268)
- ((<= 19 length 22) 269)
- ((<= 23 length 26) 270)
- ((<= 27 length 30) 271)
- ((<= 31 length 34) 272)
- ((<= 35 length 42) 273)
- ((<= 43 length 50) 274)
- ((<= 51 length 58) 275)
- ((<= 59 length 66) 276)
- ((<= 67 length 82) 277)
- ((<= 83 length 98) 278)
- ((<= 99 length 114) 279)
- ((<= 115 length 130) 280)
- ((<= 131 length 162) 281)
- ((<= 163 length 194) 282)
- ((<= 195 length 226) 283)
- ((<= 227 length 257) 284)
- ((= length 258) 285)
- (t (error "A length larger than 258 is illegal"))))
+ (decision-tree length
+ (less (+ 254 length))
+ (11 265)
+ (13 266)
+ (15 267)
+ (17 268)
+ (19 269)
+ (23 270)
+ (27 271)
+ (31 272)
+ (35 273)
+ (43 274)
+ (51 275)
+ (59 276)
+ (67 277)
+ (83 278)
+ (99 279)
+ (115 280)
+ (131 281)
+ (163 282)
+ (195 283)
+ (227 284)
+ (258 285)
+ (259 (error "A length larger than 258 is illegal"))))
(defun distance-code-bits (code)
"Return a list with 5 elements that are the binary representation of CODE."
More information about the Zlib-cvs
mailing list