Changeset 13464


Ignore:
Timestamp:
Feb 25, 2010, 9:33:10 PM (10 years ago)
Author:
gb
Message:

Use *VECTOR-OUTPUT-STREAM-DEFAULT-INITIAL-ALLOCATION* to control ...
size of initial vector output stream vector allocation.

Speed up integer encoding.

Fix fenceposts in STREAM-POSITION.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/l1-streams.lisp

    r13459 r13464  
    61016101
    61026102
     6103
     6104(defparameter *vector-output-stream-default-initial-allocation* 64 "Default size of the vector created by (MAKE-VECTOR-OUTPUT-STREAM), in octets.")
     6105
    61036106;;; Bivalent vector streams.
    61046107(make-built-in-class 'vector-stream 'basic-binary-stream 'basic-character-stream)
     
    61436146               (%err-disp $XMALADJUST displaced))
    61446147             (let* ((len (%svref displaced target::vectorH.physsize-cell))
    6145                     (newlen (max (the fixnum (+ len len)) 16))
     6148                    (newlen (max (the fixnum (+ len len)) (+ len *vector-output-stream-default-initial-allocation*)))
    61466149                    (new (%alloc-misc newlen target::subtag-u8-vector)))
    61476150               (declare (fixnum len newlen)
     
    62146217    new))
    62156218
    6216 ;;; return something equivalent to (LOGAND #xFF (ASH M (- (* N 8)))),
    6217 ;;; though try to do it more quickly.
    6218 (declaim (inline nth-octet-of-signed-integer))
    6219 (defun nth-octet-of-signed-integer (m n)
    6220   (declare (fixnum n))
    6221   (etypecase m
    6222     (fixnum
    6223      (locally
    6224          (declare (fixnum m))
    6225        (logand #xff (the fixnum (%iasr (the fixnum (ash n 3)) m)))))
    6226     (bignum
    6227      (let* ((nbytes (ash (the fixnum (uvsize m)) 2)))
    6228        (declare (fixnum nbytes))
    6229        (declare (type (simple-array (unsigned-byte 8) (*)) m)
    6230                 (optimize (speed 3) (safety 0)))
    6231        (if (< n nbytes)
    6232          (aref m #+big-endian-target (the fixnum (logxor n 3)) #+little-endian-target n)
    6233          (if (logbitp 7 (the (unsigned-byte 8) (aref m (the fixnum (- nbytes #+big-endian-target 4 #+little-endian-target 1)))))
    6234            #xff
    6235            #x00))))))
    6236 
    6237 (declaim (inline nth-octet-of-unsigned-integer))
    6238 (defun nth-octet-of-unsigned-integer (m n)
    6239   (declare (fixnum n))
    6240   (etypecase m
    6241     (fixnum
    6242      (locally
    6243          (declare (fixnum m))
    6244        (logand #xff (the fixnum (%ilsr (the fixnum (ash n 3)) m)))))
    6245     (bignum
    6246      (let* ((nbytes (ash (the fixnum (uvsize m)) 2)))
    6247        (declare (fixnum nbytes))
    6248        (declare (type (simple-array (unsigned-byte 8) (*)) m)
    6249                 (optimize (speed 3) (safety 0)))
    6250        (if (< n nbytes)
    6251          (aref m #+big-endian-target (the fixnum (logxor n 3)) #+little-endian-target n)
    6252          0)))))
    6253 
    62546219
    62556220(defun unsigned-integer-to-binary (value len s)
     
    62696234             ((simple-array (unsigned-byte 8) (*)) buffer)
    62706235             (optimize (speed 3) (safety 0)))
    6271     (do* ((n (1- len) (1- n)))
    6272          ((< n 0) (progn
    6273                     (setf (io-buffer-idx outbuf) idx
    6274                           (io-buffer-count outbuf) idx)
    6275                     value))
    6276       (declare (fixnum n))
    6277       (when (= idx limit)
    6278         (%ioblock-force-output ioblock nil)
    6279         (setq limit (io-buffer-limit outbuf)
    6280               buffer (io-buffer-buffer outbuf)))
    6281       (setf (aref buffer idx) (nth-octet-of-unsigned-integer value n))
    6282       (incf idx))))
     6236    (etypecase value
     6237      (fixnum
     6238       (if (< (the fixnum value) 0)
     6239         (report-bad-arg value 'unsigned-byte))
     6240       (do* ((shift (ash(the fixnum (1- len)) 3) (- shift 8)))
     6241            ((< shift 0) (progn
     6242                           (setf (io-buffer-idx outbuf) idx)
     6243                           (if (> idx (the fixnum (io-buffer-count outbuf)))
     6244                             (setf (io-buffer-count outbuf) idx))
     6245                           value))
     6246         (declare (fixnum shift))
     6247         (when (= idx limit)
     6248           (%ioblock-force-output ioblock nil)
     6249           (setq limit (io-buffer-limit outbuf)
     6250                 buffer (io-buffer-buffer outbuf)))
     6251         (setf (aref buffer idx) (logand #xff (the fixnum (%iasr shift value))))
     6252         (incf idx)))
     6253      (bignum
     6254       (locally
     6255           (declare ((simple-array (unsigned-byte 8) (*)) value))
     6256         (let* ((nbytes (ash (uvsize value) 2))
     6257                (sign-byte (if (logbitp 7 (the (unsigned-byte 8) (aref value (the fixnum (- nbytes #+big-endian-target 4 #+little-endian-target 1))))) #xff #x00)))
     6258           (declare (fixnum nbytes)
     6259                    ((unsigned-byte 8) sign-byte))
     6260           (unless (zerop sign-byte)
     6261             (report-bad-arg value 'unsigned-byte))
     6262           (do* ((n (1- len) (1- n)))
     6263                ((< n 0) (progn
     6264                           (setf (io-buffer-idx outbuf) idx)
     6265                           (if (> idx (the fixnum (io-buffer-count outbuf)))
     6266                             (setf (io-buffer-count outbuf) idx))
     6267                           value))
     6268             (declare (fixnum n))
     6269             (when (= idx limit)
     6270               (%ioblock-force-output ioblock nil)
     6271               (setq limit (io-buffer-limit outbuf)
     6272                     buffer (io-buffer-buffer outbuf)))
     6273             (setf (aref buffer idx)
     6274                   (if (>= n nbytes)
     6275                     0
     6276                     (aref value #+little-endian-target n #+big-endian-target (the fixnum (logxor n 3)))))
     6277             (incf idx))))))))
    62836278
    62846279(defun signed-integer-to-binary (value len s)
     
    62986293             ((simple-array (unsigned-byte 8) (*)) buffer)
    62996294             (optimize (speed 3) (safety 0)))
    6300     (do* ((n (1- len) (1- n)))
    6301          ((< n 0) (progn
    6302                     (setf (io-buffer-idx outbuf) idx
    6303                           (io-buffer-count outbuf) idx)
    6304                     value))
    6305       (declare (fixnum n))
    6306       (when (= idx limit)
    6307         (%ioblock-force-output ioblock nil)
    6308         (setq limit (io-buffer-limit outbuf)
    6309               buffer (io-buffer-buffer outbuf)))
    6310       (setf (aref buffer idx) (nth-octet-of-signed-integer value n))
    6311       (incf idx))))
     6295    (do* ((newidx (+ idx len)))
     6296         ((< newidx limit))
     6297      (declare (fixnum newidx))
     6298      (%ioblock-force-output ioblock nil)
     6299      (setq limit (io-buffer-limit outbuf)
     6300            buffer (io-buffer-buffer outbuf)))
     6301    (etypecase value
     6302      (fixnum
     6303       (do* ((shift (ash (the fixnum (1- len)) 3) (- shift 8)))
     6304            ((< shift 0) (progn
     6305                           (setf (io-buffer-idx outbuf) idx)
     6306                           (if (> idx (the fixnum (io-buffer-count outbuf)))
     6307                             (setf (io-buffer-count outbuf) idx))
     6308                           value))
     6309         (declare (fixnum shift))
     6310         (setf (aref buffer idx) (logand #xff (the fixnum (%iasr shift value))))
     6311         (incf idx)))
     6312      (bignum
     6313       (locally
     6314           (declare ((simple-array (unsigned-byte 8) (*)) value))
     6315         (let* ((nbytes (ash (uvsize value) 2))
     6316                (sign-byte (if (logbitp 7 (the (unsigned-byte 8) (aref value (the fixnum (- nbytes #+big-endian-target 4 #+little-endian-target 1))))) #xff #x00)))
     6317           (declare (fixnum nbytes)
     6318                    ((unsigned-byte 8) sign-byte))
     6319           (do* ((n (1- len) (1- n)))
     6320                ((< n 0) (progn
     6321                           (setf (io-buffer-idx outbuf) idx)
     6322                           (if (> idx (the fixnum (io-buffer-count outbuf)))
     6323                             (setf (io-buffer-count outbuf) idx))
     6324                           value))
     6325             (declare (fixnum n))
     6326             (setf (aref buffer idx)
     6327                   (if (>= n nbytes)
     6328                     sign-byte
     6329                     (aref value #+little-endian-target n #+big-endian-target (the fixnum (logxor n 3)))))
     6330             (incf idx))))))))
     6331     
    63126332             
    63136333               
     
    63536373   
    63546374(defun make-vector-output-stream (&key (external-format :default))
    6355   (%make-vector-output-stream (make-array 64 :element-type '(unsigned-byte 8))  external-format))
     6375  (%make-vector-output-stream (make-array *vector-output-stream-default-initial-allocation* :element-type '(unsigned-byte 8))  external-format))
    63566376
    63576377(defmethod stream-position ((s vector-output-stream) &optional newpos)
     
    63666386        (let* ((scaled-new (+ origin (the fixnum newpos))))
    63676387          (declare (fixnum scaled-new))
    6368           (setf (io-buffer-idx outbuf) scaled-new
    6369                 (io-buffer-count outbuf) scaled-new)
     6388          (setf (io-buffer-idx outbuf) scaled-new)
     6389          (if (> (the fixnum (io-buffer-count outbuf)) scaled-new)
     6390            (setf (io-buffer-count outbuf) scaled-new))
     6391          (let* ((displaced (vector-output-stream-ioblock-displaced ioblock)))
     6392            (when displaced
     6393              (setf (fill-pointer displaced) newpos)))
    63706394          newpos)
    6371         (report-bad-arg newpos `(integer 0 `(,(+ origin (the fixnum (io-buffer-limit outbuf)))))))
     6395        (report-bad-arg newpos `(integer 0 `(,(- (the fixnum (io-buffer-limit outbuf)) origin)))))
    63726396      (the fixnum (- (the fixnum (io-buffer-idx outbuf)) origin)))))
    63736397
     
    64816505         (limit (io-buffer-limit inbuf))
    64826506         (vector (io-buffer-buffer inbuf)))
    6483     (declare (fixnum idx limit end)
    6484              ((simple-array (unsigned-byte 8) (*)) vector))
     6507    (declare (fixnum idx limit end))
    64856508    (if (< limit end)
    64866509      (error "Integer decoding error"))
     
    65016524          (setf (io-buffer-idx inbuf) (the fixnum (+ origin (the fixnum newpos))))
    65026525          newpos)
    6503         (report-bad-arg newpos `(integer 0 `(,(+ origin (the fixnum (io-buffer-limit inbuf)))))))
     6526        (report-bad-arg newpos `(integer 0 `(,(- (the fixnum (io-buffer-limit inbuf)) origin)))))
    65046527      (the fixnum (- (the fixnum (io-buffer-idx inbuf)) origin)))))
    65056528
Note: See TracChangeset for help on using the changeset viewer.