A metaclass which allocates instance slots in contiguous vectors

point.lisp

(defclass point ()
  ((x :initarg :x
      :reader x
      :type single-float
      :pool-name *point-xs*)
   (y :initarg :y
      :reader y
      :type single-float
      :pool-name *point-ys*))
  (:metaclass pooled-class))

(defmethod print-object ((point point) stream)
  (print-unreadable-object (point stream :type t)
    (format stream "(~$, ~$)"
            (x point) (y point))))

#|
  (make-instance 'point :x 2.0 :y 3.0)
  *point-xs*
  (aref (storage-pool-storage *point-xs*) 0)
|#

pooled-class.lisp

(defstruct storage-pool
  (next-position 0 :type fixnum)
  (storage (error "need storage vector")))
(defmethod print-object ((storage-pool storage-pool) stream)
  (print-unreadable-object (storage-pool stream :type t :identity t)
    (format stream "~d/~d slot~:p, element-type ~s"
            (storage-pool-next-position storage-pool)
            (length (storage-pool-storage storage-pool))
            (array-element-type (storage-pool-storage storage-pool)))))

(defun allocate-from-pool (storage-pool)
  (let* ((position (storage-pool-next-position storage-pool))
         (storage  (storage-pool-storage storage-pool))
         (storage-length (length storage)))
    (when (>= position storage-length)
      (let ((new-storage
              (make-array (* 2 storage-length)
                          :element-type (array-element-type storage))))
        (replace new-storage storage)
        (setf storage new-storage
              (storage-pool-storage storage-pool) storage)))
    (incf (storage-pool-next-position storage-pool))
    position))

(defclass pooled-direct-slot-definition (closer-mop:standard-direct-slot-definition)
  ((element-type :initarg :element-type :reader pooled-slot-element-type)
   (storage-pool :initarg :storage-pool :reader pooled-slot-storage-pool)))

(defmethod initialize-instance :around ((s pooled-direct-slot-definition)
                                        &rest r
                                        &key (type t)
                                             pool-name)
  (let ((storage-pool nil))
    (unless (null pool-name)
      (setf storage-pool
            (make-storage-pool :storage (make-array 32 :element-type type)))
      (proclaim `(special ,pool-name))
      (set pool-name storage-pool))
    (apply #'call-next-method s
           :element-type type
           :type 'fixnum
           :storage-pool storage-pool
           (alexandria:remove-from-plist r :type))))

(defclass pooled-effective-slot-definition (closer-mop:standard-effective-slot-definition)
  ((storage-pool :initarg :storage-pool :accessor pooled-slot-storage-pool)))

(defclass pooled-class (standard-class)
  ((pooled-slots :accessor pooled-slots)))

(defmethod closer-mop:validate-superclass ((p pooled-class) (s standard-class)) t)

(defmethod closer-mop:direct-slot-definition-class ((p pooled-class) &key)
  (find-class 'pooled-direct-slot-definition))

(defvar *pooled?* t)
(defmethod closer-mop:effective-slot-definition-class ((p pooled-class) &key)
  (if *pooled?*
      (find-class 'pooled-effective-slot-definition)
      (call-next-method)))

(defmethod closer-mop:compute-effective-slot-definition
    ((p pooled-class) name direct-slot-definitions)
  (let* ((*pooled?*
           (loop for s in direct-slot-definitions
                   thereis (typep s 'pooled-direct-slot-definition)))
         (effective-slot (call-next-method)))
    (when *pooled?*
      (let ((pool (some #'pooled-slot-storage-pool direct-slot-definitions)))
        (when (null pool)
          (error "The effective slot definition ~s has no storage pool." effective-slot))
        (setf (pooled-slot-storage-pool effective-slot) pool)))
    effective-slot))

(defvar *grab-position?* nil)
(defmethod closer-mop:slot-value-using-class
    ((class pooled-class) object (slot pooled-effective-slot-definition))
  (let ((position (call-next-method)))
    (if *grab-position?*
        position
        (aref (storage-pool-storage (pooled-slot-storage-pool slot)) position))))

(defmethod (setf closer-mop:slot-value-using-class)
    (new-value (class pooled-class) object (slot pooled-effective-slot-definition))
  (if *grab-position?*
      (call-next-method)
      (let* ((position (let ((*grab-position?* t))
                         (closer-mop:slot-value-using-class class object slot)))
             (storage (storage-pool-storage (pooled-slot-storage-pool slot))))
        (setf (aref storage position)
              new-value))))

(defmethod closer-mop:finalize-inheritance :after ((class pooled-class))
  (setf (pooled-slots class)
        (loop for slot in (closer-mop:class-slots class)
              when (typep slot 'pooled-effective-slot-definition)
                collect slot)))

(defmethod allocate-instance :around ((class pooled-class) &key)
  (let ((instance (call-next-method)))
    (dolist (slot (pooled-slots class))
      (let ((*grab-position?* t))
        (setf (closer-mop:slot-value-using-class class instance slot)
              (allocate-from-pool (pooled-slot-storage-pool slot)))))
    instance))