Changeset 15165


Ignore:
Timestamp:
Jan 19, 2012, 1:47:48 AM (8 years ago)
Author:
gb
Message:

Except on the PPC (which has LAP versions of %EXTEND-VECTOR), define
%EXTEND-VECTOR in terms of %UVECTOR-REPLACE, which can use things like
%COPY-IVECTOR-TO-IVECTOR.

Make %UVECTOR-REPLACE work on non-CL-array uvector types, too.

When creating an fd-based stream (in MAKE-FD-STREAM and MAKE-FILE-STREAM),
if the stream is capable of character I/O it'll be buffered by an octet
vector, so call OPTIMAL-BUFFER-SIZE with the appropriate element type.
On Windows, use the arbitrary buffer size of 4K octets (rather than #$BUFSIZ).

In %IOBLOCK-UNENCODED-READ-LINE, if we haven't seen a newline in the first
few bufferfuls of data, stop expecting to do so (and grow the string in
larger increments less often.)

In the more generic READ-LINE cases, use a SIMPLE-STRING (and track
its length and current position manually) rather than a string with a
fill-pointer.

Location:
trunk/source
Files:
6 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-0/ARM/arm-array.lisp

    r15093 r15165  
    226226
    227227
    228 ;;; Make a new vector of size newsize whose subtag matches that of oldv-arg.
    229 ;;; Blast the contents of the old vector into the new one as quickly as
    230 ;;; possible; leave remaining elements of new vector undefined (0).
    231 ;;; Return new-vector.
    232 (defun %extend-vector (start oldv newsize)
    233   (declare (fixnum start))
    234   (let* ((new (%alloc-misc newsize (typecode oldv)))
    235          (oldsize (uvsize oldv)))
    236     (declare (fixnum oldsize))
    237     (do* ((i 0 (1+ i))
    238           (j start (1+ j)))
    239          ((= i oldsize) new)
    240       (declare (fixnum i j))
    241       (setf (uvref new j) (uvref oldv i)))))
    242 
    243 
    244228
    245229
  • trunk/source/level-0/X86/X8632/x8632-array.lisp

    r13412 r15165  
    2828;;; possible; leave remaining elements of new vector undefined (0).
    2929;;; Return new-vector.
    30 (defun %extend-vector (start oldv newsize)
    31   (declare (fixnum start))
    32   (let* ((new (%alloc-misc newsize (typecode oldv)))
    33          (oldsize (uvsize oldv)))
    34     (declare (fixnum oldsize))
    35     (do* ((i 0 (1+ i))
    36           (j start (1+ j)))
    37          ((= i oldsize) new)
    38       (declare (fixnum i j))
    39       (setf (uvref new j) (uvref oldv i)))))
     30
    4031   
    4132;;; argument is a vector header or an array header.  Or else.
  • trunk/source/level-0/X86/x86-array.lisp

    r13413 r15165  
    196196;;; possible; leave remaining elements of new vector undefined (0).
    197197;;; Return new-vector.
    198 (defun %extend-vector (start oldv newsize)
    199   (declare (fixnum start))
    200   (let* ((new (%alloc-misc newsize (typecode oldv)))
    201          (oldsize (uvsize oldv)))
    202     (declare (fixnum oldsize))
    203     (do* ((i 0 (1+ i))
    204           (j start (1+ j)))
    205          ((= i oldsize) new)
    206       (declare (fixnum i j))
    207       (setf (uvref new j) (uvref oldv i)))))
     198
    208199   
    209200
  • trunk/source/level-0/l0-array.lisp

    r15158 r15165  
    399399;;; Both TARGET and SOURCE are (SIMPLE-ARRAY (*) *), and all of the
    400400;;; indices are fixnums and in bounds.
     401;;; (Actually, we allow some internal uvector types as well as CL vectors.)
    401402(defun %uvector-replace (target target-start source source-start n typecode)
    402403  (declare (fixnum target-start n source-start n typecode)
    403404           (optimize (speed 3) (safety 0)))
    404   (ecase typecode
    405     (#.target::subtag-simple-vector
    406      (if (and (eq source target)
    407               (> target-start source-start))
    408        (do* ((i 0 (1+ i))
    409              (source-pos (1- (the fixnum (+ source-start n)))
    410                          (1- source-pos))
    411              (target-pos (1- (the fixnum (+ target-start n)))
    412                          (1- target-pos)))
    413             ((= i n))
    414          (declare (fixnum i source-pos target-pos))
    415          (setf (svref target target-pos) (svref source source-pos)))
    416        (dotimes (i n)
    417          (setf (svref target target-start) (svref source source-start))
    418          (incf target-start)
    419          (incf source-start))))
    420     (#.target::subtag-bit-vector
    421      (if (and (eq source target)
    422               (> target-start source-start))
    423        (do* ((i 0 (1+ i))
    424              (source-pos (1- (the fixnum (+ source-start n)))
    425                          (1- source-pos))
    426              (target-pos (1- (the fixnum (+ target-start n)))
    427                          (1- target-pos)))
    428             ((= i n))
    429          (declare (fixnum i source-pos target-pos))
    430          (setf (sbit target target-pos) (sbit source source-pos)))
    431        (dotimes (i n)
    432          (setf (sbit target target-start) (sbit source source-start))
    433          (incf target-start)
    434          (incf source-start))))
    435     ;; All other cases can be handled with %COPY-IVECTOR-TO-IVECTOR,
    436     ;; which knows how to handle overlap
    437     ((#.target::subtag-s8-vector
    438       #.target::subtag-u8-vector)
    439      (%copy-ivector-to-ivector source
    440                                source-start
    441                                target
    442                                target-start
    443                                n))
    444     ((#.target::subtag-s16-vector
    445       #.target::subtag-u16-vector)
    446      (%copy-ivector-to-ivector source
    447                                (the fixnum (* source-start 2))
    448                                target
    449                                (the fixnum (* target-start 2))
    450                                (the fixnum (* n 2))))
    451     ((#.target::subtag-s32-vector
    452       #.target::subtag-u32-vector
    453       #.target::subtag-single-float-vector
    454       #.target::subtag-simple-base-string
    455       #+32-bit-target #.target::subtag-fixnum-vector)
    456      (%copy-ivector-to-ivector source
    457                                (the fixnum (* source-start 4))
    458                                target
    459                                (the fixnum (* target-start 4))
    460                                (the fixnum (* n 4))))
    461     ((#.target::subtag-double-float-vector
    462       #+64-bit-target #.target::subtag-s64-vector
    463       #+64-bit-target #.target::subtag-u64-vector
    464       #+64-bit-target #.target::subtag-fixnum-vector)
    465      (%copy-ivector-to-ivector source
    466                                (the fixnum
    467                                  (+ (the fixnum (- target::misc-dfloat-offset
    468                                                    target::misc-data-offset))
    469                                     (the fixnum (* source-start 8))))
    470                                target
    471                                (the fixnum
    472                                  (+ (the fixnum (- target::misc-dfloat-offset
    473                                                    target::misc-data-offset))
    474                                     (the fixnum (* target-start 8))))
    475                                (the fixnum (* n 8)))))
     405  (if (gvectorp target)
     406    (if (and (eq source target)
     407             (> target-start source-start))
     408      (do* ((i 0 (1+ i))
     409            (source-pos (1- (the fixnum (+ source-start n)))
     410                        (1- source-pos))
     411            (target-pos (1- (the fixnum (+ target-start n)))
     412                        (1- target-pos)))
     413           ((= i n))
     414        (declare (fixnum i source-pos target-pos))
     415        (setf (%svref target target-pos) (%svref source source-pos)))
     416      (dotimes (i n)
     417        (setf (%svref target target-start) (%svref source source-start))
     418        (incf target-start)
     419        (incf source-start)))
     420    (ecase typecode
     421      (#.target::subtag-bit-vector
     422       (if (and (eq source target)
     423                (> target-start source-start))
     424         (do* ((i 0 (1+ i))
     425               (source-pos (1- (the fixnum (+ source-start n)))
     426                           (1- source-pos))
     427               (target-pos (1- (the fixnum (+ target-start n)))
     428                           (1- target-pos)))
     429              ((= i n))
     430           (declare (fixnum i source-pos target-pos))
     431           (setf (sbit target target-pos) (sbit source source-pos)))
     432         (dotimes (i n)
     433           (setf (sbit target target-start) (sbit source source-start))
     434           (incf target-start)
     435           (incf source-start))))
     436      ;; All other cases can be handled with %COPY-IVECTOR-TO-IVECTOR,
     437      ;; which knows how to handle overlap
     438      ((#.target::subtag-s8-vector
     439        #.target::subtag-u8-vector)
     440       (%copy-ivector-to-ivector source
     441                                 source-start
     442                                 target
     443                                 target-start
     444                                 n))
     445      ((#.target::subtag-s16-vector
     446        #.target::subtag-u16-vector)
     447       (%copy-ivector-to-ivector source
     448                                 (the fixnum (* source-start 2))
     449                                 target
     450                                 (the fixnum (* target-start 2))
     451                                 (the fixnum (* n 2))))
     452      ((#.target::subtag-s32-vector
     453        #.target::subtag-u32-vector
     454        #.target::subtag-single-float-vector
     455        #.target::subtag-simple-base-string
     456        #.target::subtag-bignum
     457        #.target::subtag-single-float
     458        #.target::subtag-double-float
     459        #+32-bit-target #.target::subtag-fixnum-vector)
     460       (%copy-ivector-to-ivector source
     461                                 (the fixnum (* source-start 4))
     462                                 target
     463                                 (the fixnum (* target-start 4))
     464                                 (the fixnum (* n 4))))
     465      ((#.target::subtag-double-float-vector
     466        #+64-bit-target #.target::subtag-s64-vector
     467        #+64-bit-target #.target::subtag-u64-vector
     468        #+64-bit-target #.target::subtag-fixnum-vector)
     469       (%copy-ivector-to-ivector source
     470                                 (the fixnum
     471                                   (+ (the fixnum (- target::misc-dfloat-offset
     472                                                     target::misc-data-offset))
     473                                      (the fixnum (* source-start 8))))
     474                                 target
     475                                 (the fixnum
     476                                   (+ (the fixnum (- target::misc-dfloat-offset
     477                                                     target::misc-data-offset))
     478                                      (the fixnum (* target-start 8))))
     479                                 (the fixnum (* n 8))))))
    476480  target)
    477481
     
    867871  (%misc-set v i new))
    868872
     873#-ppc-target
     874(defun %extend-vector (start oldv newsize)
     875  (declare (fixnum start))
     876  (let* ((typecode (typecode oldv))
     877         (new (%alloc-misc newsize typecode))
     878         (oldsize (uvsize oldv)))
     879    (declare (fixnum oldsize) (type (unsigned-byte 8) typecode))
     880    (%uvector-replace  new start oldv 0 oldsize typecode)))
     881
    869882
    870883
  • trunk/source/level-1/l1-streams.lisp

    r14833 r15165  
    102102;; From Shannon Spires, slightly modified.
    103103(defun generic-read-line (s)
    104   (let* ((str (make-array 20 :element-type 'base-char
    105                           :adjustable t :fill-pointer 0))
     104  (let* ((len 20)
     105         (pos 0)
     106         (str (make-array len :element-type 'base-char))
    106107         (eof nil))
     108    (declare (fixnum pos len) (simple-string str))
    107109    (do* ((ch (read-char s nil :eof) (read-char s nil :eof)))
    108110         ((or (eq ch #\newline) (setq eof (eq ch :eof)))
    109           (values (ensure-simple-string str) eof))
    110       (vector-push-extend ch str))))
     111          (values (subseq str 0 pos) eof))
     112      (when (= pos len)
     113        (setq len (* len 2)
     114              str (%extend-vector 0 str len)))
     115      (setf (schar str pos) ch
     116            pos (1+ pos)))))
    111117
    112118(defun generic-character-read-list (stream list count)
     
    22972303           (len 0)
    22982304           (eof nil)
     2305           (filled-buf 0)
    22992306           (buf (io-buffer-buffer inbuf))
    23002307           (newline (char-code #\newline)))
     2308      (declare (fixnum filled-buf))
    23012309      (let* ((ch (ioblock-untyi-char ioblock)))
    23022310        (when ch
     
    23132321               (idx (io-buffer-idx inbuf))
    23142322               (count (io-buffer-count inbuf)))
    2315           (declare (fixnum idx count more))
     2323          (declare (fixnum idx count more filled-buf))
    23162324          (if (= idx count)
    23172325            (if eof
     
    23192327              (progn
    23202328                (setq eof t)
     2329                (incf filled-buf)
    23212330                (%ioblock-advance ioblock t)))
    23222331            (progn
     
    23422351                (%copy-u8-to-string
    23432352                 buf idx string len more)
    2344                 (incf len more)))))))))
     2353                (incf len more))
     2354              (when (> filled-buf 1)
     2355                (let* ((pos len))
     2356                  (loop
     2357                    (%ioblock-advance ioblock t)
     2358                    (setq count (io-buffer-count inbuf))
     2359                    (when (zerop count)                       
     2360                      (return-from %ioblock-unencoded-read-line
     2361                        (values (if (= pos len)
     2362                                  string
     2363                                  (subseq string 0 pos))
     2364                                t)))
     2365                    (let* ((p (position newline buf :end count))
     2366                           (n (or p count))
     2367                           (room (- len pos)))
     2368                      (declare (fixnum n room))
     2369                      (when (< room n)
     2370                        (setq len (+ len (the fixnum (or p len)))
     2371                              string (%extend-vector 0 string len)))
     2372                      (%copy-u8-to-string buf 0 string pos n)
     2373                      (incf pos n)
     2374                      (when p
     2375                        (return-from %ioblock-unencoded-read-line
     2376                          (values (if (= pos len)
     2377                                    string
     2378                                    (subseq string 0 pos)) nil)))
     2379                      (setf (io-buffer-idx inbuf) count))))))))))))
    23452380
    23462381;;; There are lots of ways of doing better here, but in the most general
     
    23482383;;; whether there's a 1:1 mapping between code units and characters.
    23492384(defun %ioblock-encoded-read-line (ioblock)
    2350   (let* ((str (make-array 20 :element-type 'base-char
    2351                           :adjustable t :fill-pointer 0))
     2385  (let* ((pos 0)
     2386         (len 20)
     2387         (str (make-string len))
    23522388         (rcf (ioblock-read-char-when-locked-function ioblock))
    23532389         (eof nil))
     2390    (declare (fixnum pos len) (simple-string str))
    23542391    (do* ((ch (funcall rcf ioblock) (funcall rcf ioblock)))
    23552392         ((or (eq ch #\newline) (setq eof (eq ch :eof)))
    2356           (values (ensure-simple-string str) eof))
    2357       (vector-push-extend ch str))))
     2393          (values (subseq str 0 pos) eof))
     2394      (when (= pos len)
     2395        (setq len (* len 2) str (%extend-vector 0 str len)))
     2396      (setf (schar str pos) ch
     2397            pos (1+ pos)))))
    23582398         
    23592399(defun %ioblock-unencoded-character-read-vector (ioblock vector start end)
     
    33443384             (8 (ash octets -3)))))
    33453385    #+windows-target
    3346     (let ((octets #$BUFSIZ))
     3386    (let ((octets 4096))
    33473387      (scale-buffer-size octets))
    33483388    #-windows-target
  • trunk/source/level-1/l1-sysio.lisp

    r15138 r15165  
    774774        ((:io :output) nil)
    775775        (t (report-bad-arg direction '(member :input :output :io :probe))))
    776       (check-pathname-not-wild filename) ;; probe-file-x misses wild versions....
     776      (check-pathname-not-wild filename) ; probe-file-x misses wild versions....
    777777      (multiple-value-bind (native-truename kind) (probe-file-x filename)
    778778        (tagbody retry
     
    805805                   (when (null if-exists) (return-from open nil))
    806806                   (multiple-value-setq (native-truename kind) (probe-file-x filename))
    807                    (unless native-truename ;; huh?  Perhaps it disappeared again?
     807                   (unless native-truename ; huh?  Perhaps it disappeared again?
    808808                     (error "Attempt to create ~s failed unexpectedly" filename))
    809809                   (go retry))
     
    830830                       (char-p (or (eq element-type 'character)
    831831                                   (subtypep element-type 'character)))
    832                        (elements-per-buffer (optimal-buffer-size fd element-type))
     832                       (elements-per-buffer (optimal-buffer-size fd (if char-p '(unsigned-byte 8) element-type)))
    833833                       (real-external-format
    834834                        (if char-p
Note: See TracChangeset for help on using the changeset viewer.