spin off into new src files

cl-ctrie.asd

@@ -74,8 +74,11 @@
                 (:file "common-pointer")
                 (:file "common-array")
                 (:file "ctrie-package")
+                (:file "ctrie-special")
+                (:file "ctrie-conditions")
                 (:file "ctrie-cas")
                 (:file "ctrie-util")
+                (:file "ctrie-pool")
                 (:file "ctrie")
                 (:file "ctrie-lambda")
                 #+cldoc (:file "ctrie-doc")

ctrie-conditions.lisp

@@ -0,0 +1,96 @@
+;;;;; -*- mode: common-lisp;   common-lisp-style: modern;    coding: utf-8; -*-
+;;;;;
+
+(in-package :cl-ctrie)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Conditions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(define-condition ctrie-error (error) 
+  ((ctrie :initform *ctrie* :initarg :ctrie :reader ctrie-of))
+  (:documentation "Abstract superclass of CTRIE related conditions."))
+
+
+(define-condition ctrie-structural-error (ctrie-error)
+  ((node :initarg :node :reader node-of))
+  (:documentation "Condition designating that the CTRIE data structure
+   has been determined to be invalid."))
+
+
+(define-condition ctrie-generational-mismatch (ctrie-structural-error)
+  ((expected :initarg :expected :reader expected)
+    (found   :initarg :found    :reader found))
+  (:documentation "Condition indicating an operation encountered an
+   outdated or inconsistent node during its attempted traversal"))
+
+
+(define-condition ctrie-operational-error (ctrie-error)
+  ((op :initarg :op :reader op-of))
+  (:documentation "Condition for when an operational failure or
+  inconsistency has occurred."))
+
+
+(define-condition ctrie-modification-failed  (ctrie-operational-error)
+  ((place   :initarg :place  :reader place-of)
+    (reason :initarg :reason :reader reason-of))
+  (:report
+    (lambda (condition stream)
+      (with-slots (ctrie op place reason) condition
+        (format stream "CTRIE MODIFICATION FAILED~%")
+        (format stream "-------------------------~%~%")
+        (format stream "FAILURE: Operation ~S failed to modify ~S in CTRIE at #x~X~%~%"
+          op place (if ctrie (sb-kernel:get-lisp-obj-address ctrie) 0))
+        (format stream "CAUSE:   ~A~%~%" reason)
+        (format stream "ABOUT:   ~A~%~%"
+          (documentation (type-of condition) 'type)))))
+  (:documentation
+        "This condition indicates an unhandled failure of an attempt to
+         perform stateful modification to CTRIE.  The most common case in
+         which this might occur is when such an attempt is mode on a CTRIE
+         designated as READONLY-P.  In any case, this condition represents an
+         exception from which processing cannot continue and requires
+         interactive user intervention in order to recover."))
+
+
+(define-condition ctrie-invalid-dynamic-context (ctrie-operational-error)
+  ((ctrie-context :initform *ctrie* :initarg :ctrie-context :reader ctrie-context)
+    (gen-context  :initarg :gen-context   :reader gen-context))
+  (:documentation "Condition indicating an operation was attempted
+   outside the dynamic extent of a valid enclosing WITH-CTRIE form"))
+
+
+(define-condition ctrie-operation-timeout-exceeded (ctrie-operational-error)
+  ((seconds :initform *timeout* :initarg :seconds :reader seconds-of))
+  (:documentation "Condition indicating an operation has failed the
+   maximum number of times specified by the s-variable *retries*"))
+
+
+(define-condition ctrie-operation-retries-exceeded (ctrie-operational-error)
+  ((retries :initform *retries* :initarg :retries :reader retries-of))
+  (:documentation "Condition indicating an operation has failed the
+   maximum number of times specified by the special-variable
+   *retries*"))
+
+
+(define-condition ctrie-not-implemented (ctrie-error) ()
+  (:documentation "Condition designating functionality for which the
+   implementation has not been written, but has not been deliberately
+   excluded."))
+
+
+(define-condition ctrie-not-supported (ctrie-error) ()
+  (:documentation "Condition designating functionality that is
+  deliberately not supported."))
+
+
+(defmacro ctrie-error (condition &rest args)
+  "Signal a CTRIE related condition."
+  `(error ',condition :ctrie *ctrie* ,@args))
+
+
+(defun ctrie-modification-failed (reason &key op place)
+  "Signal a modification failure with the appropriate attendant metadata."
+  (ctrie-error ctrie-modification-failed :op op :place place :reason reason))

ctrie-pool.lisp

@@ -0,0 +1,153 @@
+;;;;; -*- mode: common-lisp;   common-lisp-style: modern;    coding: utf-8; -*-
+;;;;;
+
+(in-package :cl-ctrie)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Threaded Pre-Allocation and Memory Pooling
+;;
+;; This Memory Alocation Pooling System is completely 'stateless' and requires
+;; no special interaction or management by the developer/end-user.  No processing
+;; or consumption of resources will occur until the first user-requested allocation,
+;; at which time the worker thread will initialize and fill all defined pools and
+;; their bucket vectors.  After this point, all further preallocation will occur
+;; lazily on-demand.
+;;
+;; One fiddly-bit that one might care to make use-of is #'CTRIE-POOL-STATUS,
+;; which will return an alist describing the current fill-level for all currently
+;; defined pools and their constituent bucket vectors.
+;;
+;; I especially like the way this came together.  Still, there is plenty of
+;; room for improvement, of course -- most notably some more effort toward 
+;; optimization, condition handling, and api refinements would be worthwhile.  
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(defun ctrie-enable-pooling ()
+  (setf *pool-enabled* t))
+
+(defun ctrie-disable-pooling ()
+  (setf *pool-enabled* nil))
+
+(defun ctrie-pooling-enabled-p ()
+  (not (null *pool-enabled*)))
+
+(defun pool-buckets (class-name)
+  (or (get class-name :pool-buckets) 0))
+
+(defun pool-serial (class-name)
+  (or (get class-name :pool-serial)
+    (setf (get class-name :pool-serial) 0)))
+
+(defun (setf pool-buckets) (value class-name)
+  (setf (get class-name :pool-buckets) (or value 0)))
+
+(defun pool-alloc (class-name)
+  (get class-name :pool-alloc))
+
+(defun (setf pool-alloc) (fn class-name)
+  (setf (get class-name :pool-alloc) fn))
+
+(defun find-pool (class-name)
+  (or (getf *pool-list* class-name)
+    (setf (getf *pool-list* class-name)
+      (let1 buckets (pool-buckets class-name)
+        (make-array (1+ buckets) :initial-contents
+          (loop repeat (1+ buckets) collect (cons nil nil)))))))
+
+(defmacro define-pool (name (&optional (buckets 0)) &body body)
+  (with-unique-names (num-buckets)
+    `(let ((,num-buckets ,buckets))
+       (prog1 ',name
+         (setf (get ',name :pool-serial) 0)
+         (setf (pool-alloc ',name) (lambda (&optional bucket)
+                                     (declare (ignorable bucket))
+                                     ;; (sb-ext:atomic-incf
+                                     ;;   (getf (symbol-plist ',name) :pool-serial))
+                                     ,@body))
+         (setf (pool-buckets ',name) ,num-buckets)
+         (find-pool ',name)))))
+
+(defun ctrie-pool-status ()
+  (loop for class-name in *pool-list* by #'cddr
+    when class-name
+    collect (cons class-name
+              (coerce (loop for p across (find-pool class-name)
+                        collect (length (cdr p)))
+                'vector))))
+
+(defun ps ()
+  (ctrie-pool-status))
+
+(defun ctrie-ps ()
+  (ctrie-pool-status))
+
+(defun/inline pool-list ()
+  *pool-list*)
+
+(defun/inline pool-queue ()
+  (or *pool-queue* 
+    (setf *pool-queue*
+      (sb-concurrency:make-mailbox :name "pool-queue"))))
+
+(defun destroy-pool-list ()
+  (setf *pool-list* nil))
+
+(defun destroy-pool-queue ()
+  (setf *pool-queue* nil))
+
+(defun fill-pool (class-name &optional (bucket 0))
+  (let1 pool (svref (find-pool class-name) bucket)
+    (unless (cdr pool)
+      (when *debug* (printv "filling pool" class-name bucket ""))
+      (sb-thread::with-cas-lock ((car pool))
+        (setf (cdr pool)
+          (loop repeat *pool-high-water*
+            collect (apply (pool-alloc class-name)
+                      (ensure-list (unless (zerop bucket) bucket)))))))))
+
+(defun fill-all-pools ()
+  (loop for (class-name pool) on (pool-list) by #'cddr
+    when class-name
+    do (printv class-name)
+    do (dolist (bucket (iota (1+ (pool-buckets class-name)) :start 0))
+         (sb-concurrency:send-message (pool-queue) (cons class-name bucket)))))
+
+(defun pool-work-loop ()
+  (loop with terminate until terminate
+    for request = (ensure-list (sb-concurrency:receive-message (pool-queue)))
+    if (and (cdr request) (minusp (cdr request))) do (setf terminate t)
+    else do (fill-pool (car request) (or (cdr request) 0))))
+
+(defun/inline pool-worker ()
+  (if (and *pool-worker* (sb-thread:thread-alive-p *pool-worker*))
+    *pool-worker*
+    (setf *pool-worker*
+      (sb-thread:make-thread
+        (lambda ()
+          (fill-all-pools)
+          (pool-work-loop)
+          (destroy-pool-list)
+          (destroy-pool-queue)
+          (setf *pool-worker* nil)
+          (sb-thread:terminate-thread sb-thread:*current-thread*))
+        :name "pool-worker"))))
+
+(defun/inline allocate (class-name &optional (bucket 0))
+  (if (minusp bucket)
+    (sb-concurrency:send-message (pool-queue) (cons class-name bucket)) 
+    (flet ((bail ()
+             (pool-worker)
+             (sb-concurrency:send-message (pool-queue) (cons class-name bucket)) 
+             (return-from allocate
+               (apply (pool-alloc class-name) (ensure-list (unless (zerop bucket) bucket))))))
+      (let1 pool (svref (find-pool class-name) bucket)
+        (when (null (cdr pool)) (bail))
+        (sb-thread::with-cas-lock ((car pool))
+          (unless (cdr pool) (bail))
+          (prog1 (pop (cdr pool))
+            (unless (cdr pool)
+              (pool-worker)
+              (sb-concurrency:send-message (pool-queue) (cons class-name bucket))))))))) 
+

ctrie-special.lisp

@@ -0,0 +1,66 @@
+;;;;; -*- mode: common-lisp;   common-lisp-style: modern;    coding: utf-8; -*-
+;;;;;
+
+(in-package :cl-ctrie)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Special Variables
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar       *ctrie*         nil
+  "Within the dynamic extent of a CTRIE operation this variable will
+  be bound to the root-container CTRIE operand.  It is an error if an
+  operation is defined that attempts access to a CTRIE without this
+  binding, which is properly established by wrapping the operation in
+  an appropriate WITH-CTRIE form.")
+
+(defvar       *hash-code*     nil
+  "Special variable used to store the hash-code that corresponds to the
+  current operation.  Used as a means of improving efficiency by eliminating
+  needless recomputation of the hash function, which is the most expensive
+  part of most user-level ctrie operations.  If this value is not set, then
+  the hash will simply be computed on demand and processing will continue
+  unaffected.  Use of this variable is simply an optional performace
+  optimization techniqie. For additional detail, refer to the documentation
+  for functions `FLAG` and `CTHASH`")
+
+(defparameter *retries*        16
+  "Establishes the number of restarts permitted to a CTRIE operation
+  established by a WITH-CTRIE form before a condition of type
+  CTRIE-OPERATION-RETRIES-EXCEEDED will be signaled, aborting the
+  operatation, and requiring operator intervention to resume
+  processing.")
+
+
+(defparameter *timeout*         2
+  "Establishes the duration (in seconds) allotted to a CTRIE operation
+  established by a WITH-CTRIE form before a condition of type
+  CTRIE-OPERATION-TIMEOUT-EXCEEDED will be signaled, aborting the
+  operatation, and requiring operator intervention to resume
+  processing.")
+
+
+(defparameter *context*       nil
+  "Diagnostic value, not used in production, used to maintain
+  additional information tracking the current dynamic state.")
+
+
+(defparameter *debug*         nil
+  "Debugging flag, not used in production, to enable generation of
+  additional diagnostic and reporting information.")
+
+(defparameter *timestamps-enabled* nil)
+
+(defparameter *pool-enabled*    t)
+
+(defparameter *pool-high-water* (expt 2 10))
+
+(defvar       *pool-list*        nil)
+
+(defvar       *pool-worker*      nil)
+
+(defvar       *pool-queue*       nil)
+
+(defparameter *default-mmap-dir* nil)
+