#:make-server-config
#:log-clear
#:log-tail
+ #:log-resize
#:log-line
#:log-line-nostamp
#:with-log-errors
(log-syslog t :type boolean)
(log-syslog-ident "ecl-mp-server" :type string)
(log-syslog-facility syslog:+log-user+ :type fixnum)
- (log-fifo-lines 0 :type fixnum)
+ (log-history-lines 0 :type fixnum)
(input-timeout 60 :type fixnum)
(children-initial 16 :type fixnum)
(children-minspare 16 :type fixnum)
(svref addr 3)))
-;;; Implementation of a simple thread-safe FIFO buffer with limited entries.
+;;; Implementation of a simple thread-safe backlog buffer minimizing consing
+;;; Eventually compare to a specialized thread
-(defstruct fifo
- "A FIFO buffer. See FIFO-APPEND, FIFO-CLEAR.
-FIFO objects use an internal lock for safe concurrency."
- (head '() :type list)
- (tail '() :type list)
- (count 0 :type fixnum)
+(defstruct (buffer (:constructor %make-buffer))
+ "A history backlog buffer designed to minimize consing and fragmentation.
+See: MAKE-BUFFER, BUFFER-APPEND, BUFFER-CLEAR, BUFFER-HISTORY, BUFFER-RESIZE.
+BUFFER objects use an internal lock for safe concurrency."
+ (buf #() :type (simple-vector *))
+ (head 0 :type fixnum)
+ (tail 0 :type fixnum)
(size 0 :type fixnum)
- (lock (mp:make-lock :name 'fifo-lock) :type mp:lock))
-
-(defun fifo-append (fifo object)
- "Appends OBJECT to FIFO."
+ (lock (mp:make-lock :name 'buffer-lock :recursive t) :type mp:lock))
+
+(defun make-buffer (size)
+ "Creates a new BUFFER which may hold a history of up to SIZE objects."
+ (check-type size fixnum)
+ (let ((size (1+ size)))
+ (%make-buffer :size size
+ :buf (make-array size
+ :initial-element nil
+ :adjustable nil
+ :fill-pointer nil))))
+
+(defun buffer-append (buffer object)
+ "Appends OBJECT to BUFFER, discarding the oldest entry if full.
+Optimized for speed and consing avoidance as may be called very frequently."
(declare (optimize (speed 3) (safety 0) (debug 0)))
- (with-accessors ((head fifo-head) (tail fifo-tail)
- (count fifo-count) (size fifo-size)
- (lock fifo-lock)) fifo
- (mp:with-lock (lock)
- (if (= (the fixnum count) (the fixnum size))
- (setf head (rest head))
- (incf (the fixnum count)))
- (let ((new (cons object nil)))
- (if (null head)
- (setf head new
- tail new)
- (setf (rest tail) new
- tail new)))))
- nil)
+ (with-accessors ((bhead buffer-head) (btail buffer-tail)) buffer
+ (mp:with-lock ((buffer-lock buffer))
+ (let ((head bhead)
+ (tail btail)
+ (size (buffer-size buffer))
+ (buf (buffer-buf buffer)))
+ (declare (type fixnum head tail size)
+ (type (simple-vector *) buf))
+ (let ((newtail (1+ tail)))
+ (declare (type fixnum newtail))
+ (when (= newtail size)
+ (setf newtail 0))
+ (setf (svref buf tail) object
+ btail newtail)
+ (when (= newtail head)
+ (incf head)
+ (when (= head size)
+ (setf head 0))
+ (setf bhead head))))))
+ (values))
-(defun fifo-clear (fifo)
- "Resets/clears FIFO."
- (mp:with-lock ((fifo-lock fifo))
- (let ((list '()))
- (setf (fifo-head fifo) list
- (fifo-tail fifo) list
- (fifo-count fifo) 0)))
- nil)
+(defun buffer-clear (buffer)
+ "Resets/clears BUFFER. Objects may remain referenced until the buffer
+fills again to override them."
+ (mp:with-lock ((buffer-lock buffer))
+ (setf (buffer-head buffer) 0
+ (buffer-tail buffer) 0))
+ (values))
+
+(defun buffer-history (buffer)
+ "Returns a list holding all the currently held objects of BUFFER.
+Conses but is rarely called versus BUFFER-APPEND."
+ (declare (optimize (speed 3) (safety 0) (debug 0)))
+ (check-type buffer buffer)
+ (mp:with-lock ((buffer-lock buffer))
+ (loop
+ with vector of-type (simple-vector *) = (buffer-buf buffer)
+ with head of-type fixnum = (buffer-head buffer)
+ with tail of-type fixnum = (buffer-tail buffer)
+ with size of-type fixnum = (buffer-size buffer)
+ for i of-type fixnum = head then (the fixnum (1+ (the fixnum i)))
+ when (= size i) do (setf i 0)
+ until (= tail i)
+ collect (svref vector i))))
+
+(defmacro with-buffer-iterator ((buffer entry) &body body)
+ "Iterates over all currently held objects of BUFFER, binds ENTRY to it and
+evaluates BODY."
+ (let ((buffer-s (gensym))
+ (vector-s (gensym))
+ (head-s (gensym))
+ (tail-s (gensym))
+ (size-s (gensym))
+ (i-s (gensym)))
+ `(let ((,buffer-s ,buffer))
+ (mp:with-lock ((buffer-lock ,buffer-s))
+ (loop
+ with ,vector-s of-type (symple-vector *) =
+ (buffer-buf ,buffer-s)
+ with ,head-s of-type fixnum = (buffer-head ,buffer-s)
+ with ,tail-s of-type fixnum = (buffer-tail ,buffer-s)
+ with ,size-s of-type fixnum = (buffer-size ,buffer-s)
+ for ,i-s of-type fixnum =
+ ,head-s then (the fixnum (1+ (the fixnum ,i-s)))
+ when (= ,size-s ,i-s) do (setf ,i-s 0)
+ until (= ,tail-s ,i-s)
+ do
+ (let ((,entry (svref ,vector-s ,i-s)))
+ ,@body))))))
+
+(defun buffer-resize (buffer newsize)
+ "Resizes BUFFER to be able to hold SIZE number of items.
+The old history is preserved but may be partial if the size is shrunk."
+ (declare (optimize (speed 3) (safety 0) (debug 0))
+ (type fixnum newsize))
+ (check-type buffer buffer)
+ (check-type newsize fixnum)
+ (incf newsize)
+ (mp:with-lock ((buffer-lock buffer))
+ (with-accessors ((bbuf buffer-buf)
+ (bhead buffer-head)
+ (btail buffer-tail)
+ (bsize buffer-size)) buffer
+ (let ((oldbuf bbuf)
+ (oldhead (the fixnum bhead))
+ (oldtail (the fixnum btail))
+ (oldsize (the fixnum bsize)))
+ (declare (type (simple-vector *) oldbuf)
+ (type fixnum oldhead oldtail oldsize))
+ (setf bbuf (make-array newsize
+ :initial-element nil
+ :adjustable nil
+ :fill-pointer nil)
+ bhead 0
+ btail 0
+ bsize newsize)
+ (loop
+ for i of-type fixnum = oldhead then
+ (the fixnum (1+ (the fixnum i)))
+ when (= oldsize i) do (setf i 0)
+ until (= oldtail i)
+ do
+ (buffer-append buffer (svref oldbuf i))))))
+ (values))
-;;; Simple memory log implementation using the above FIFO,
+;;; Simple memory log implementation using the above buffer,
;;; or using syslog(3)
(defvar *log-syslog* nil)
(when *log-syslog*
(syslog:syslog syslog:+log-info+ l))
(when *log-buffer*
- (fifo-append *log-buffer*
- (format nil "~A ~A" (server-time-posix) l))))
+ (buffer-append *log-buffer*
+ (format nil "~A ~A" (server-time-posix) l))))
(values))
(declaim (inline log-line-nostamp))
(when *log-syslog*
(syslog:syslog syslog:+log-info+ l))
(when *log-buffer*
- (fifo-append *log-buffer* l)))
+ (buffer-append *log-buffer* l)))
(values))
(defun log-clear ()
"Clears the in-memory server log."
(when *log-buffer*
- (fifo-clear *log-buffer*))
+ (buffer-clear *log-buffer*))
(values))
(defun log-tail ()
"Writes to *STANDARD-OUTPUT* the contents of the server log."
(when *log-buffer*
(loop
- for line in (fifo-head *log-buffer*)
+ with lines = (buffer-history *log-buffer*)
+ for line in lines
do
(write-string (format nil "~A~%" line))))
(values))
+(defun log-resize (backlog)
+ "Resizes the log history buffer.
+The old backlog is preserved but may be partial if the buffer is shrunk."
+ (when *log-buffer*
+ (buffer-resize *log-buffer* backlog))
+ (values))
+
(declaim (inline log-connection))
(defun log-connection (connect session address port)
(log-line "~X ~A: [~A:~A]"
(setf (stream-external-format *standard-output*) '(:LATIN-1 :LF)))
(ext:catch-signal ext:+sigpipe+ :ignore)
(setf *server-socket* (bind-socket))
- (let ((log-fifo-lines (config-log-fifo-lines *config*)))
- (unless (zerop log-fifo-lines)
- (setf *log-buffer* (make-fifo :size log-fifo-lines))))
+ (let ((log-history-lines (config-log-history-lines *config*)))
+ (unless (zerop log-history-lines)
+ (setf *log-buffer* (make-buffer log-history-lines))))
(when (config-log-syslog *config*)
(syslog:openlog (config-log-syslog-ident *config*)
(logior syslog:+log-ndelay+ syslog:+log-pid+)
To obtain literal bytes, use the LATIN-1 EXTERNAL-FORMAT."
(declare (type fixnum max)
(optimize (speed 3) (safety 0) (debug 0)))
- (macrolet ((add-char (c orelse)
+ (macrolet ((add-char (c)
`(if (<= nchars max)
(progn
(vector-push-extend ,c line 1024)
(the fixnum (incf (the fixnum nchars))))
- ,(if (eq :finish orelse)
- '(loop-finish)
- 'nil))))
+ (loop-finish))))
(loop
with line = (make-array max
:element-type 'character
when (= o 10) do
(invoke-restart 'use-value (code-char o))
else do
- (add-char (code-char o) :finish))
+ (add-char (code-char o)))
(invoke-restart 'continue)))
(simple-error
#'(lambda (e)
:errno 0))))
(read-char stream))
until (= (char-code c) 10) do ; Inlines better than CHAR=
- (add-char c :finish)
+ (add-char c)
finally (if (= 0 (length line))
(return line)
(progn
Repositories / mmondor.git / commitdiff