Try to reduce consing a reasonable amount.

Author: Shinmera

controller.lisp

@@ -58,9 +58,11 @@
   (with-simple-restart (skip "Skip processing the message batch.")
     (loop for i from 0
           for thing across queue
-          do (with-simple-restart (continue "Continue processing messages, skipping ~a" thing)
-               (pass pipeline thing))
-             (setf (aref queue i) 0)))
+          do (unwind-protect
+                  (with-simple-restart (continue "Continue processing messages, skipping ~a" thing)
+                    (pass pipeline thing))
+               (maybe-release-message thing)
+               (setf (aref queue i) 0))))
   (setf (fill-pointer queue) 0))
 
 (defmethod controller-loop ((controller controller))
@@ -89,5 +91,6 @@
              (vector-push-extend message (queue controller)))
            (bt:condition-notify (queue-condition controller)))
           (T
-           (pass (pipeline controller) message))))
+           (pass (pipeline controller) message)
+           (maybe-release-message message))))
   NIL)

message.lisp

@@ -2,6 +2,7 @@
 
 (defvar *levels* NIL)
 (defvar *default-message-class* 'message)
+(defvar *pool* NIL)
 
 (declaim (inline log-object))
 (defun log-object (object)
@@ -27,31 +28,52 @@
   (unless (every #'keywordp categories) 
     (cl:error "Categories must be keywords.")))
 
+(defmethod print-object ((message message) stream)
+  (print-unreadable-object (message stream :type T)
+    (format-message stream message)))
+
+(defmethod format-message ((null null) thing)
+  (with-output-to-string (stream)
+    (format-message stream thing)))
+
+(defmethod format-message ((vector string) thing)
+  (with-output-to-string (stream vector)
+    (format-message stream thing)))
+
 (defmethod format-message ((stream stream) (message message))
-  (format stream "~a [~5,a] ~{<~a>~}: ~a"
-          (format-time :timestamp (timestamp message))
+  (format-time :timestamp (timestamp message) :stream stream)
+  (format stream " [~5,a] ~{<~a>~}: "
           (level message)
-          (categories message)
-          (format-message NIL (content message))))
+          (categories message))
+  (format-message stream (content message)))
 
-(defmethod format-message ((null null) message)
-  (princ-to-string message))
+(defmethod format-message ((stream stream) thing)
+  (princ thing stream))
 
-(defmethod format-message ((null null) (func function))
-  (princ-to-string (funcall func)))
+(defmethod format-message (target (func function))
+  (format-message target (funcall func)))
 
-(defmethod format-message ((null null) (message message))
-  (with-output-to-string (stream)
-    (format-message stream message)))
+(setf *pool* (make-pool (lambda () (allocate-instance (find-class 'message)))))
 
-(defmethod print-object ((message message) stream)
-  (print-unreadable-object (message stream :type T)
-    (format-message stream message)))
+(defun maybe-release-message (message)
+  (when (and *pool* (eq (type-of message) 'message))
+    (release-instance *pool* message)))
+
+(defun maybe-draw-message (level categories content class &rest initargs)
+  (if (and *pool* (eq class 'message))
+      (let ((instance (draw-instance *pool*)))
+        (setf (timestamp instance) (get-universal-time))
+        (setf (thread instance) (bt:current-thread))
+        (setf (level instance) level)
+        (setf (categories instance) categories)
+        (setf (content instance) content)
+        instance)
+      (apply #'make-instance class :level level :categories categories :content content initargs)))
 
 (defun log-message (level categories content &optional (class *default-message-class*) &rest initargs)
   (unless (listp categories)
     (setf categories (list categories)))
-  (log-object (apply #'make-instance class :level level :categories categories :content content initargs)))
+  (log-object (apply #'maybe-draw-message level categories content class initargs)))
 
 (defmethod log (level categories (datum string) &rest args)
   (log-message level categories (apply #'format NIL datum args)))

pipes.lisp

@@ -54,42 +54,49 @@
 
 (defmethod format-message ((faucet repl-faucet) (message message))
   (if (ansi-colors faucet)
-      (flet ((f (color format &rest args)
-               (when color (format (output faucet) "~c[38;5;~am" (code-char #x1b) color))
-               (format (output faucet) "~?" format args)
-               (when color (format (output faucet) "~c[0m" (code-char #x1b))))
-             (fb (fg bg format &rest args)
-               (format (output faucet) "~c[38;5;~am~c[48;5;~am" (code-char #x1b) fg (code-char #x1b) bg)
-               (format (output faucet) "~?" format args)
-               (format (output faucet) "~c[0m" (code-char #x1b))))
-        (f 7 "~a " (format-time :timestamp (timestamp message)))
-        (f 8 "[")
-        (f (case (level message)
-             (:trace 8)
-             (:debug 7)
-             (:info NIL)
-             (:warn 9)
-             (:error 1)
-             (:severe 11)
-             (:fatal 11)) "~5,a" (level message))
-        (f 8 "] ")
-        (dolist (category (categories message))
-          (f 8 "<")
-          (f NIL "~a" category)
-          (f 8 ">"))
-        (f 8 ": ")
-        (flet ((msg (fg &optional bg)
-                 (if bg
-                     (fb fg bg "~a" (format-message NIL (content message)))
-                     (f fg "~a" (format-message NIL (content message))))))
-          (case (level message)
-            (:trace (msg 8))
-            (:debug (msg 7))
-            (:info (msg NIL))
-            (:warn (msg 9))
-            (:error (msg 1))
-            (:severe (msg 11))
-            (:fatal (msg 0 11)))))
+      (let ((stream (output faucet)))
+        (macrolet ((f (color format &rest args)
+                     `(progn
+                        ,@(when color `((format stream "~c[38;5;~am" (code-char #x1b) ,color)))
+                        ,(if (stringp format)
+                             `(format stream ,format ,@args)
+                             `(progn ,format ,@args))
+                        ,@(when color `((format stream "~c[0m" (code-char #x1b))))))
+                   (fb (fg bg format &rest args)
+                     `(progn
+                        (format stream "~c[38;5;~am~c[48;5;~am" (code-char #x1b) ,fg (code-char #x1b) ,bg)
+                        ,(if (stringp format)
+                             `(format stream ,format ,@args)
+                             `(progn ,format ,@args))
+                        (format stream "~c[0m" (code-char #x1b)))))
+          (f 7 (format-time :timestamp (timestamp message) :stream stream))
+          (f 8 " [")
+          (f (case (level message)
+               (:trace 8)
+               (:debug 7)
+               (:info NIL)
+               (:warn 9)
+               (:error 1)
+               (:severe 11)
+               (:fatal 11)) "~5,a" (level message))
+          (f 8 "] ")
+          (dolist (category (categories message))
+            (f 8 "<")
+            (f NIL "~a" category)
+            (f 8 ">"))
+          (f 8 ": ")
+          (flet ((msg (fg &optional bg)
+                   (if bg
+                       (fb fg bg (format-message stream (content message)))
+                       (f fg (format-message stream (content message))))))
+            (case (level message)
+              (:trace (msg 8))
+              (:debug (msg 7))
+              (:info (msg NIL))
+              (:warn (msg 9))
+              (:error (msg 1))
+              (:severe (msg 11))
+              (:fatal (msg 0 11))))))
       (call-next-method)))
 
 (defmethod stop ((faucet repl-faucet)))

pool.lisp

@@ -0,0 +1,89 @@
+(in-package #:org.shirakumo.verbose)
+
+(defstruct (pool
+            (:predicate NIL)
+            (:copier NIL)
+            (:constructor %make-pool (instances constructor)))
+  (instances NIL :type simple-vector)
+  (index 0 :type (unsigned-byte 32))
+  (constructor NIL :type function)
+  (lock (bt:make-lock "verbose pool")))
+
+(defmethod print-object ((pool pool) stream)
+  (print-unreadable-object (pool stream :type T :identity T)
+    (format stream "~d/~d" (pool-index pool) (length (pool-instances pool)))))
+
+(defun make-pool (constructor &optional (initial-size 128))
+  (let ((instances (make-array initial-size)))
+    (map-into instances constructor)
+    (%make-pool instances constructor)))
+
+(defun clear-pool (pool)
+  (bt:with-lock-held ((pool-lock pool))
+    ;; The order is no longer guaranteed to be consistent
+    ;; and due to out of order release/draw, some objects may
+    ;; not be present at all, or present multiple times, we have
+    ;; to refill the pool entirely.
+    (setf (pool-index pool) 0)
+    (map-into (pool-instances pool) (pool-constructor pool))
+    pool))
+
+(defun resize-pool (pool new-size &key (lock T))
+  (flet ((resize ()
+           (let* ((old (pool-instances pool))
+                  (new (adjust-array old new-size)))
+             (loop for i from (length old) below new-size
+                   do (setf (aref new i) (funcall (pool-constructor pool))))
+             (setf (pool-instances pool) new))))
+    (if lock
+        (bt:with-lock-held ((pool-lock pool))
+          (resize))
+        (resize))))
+
+(defun draw-instance (pool)
+  #+atomics-cas-struct-slot
+  (loop
+    (let ((instances (pool-instances pool))
+          (index (pool-index pool)))
+      (cond ((< index (length instances))
+             (when (atomics:cas (pool-index pool) index (1+ index))
+               (return (aref instances index))))
+            ((= index (length instances))
+             ;; We filled, so we are responsible for resizing it.
+             (resize-pool pool (* 2 index) :lock T))
+            (T
+             ;; Re-use the lock as a barrier, then retry
+             (bt:with-lock-held ((pool-lock pool)))))))
+  #-atomics-cas-struct-slot
+  (bt:with-lock-held ((pool-lock pool))
+    (let ((instances (pool-instances pool))
+          (index (pool-index pool)))
+      ;; We filled, so we are responsible for resizing it.
+      (loop while (<= (length instances) index)
+            do (resize-pool pool (* 2 index) :lock NIL)
+               (setf instances (pool-instances pool)))
+      (setf (pool-index pool) (1+ index))
+      (aref instances index))))
+
+(defun release-instance (pool instance)
+  #+atomics-cas-struct-slot
+  (loop
+    (let ((index (pool-index pool))
+          (instances (pool-instances pool)))
+      (cond ((= 0 index)
+             ;; What the fuck... (double-release?)
+             (return))
+            ;; FIXME: I don't think this is quite consistent...
+            ((= index (length instances))
+             ;; What the fuck... (how? wait for a resize maybe?)
+             ())
+            ((atomics:cas (pool-index pool) index (1- index))
+             (return (setf (aref instances index) instance))))))
+  #-atomics-cas-struct-slot
+  (bt:with-lock-held ((pool-lock pool))
+    (let ((index (pool-index pool)))
+      (cond ((= 0 index)
+             (cl:warn "What the fuck?"))
+            (T
+             (setf (aref (pool-instances pool) index) instance)
+             (setf (pool-index pool) (1- index)))))))

verbose.asd

@@ -1,6 +1,6 @@
 (asdf:defsystem verbose
   :name "Verbose"
-  :version "2.1.0"
+  :version "2.2.0"
   :author "Yukari Hafner <shinmera@tymoon.eu>"
   :license "zlib"
   :description "A logging framework using the piping library."
@@ -11,6 +11,7 @@
   :components ((:file "package")
                (:file "toolkit")
                (:file "controller")
+               (:file "pool")
                (:file "message")
                (:file "pipes")
                (:file "convenience")
@@ -21,5 +22,6 @@
                (:file "documentation"))
   :depends-on (:piping
                :bordeaux-threads
+               :atomics
                :dissect
                :documentation-utils))