Switch branches/tags
release10.1_t6 release10.1_t5 release10.1_t4 release10.1_t3 release10.1_t2 release10.1_t1 release10.1_release_point release10.1_rc5 release10.1_rc4 release10.1_rc3 release10.1_rc2 release10.1_rc1 release10.1_beta3_release_point release10.1.beta2_release_point release10.1.beta_t6 release10.1.beta_t5 release10.1.beta_t4 release10.1.beta_t3 release10.1.beta_t2 release10.1.beta_t1 release10.1.beta_release_point release10.1.beta_rc4 release10.1.beta_rc3 release10.1.beta_rc2 release10.1.beta_rc1 release10.0_t3 release10.0_t2 release10.0_t1 release10.0_rc9 release10.0_rc8 release10.0_rc7 release10.0_rc6 release10.0_rc5 release10.0_rc4 release10.0_rc3 release10.0_rc2 release10.0_rc1 release10.0.pre-final.30_release_point release10.0.pre-final.17_release_point release10.0.beta_t13 release10.0.beta_t12 release10.0.beta_t11 release10.0.beta_t10 release10.0.beta_t9 release10.0.beta_t8 release10.0.beta_t7 release10.0.beta_t6 release10.0.beta_t5 release10.0.beta_t4 release10.0.beta_t3 release10.0.beta_t2 release10.0.beta_t1 release10.0.beta_release_point release10.0.beta_rc2 release10.0.beta_rc1 release_aclt2 release_acl100b14t8 release_acl100b11t7 release_acl100b10t6 release_acl100b8t5 release_acl100b7t4 release_acl100b6t3 release_acl100b4t2 release_acl100b2t1 release_acl90b21rc5 release_acl90b20_release_point release_acl90b20rc4 release_acl90b19rc3 release_acl90b18rc2 release_acl90b15_release_point release_acl90b15rc1 release_acl90b13t1 release_acl90b11t1 release_acl90b9t1 release_acl90b8t1 release_acl90b6_release_point release_acl90b6rc2 release_acl90b_release_point release_acl90a52rc1 release_acl90a44rc2 release_acl90a43rc1 release_acl90a39 release_acl90a39rc2 release_acl90a32 release_acl90a27 release_acl90a25 release_acl90a24 release_acl90a23 release_acl90a20 release_acl90a18 install-spider_2013-04-26T12-55-31 install-spider_2013-04-25T12-56-58 install-spider_2013-04-24T16-52-55 install-spider_2013-04-24T16-42-42 install-spider_2013-04-24T16-29-36 install-spider_2013-04-24T15-47-16 install-spider_2013-04-24T15-37-01 install-spider_2013-04-24T15-02-09 install-spider_2013-04-23T11-10-35 install-spider_2013-04-12T14-51-27
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
585 lines (433 sloc) 16.6 KB
;; stream for doing compression
;; code based on from AllegroGraph written by marijnh
;; while under contract with Franz.
;; See the file LICENSE for the full license governing this code.
#+(version= 10 1)
(sys:defpatch "deflate" 1
"v1: internal change for aserve."
:type :system
:post-loadable t)
#+(version= 10 0)
(sys:defpatch "deflate" 2
"v2: internal change for aserve;
v1: add hook run when a deflate stream closes."
:type :system
:post-loadable t)
#+(version= 9 0)
(sys:defpatch "deflate" 2
"v2: internal change for aserve;
v1: add hook run when a deflate stream closes."
:type :system
:post-loadable t)
(:use :common-lisp :excl)
;; NOTE: this stream class is defined even when the foreign loading
;; below fails. Applications that use this module should check
;; that :zlib-deflate is on *features* before using this class.
(eval-when (compile load eval)
(defconstant *zlib-in-buffer-size* (* 16 1024))
(defconstant *zlib-out-buffer-size* (* 17 1024))
;; deflate-stream
;; create via
;; (make-instance 'deflate-stream :target stream-or-vector
;; :compression ckind)
;; The target argument is required. It says where to compressed
;; data.
;; The :compression argument is optional. It can be :gzip,
;; :zlib, or :deflate. If not given :gzip is assumed
;; If a stream is given as the :target then the compressed bytes
;; are written to that stream as they are generated.
;; You cannot count on the zlib module to generate
;; compressed bytes immediately. The only time you can be sure
;; that all the compressed bytes have been send to the stream
;; is after you close the deflate-stream. After the deflate-stream
;; is closed, the last bits of compressed data is written to
;; the target stream and a force-output is done the target
;; stream. The target stream is NOT closed.
;; If the :target value is a simple vector of (unsigned-byte 8) then
;; the compressed bytes are written to that vector. If that
;; vector fills up then more vectors are allocated.
;; After the deflate-stream is closed you can call
;; deflate-stream-vector to retrieve all off the vectors that contain
;; the compressed data. You can also call deflate-stream-vector-combined
;; to create a single vector containing all of the compressed data.
;; examples
;; (setq str (make-instance 'deflate-stream :target (make-array 1000 :element-type '(unsigned-byte 8))))
;; (dotimes (i 1000) (write-byte (mod i 30) str))
;; (close str)
;; (deflate-stream-vector-combined str)
;; See `NOTE' in export about the availability of this class when requiring
;; this module.
(def-stream-class deflate-stream (single-channel-simple-stream)
;; malloc z-state foreign object
;; holding the info zlib needs to use to run
:initform 0
:accessor z-state)
; using existing slots
; from stream
; flags
; output-handle - stream to vector
; external-format
; from simple-stream
; buffer malloc,ed, contains user written data
; buffer-ptr next byte to write
; charpos always nil since we don't track
; new slots
;; holds malloc'ed zlib struct that controls compression
:initform 0
:accessor zlib-z-stream)
;; malloced buffer to which data is copied before compression
;; since the compressor requires a static buffer
:accessor zlib-in-buffer)
;; malloc buffer holding data after compression
;; it's malloced so it stays still
:initform 0
:accessor zlib-z-buffer)
(in-buffer-ptr :initform 0
:accessor zlib-in-buffer-ptr)
; points to the lispstatic-reclaimable resources for
; this stream. Should the stream be dropped and never
; closed this list will be gc'ed and that will the
; allow the static data to be reclaimed.
(static-resources :initform nil
:accessor zlib-static-resources)
; trace usage
(in-bytes :initform 0
:accessor zlib-in-bytes)
(out-bytes :initform 0
:accessor zlib-out-bytes)
;; for stream target
:initform nil
:accessor deflate-target-stream)
;; for vector target
:initform nil
:accessor zlib-target-vector)
:initform 0
:accessor zlib-target-vector-pos)
; list of full previous target vectors
:initform nil
:accessor zlib-target-vector-old)
;; end vector target
(eval-when (compile load eval) (require :util-string))
(defvar sys::*zlib-system-library*
(excl::machine-case :host
((:msx86 :msx86-64)
;; I don't know of a source for a 64-bit version of this library,
;; but it would be called this if there were one.
((:macosx86 :macosx86-64) "libz.1.dylib")
;;;; FreeBSD changes the name of this library more than other
;;;; platforms, which seem to keep it static between releases.
;;;; The values here are defined per ACL version, which seems the most
;;;; sensible way to do it.
#+(version= 8 2) (:freebsd "")
#+(version= 9 0) ((:freebsd :ipp3) "")
#+(version= 10 0) (:ipp3 "") ;; [bug22946]
#+(version>= 10 0) (:freebsd "") ;; [bug23032]
#+(version>= 9 0) (:freebsd-64 "")
(t (util.string:string+ "libz." sys::*dll-type* ".1"))))
(defvar *zlib-dll-loaded* nil)
(when (not *zlib-dll-loaded*)
(handler-case (load sys::*zlib-system-library* :system-library t :foreign t)
(error (c)
(error "~
This Allegro CL module requires the compression library named libz ~
to be present for the deflate module to load properly. ~
See for versions for various platforms. The ~
actual error:~% ~a" c)))
(setq *zlib-dll-loaded* t))
(pushnew :zlib-deflate *features*)
(provide :deflate)
(ff:def-foreign-type z-stream
(:struct (next-in (* :void)) ; next input byte
(avail-in :unsigned-int) ; number of bytes available at next-in
(total-in :unsigned-long) ; total nb of input bytes read so far
(next-out (* :void)) ; next output byte should be put there
(avail-out :unsigned-int) ; remaining free space at next_out
(total-out :unsigned-long) ; total nb of bytes output so far
(msg (* :char)) ; last error message, NULL if no error
(state (* :void)) ; not visible by applications
(zalloc (* :void)) ; used to allocate the internal state
(zfree (* :void)) ; used to free the internal state
(opaque (* :void)) ; private data object passed to zalloc and zfree
(data-type :int) ; best guess about the data type: binary or text
(adler :unsigned-long) ; adler32 value of the uncompressed data
(reserved :unsigned-long))) ; reserved for future use
(ff:def-foreign-type deflate-in-buffer
(:struct (buff (:array :unsigned-char #.*zlib-in-buffer-size*))))
(ff:def-foreign-type deflate-out-buffer
(:struct (buff (:array :unsigned-char #.*zlib-out-buffer-size*))))
(defmacro z-stream-slot (name obj)
`(ff:fslot-value-typed 'z-stream :c ,obj ',name))
(ff:def-foreign-call (deflate-init-2 "deflateInit2_")
((stream (* z-stream))
(level :int)
(method :int)
(window-bits :int)
(mem-level :int)
(strategy :int)
(version (* :char))
(stream-size :int))
:strings-convert t
:returning :int)
(ff:def-foreign-call (deflate "deflate")
((stream (* z-stream))
(flush :int))
:returning :int)
(ff:def-foreign-call (deflate-end "deflateEnd")
((stream (* z-stream)))
:returning :int)
(defmethod print-object ((p deflate-stream) s)
(print-unreadable-object (p s :identity t :type t)
(format s "in ~d / out ~d" (zlib-in-bytes p) (zlib-out-bytes p))))
(defmethod device-open ((p deflate-stream) dummy options)
(declare (ignore dummy))
(let ((output-target (getf options :target))
(compression (or (getf options :compression)
(static-resources (get-deflate-buffer-resources)))
(setf (zlib-static-resources p) static-resources)
(destructuring-bind (z-stream-vec in-buffer-vec out-buffer-vec)
(typecase output-target
(setf (deflate-target-stream p) output-target))
((simple-array (unsigned-byte 8) (*))
(setf (zlib-target-vector p) output-target))
(t (error "the value of initarg :target must be a stream or simple (unsigned-byte 8) vector, not ~s" output-target)))
(if* (not (member compression '(:gzip :zlib :deflate)))
then (error "compression must be :gzip, :zlib, or :deflate, not ~s"
(if* (null output-target)
then (error ":output-target must be given when creating a deflate-stream"))
;; normal these would be written using the with-stream-class
;; macro and sm, but we may want to open source this so best
;; to write it in code that doesn't need a dcl to build
(slot-value p 'excl::buffer) (make-array 4096 :element-type '(unsigned-byte 8))
(zlib-in-buffer p) (ff:fslot-address-typed
(zlib-z-buffer p) (ff:fslot-address-typed
(slot-value p 'excl::buffer-ptr) 0
(zlib-z-stream p) (make-z-stream (ff:fslot-address-typed
(slot-value p 'excl::control-out) excl::*std-control-out-table*
; does some kind of initialization I think
(setf (stream-external-format p)
(stream-external-format p))
(add-stream-instance-flags p :output :simple)
(defun make-z-stream (z-stream type)
(let (
;; windowBits default value is 15 for zlib header and trailer
;; if you add 16 you get gzip header and trailer
;; if windowBits is -15, then you get a raw deflate stream.
(window-bits (+ 15 (ecase type (:gzip 16) (:zlib 0) (:deflate -30)))))
(setf (z-stream-slot zalloc z-stream) 0
(z-stream-slot zfree z-stream) 0
(z-stream-slot opaque z-stream) 0)
(let ((err (deflate-init-2 z-stream
-1 #|default level|#
8 #|default level|#
"" #|version|#
(ff:sizeof-fobject 'z-stream))))
(if* (< err 0 #|Z_OK|#)
then (error "deflateInit2_ returned ~a" err)))
(defun finish-z-stream (z-stream)
;; free C resources controlled by zlib
(deflate-end z-stream))
(defmethod device-write ((p deflate-stream) buffer start end blocking)
;; buffer is an ausb8
;; fill up the internal static buffer
;; do the compressing should the buffer fill up
(declare (ignore blocking))
(let ((in-buffer (zlib-in-buffer p))
(in-buffer-ptr (zlib-in-buffer-ptr p))
(max *zlib-in-buffer-size*)
(buffer (or buffer (slot-value p 'excl::buffer)))
(do ((i start (1+ i)))
((>= i end))
(setf (sys::memref-int in-buffer in-buffer-ptr 0 :unsigned-byte)
(aref buffer i))
(incf in-buffer-ptr)
(if* (>= in-buffer-ptr max)
then ; must flush the buffer
(setf (zlib-in-buffer-ptr p) in-buffer-ptr)
(flush-deflate-stream-input-buffer p)
(setq in-buffer-ptr (zlib-in-buffer-ptr p))))
(setf (zlib-in-buffer-ptr p) in-buffer-ptr)
(defmethod flush-deflate-stream-input-buffer ((p deflate-stream))
;; compress the contents of the input buffer
(let ((z-stream (zlib-z-stream p)))
(setf (z-stream-slot avail-in z-stream) (zlib-in-buffer-ptr p)
(z-stream-slot next-in z-stream) (zlib-in-buffer p))
(incf (zlib-in-bytes p) (zlib-in-buffer-ptr p))
(setf (zlib-in-buffer-ptr p) 0)
(if* (zerop (z-stream-slot avail-in z-stream))
then ; no more to compress
(setf (z-stream-slot next-out z-stream) (zlib-z-buffer p)
(z-stream-slot avail-out z-stream) *zlib-out-buffer-size*)
(let ((error (deflate z-stream 0 ; Z_NO_FLUSH
(if* (< error 0)
then (error "zlib's deflate returned error code ~s" error))
(process-compressed-result p)))))
(defmethod finish-zlib-compression ((p deflate-stream))
;; finish the compression of the contents of the input buffer
(flush-deflate-stream-input-buffer p)
(let ((z-stream (zlib-z-stream p)))
(setf (z-stream-slot next-out z-stream) (zlib-z-buffer p)
(z-stream-slot avail-out z-stream) *zlib-out-buffer-size*)
(let ((error (deflate z-stream 4 ; Z_FINISH
(process-compressed-result p)
(if* (eq error 1) ; Z_STREAM_END
then (return))
(defmethod process-compressed-result ((p deflate-stream))
;; take the resulant compressed bytes and put
;; them somewhere
(let ((static-vec (zlib-z-buffer p))
(bytes (- *zlib-out-buffer-size*
(z-stream-slot avail-out (zlib-z-stream p)))))
(incf (zlib-out-bytes p) bytes)
; we'll just write byte all the values
(let ((target-stream (deflate-target-stream p)))
(if* target-stream
(dotimes (i bytes)
(write-byte (sys:memref-int static-vec i 0 :unsigned-byte)
else (let* ((vec (zlib-target-vector p))
(pos (zlib-target-vector-pos p))
(max (length vec))
(static-base 0))
(let ((docopy (min bytes (- max pos))))
(dotimes (i docopy)
(setf (aref vec (+ pos i))
(sys:memref-int static-vec i static-base :unsigned-byte)))
(if* (> bytes docopy)
then ; we overflowed, more to do
(push vec (zlib-target-vector-old p))
(setq vec (make-array (length vec)
'(unsigned-byte 8)))
(setf (zlib-target-vector p) vec)
(setq pos 0)
(incf static-base docopy)
(decf bytes docopy)
else ; finished
(setf (zlib-target-vector-pos p) (+ pos docopy))
; set to a function to call on the target stream to do
; extra processing on deflate close
(defvar sys::*deflate-target-stream-close-hook* nil)
(defmethod device-close ((p deflate-stream) abort)
(if* (not abort)
then ; flush all current data
(finish-zlib-compression p))
(let ((z-stream (zlib-z-stream p)))
(if* (not (zerop z-stream))
then (finish-z-stream z-stream))
(setf (zlib-z-stream p) 0))
(if* (deflate-target-stream p)
then (force-output (deflate-target-stream p))
(and sys::*deflate-target-stream-close-hook*
(funcall sys::*deflate-target-stream-close-hook*
(deflate-target-stream p)))
;; Free the Lisp resource only after all the uses of
;; the static areas are done. [bug20559]
(free-deflate-buffer-resource (zlib-static-resources p))
(defmethod excl::inner-stream ((p deflate-stream))
(deflate-target-stream p)))
(defmethod deflate-stream-vector ((p deflate-stream))
(let ((vec (zlib-target-vector p)))
(if* vec
then (values vec
(zlib-target-vector-pos p)
(zlib-target-vector-old p))
else (error "deflate-stream ~s was not created with a vector target" p))))
(defmethod deflate-stream-vector-combined ((p deflate-stream))
(multiple-value-bind (last pos old) (deflate-stream-vector p)
(if* old
then ; must combine
(let ((size pos))
(dolist (v old) (incf size (length v)))
(let ((ans (make-array size :element-type '(unsigned-byte 8)))
(start 0))
(dolist (v (reverse old))
(replace ans v :start1 start)
(incf start (length v)))
(replace ans last :start1 start :end2 pos)
(values ans size)))
else (values last pos))))
;; we'll resource the buffers we need to speed up allocation
(defvar *deflate-resource-lock* (mp:make-process-lock))
(defvar *deflate-malloc-resources* nil)
(defun get-deflate-buffer-resources ()
(mp:with-process-lock (*deflate-resource-lock*)
(let ((buffers (pop *deflate-malloc-resources*)))
(if* buffers
else (list (ff:allocate-fobject 'z-stream :foreign-static-gc)
(ff:allocate-fobject 'deflate-in-buffer :foreign-static-gc)
(ff:allocate-fobject 'deflate-out-buffer :foreign-static-gc))))))
(defun free-deflate-buffer-resource (buffers)
(mp:with-process-lock (*deflate-resource-lock*)
(push buffers *deflate-malloc-resources*)))