io.streams/buffer.lisp

   1 ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
   2
   3 ;;   This code is free software; you can redistribute it and/or
   4 ;;   modify it under the terms of the version 2.1 of
   5 ;;   the GNU Lesser General Public License as published by
   6 ;;   the Free Software Foundation, as clarified by the
   7 ;;   preamble found here:
   8 ;;       http://opensource.franz.com/preamble.html
   9 ;;
  10 ;;   This program is distributed in the hope that it will be useful,
  11 ;;   but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;;   GNU General Public License for more details.
  14 ;;
  15 ;;   You should have received a copy of the GNU Lesser General
  16 ;;   Public License along with this library; if not, write to the
  17 ;;   Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
  18 ;;   Boston, MA 02110-1301, USA
  19
  20 (in-package :io.streams)
  21
  22 ;;;
  23 ;;; Foreign Buffers
  24 ;;;
  25
  26 (define-constant +bytes-per-iobuf+ (* 4 1024))
  27
  28 ;; FIXME: make this right
  29 ;; probably not all SIMPLE-ARRAYs are admissible
  30 ;; on all implementations
  31 (deftype compatible-lisp-array ()
  32   '(simple-array * (*)))
  33
  34 (declaim (inline allocate-iobuf free-iobuf
  35                  iobuf-length iobuf-start-pointer
  36                  iobuf-end-pointer iobuf-end-space-length
  37                  iobuf-empty-p iobuf-full-p
  38                  iobuf-reset iobuf-copy-data-to-start
  39                  bref (setf bref) iobuf-copy
  40                  iobuf-pop-octet iobuf-push-octet))
  41
  42 (defun allocate-iobuf (&optional (size +bytes-per-iobuf+))
  43   (let ((b (%make-iobuf)))
  44     (setf (iobuf-data b) (foreign-alloc :uint8 :count size)
  45           (iobuf-size b) size)
  46     (values b)))
  47
  48 (defun free-iobuf (iobuf)
  49   (foreign-free (iobuf-data iobuf))
  50   (setf (iobuf-data iobuf) (null-pointer))
  51   (values iobuf))
  52
  53 (defun iobuf-length (iobuf)
  54   (- (iobuf-end iobuf)
  55      (iobuf-start iobuf)))
  56
  57 (defun iobuf-start-pointer (iobuf)
  58   (inc-pointer (iobuf-data iobuf)
  59                (iobuf-start iobuf)))
  60
  61 (defun iobuf-end-pointer (iobuf)
  62   (inc-pointer (iobuf-data iobuf)
  63                (iobuf-end iobuf)))
  64
  65 (defun iobuf-empty-p (iobuf)
  66   (= (iobuf-end iobuf)
  67      (iobuf-start iobuf)))
  68
  69 (defun iobuf-full-p (iobuf)
  70   (= (iobuf-end iobuf)
  71      (iobuf-size iobuf)))
  72
  73 (defun iobuf-end-space-length (iobuf)
  74   (- (iobuf-size iobuf)
  75      (iobuf-end iobuf)))
  76
  77 (defun iobuf-reset (iobuf)
  78   (setf (iobuf-start iobuf) 0
  79         (iobuf-end iobuf)   0))
  80
  81 (defun iobuf-copy-data-to-start (iobuf)
  82   (declare (type iobuf iobuf))
  83   (et:memmove (iobuf-data iobuf)
  84               (inc-pointer (iobuf-data iobuf)
  85                            (iobuf-start iobuf))
  86               (iobuf-length iobuf)))
  87
  88 ;; BREF, (SETF BREF) and BUFFER-COPY *DO NOT* check boundaries
  89 ;; that must be done by their callers
  90 (defun bref (iobuf index)
  91   (declare (type iobuf iobuf)
  92            (type buffer-index index))
  93   (mem-aref (iobuf-data iobuf) :uint8 index))
  94
  95 (defun (setf bref) (octet iobuf index)
  96   (declare (type (unsigned-byte 8) octet)
  97            (type iobuf iobuf)
  98            (type buffer-index index))
  99   (setf (mem-aref (iobuf-data iobuf) :uint8 index) octet))
 100
 101 (defun iobuf-copy-from-lisp-array (src soff dst doff length)
 102   (declare (type compatible-lisp-array src)
 103            (type iobuf dst)
 104            (type buffer-index soff doff length))
 105   (let ((dst-ptr (iobuf-data dst)))
 106     (with-pointer-to-vector-data (src-ptr src)
 107       (et:memcpy (inc-pointer dst-ptr doff)
 108                  (inc-pointer src-ptr soff)
 109                  length))))
 110
 111 (defun iobuf-copy-into-lisp-array (src soff dst doff length)
 112   (declare (type iobuf src)
 113            (type compatible-lisp-array dst)
 114            (type buffer-index soff doff length))
 115   (let ((src-ptr (iobuf-data src)))
 116     (with-pointer-to-vector-data (dst-ptr dst)
 117       (et:memcpy (inc-pointer dst-ptr doff)
 118                  (inc-pointer src-ptr soff)
 119                  length))))
 120
 121 (defun iobuf-pop-octet (iobuf)
 122   (declare (type iobuf iobuf))
 123   (let ((start (iobuf-start iobuf)))
 124     (prog1 (bref iobuf start)
 125       (incf (iobuf-start iobuf)))))
 126
 127 (defun iobuf-push-octet (iobuf octet)
 128   (declare (type iobuf iobuf)
 129            (type (unsigned-byte 8) octet))
 130   (let ((end (iobuf-end iobuf)))
 131     (prog1 (setf (bref iobuf end) octet)
 132       (incf (iobuf-end iobuf)))))
 133 \f
 134 ;;;
 135 ;;; Buffer Pool
 136 ;;;
 137
 138 (defstruct (iobuf-pool
 139              (:constructor make-iobuf-pool ())
 140              (:copier nil))
 141   (iobufs nil :type list)
 142   (count  0   :type unsigned-byte))
 143
 144 (defvar *available-iobufs* (make-iobuf-pool))
 145
 146 ;; #-clisp
 147 ;; (defvar *iobuf-lock* (bordeaux-threads:make-lock "NET.SOCKETS STREAMS BUFFER POOL LOCK"))
 148
 149 ;; FIXME: using a lock-free queue would be better
 150 (defun next-available-iobuf ()
 151 ;;   #-clisp
 152 ;;   (bordeaux-threads:with-lock-held (*iobuf-lock*)
 153 ;;     (if (iobuf-pool-iobufs *available-iobufs*)
 154 ;;         (progn
 155 ;;           (pop (iobuf-pool-iobufs *available-iobufs*))
 156 ;;           (decf (iobuf-pool-count *available-iobufs*)))
 157 ;;         (%make-iobuf)))
 158 ;;   #+clisp
 159   (if (iobuf-pool-iobufs *available-iobufs*)
 160       (progn
 161         (pop (iobuf-pool-iobufs *available-iobufs*))
 162         (decf (iobuf-pool-count *available-iobufs*)))
 163       (%make-iobuf)))