branch: externals/pam
commit bc654b6d687c67c5ad45218d6f45f95b8f1e0478
Author: Onnie Lynn Winebarger <owine...@gmail.com>
Commit: Onnie Lynn Winebarger <owine...@gmail.com>
Change data structures to primitive representation.
Bytecode for compiled allocate/free functions only have call instruction
for error signaling.
Bytecode for claim/release functions on have call for error signaling and
object finalizer.
---
tam.el | 443 +++++++++++++++++++++++++++++++++++++++++++++++------------------
1 file changed, 319 insertions(+), 124 deletions(-)
diff --git a/tam.el b/tam.el
index de6cac8187..9be2aa06ec 100644
--- a/tam.el
+++ b/tam.el
@@ -54,197 +54,392 @@
;;; Code:
-(eval-when-compile
- (require 'cl-lib))
-
-(cl-defstruct (tam--table (:constructor tam--table-create (size))
- (:copier tam--copy-table))
- "Table with explicitly managed allocation"
- (size nil :documentation "Size of the table")
- (used nil :documentation "Number of entries in use")
- (slots nil :documentation "Vector of slots")
- (first-free nil :documentation "First slot on the free list")
- (last-free nil :documentation "Last slot on the free list")
- (first-used nil :documentation "First slot on in-use list")
- (last-used nil :documentation "Last slot on in-use list"))
-
-(cl-defstruct (tam--slot (:constructor tam--slot-create
- (table index in-use next previous))
- (:copier tam--copy-slot))
- "Slot in TAM table"
- (table nil :documentation "table containing this slot")
- (index nil :documentation "index of slot in table")
- (in-use nil :documentation "flag indicating if contents are \"live\"")
- (next nil :documentation "next on list of used/free")
- (previous nil :documentation "previous on list of used/free")
- (contents nil :documentation "contents of slot")
- )
-
-(cl-defstruct (tam--pool (:constructor tam--pool-create
- (table
- objs
- allocate
- reset))
- (:copier tam--copy-pool))
- "Pool of manually managed pre-allocated objects"
- (table nil :documentation "TAM table for tracking live/free objects")
- (objs nil :documentation "Preallocated objects")
- (allocate nil :documentation "Thunk for allocating uninitialized objects")
- (reset nil :documentation "Function to reset object to uninitialized state"))
-
-(defun tam-create-table (N)
- "Make a tam table of size N."
- (let ((tbl (tam--table-create N))
- (v (make-vector N nil))
+(defun tam--slot-create (table index in-use next previous &optional contents)
+ "Make a tam--slot record.
+Fields:
+ TABLE - table holding this slot
+ INDEX - index of this slot in TABLE
+ IN-USE - boolean indicating whether slot is in use or free
+ NEXT - next slot in list (free/live) containing slot, or nil if last
+ PREVIOUS - previouse slot in list (free/live) containing slot, or
+ nil if first
+ CONTENTS - object managed by slot's allocation state"
+ (record 'tam--slot table index in-use next previous contents))
+
+(defsubst tam--slot-table (slot)
+ "Return table of SLOT."
+ (aref slot 1))
+(defsubst tam--slot-size-set (slot tbl)
+ "Set table field of SLOT to TBL."
+ (aset slot 1 tbl))
+(defsubst tam--slot-index (slot)
+ "Return index field of SLOT."
+ (aref slot 2))
+(defsubst tam--slot-index-set (slot index)
+ "Set index field of SLOT to INDEX."
+ (aset slot 2 index))
+
+(defsubst tam--slot-in-use (slot)
+ "Return in-use field of SLOT."
+ (aref slot 3))
+(defsubst tam--slot-in-use-set (slot in-use)
+ "Set in-use field of SLOT to IN-USE."
+ (aset slot 3 in-use))
+
+(defsubst tam--slot-next (slot)
+ "Return next field of SLOT."
+ (aref slot 4))
+(defsubst tam--slot-next-set (slot next)
+ "Set next field of SLOT to NEXT."
+ (aset slot 4 next))
+
+(defsubst tam--slot-previous (slot)
+ "Return previous field of SLOT."
+ (aref slot 5))
+(defsubst tam--slot-previous-set (slot previous)
+ "Set previous field of SLOT to PREVIOUS."
+ (aset slot 5 previous))
+
+(defsubst tam--slot-contents (slot)
+ "Return contents field of SLOT."
+ (aref slot 6))
+(defsubst tam--slot-contents-set (slot contents)
+ "Set contents field of SLOT to CONTENTS."
+ (aset slot 6 contents))
+
+(defun tam--table-create (&optional size
+ used
+ slots
+ first-free
+ last-free
+ first-used
+ last-used)
+ "Make a tam--table record of size N.
+Fields:
+ SIZE - number of slots in table
+ USED - number of slots in use
+ SLOTS - vector of SIZE slot objects
+ FIRST-FREE - first slot on free list, or nil if empty
+ LAST-FREE - last slot on free-list, or nil if empty
+ FIRST-USED - first slot on live list, or nil if empty
+ LAST-USED - last slot on live list, or nil if empty"
+ (record 'tam--table
+ size used slots
+ first-free last-free
+ first-used last-used))
+
+(defun tam--pool-create (&optional size
+ used
+ slots
+ first-free
+ last-free
+ first-used
+ last-used
+ allocate
+ reset)
+ "Make a tam--pool record of size N.
+A tam--pool is used to manage a set of N pre-allocated object
+of some type.
+Fields:
+ SIZE - number of slots in table
+ USED - number of slots in use
+ SLOTS - vector of SIZE slot objects
+ FIRST-FREE - first slot on free list, or nil if empty
+ LAST-FREE - last slot on free-list, or nil if empty
+ FIRST-USED - first slot on live list, or nil if empty
+ LAST-USED - last slot on live list, or nil if empty
+ ALLOCATE - thunk that allocates an uninitialized object
+ RESET - function of one argument that resets an object to
+ an uninitialized state"
+ (record 'tam--pool
+ size used slots
+ first-free last-free
+ first-used last-used
+ allocate reset))
+
+
+(defsubst tam--table-size (tbl)
+ "Return size of TBL."
+ (aref tbl 1))
+(defsubst tam--table-size-set (tbl size)
+ "Set size field of TBL to SIZE."
+ (aset tbl 1 size))
+(defsubst tam--table-used (tbl)
+ "Return used field of TBL."
+ (aref tbl 2))
+(defsubst tam--table-used-set (tbl used)
+ "Set used field of TBL to USED."
+ (aset tbl 2 used))
+
+(defsubst tam--table-slots (tbl)
+ "Return slots field of TBL."
+ (aref tbl 3))
+(defsubst tam--table-slots-set (tbl slots)
+ "Set slots field of TBL to SLOTS."
+ (aset tbl 3 slots))
+
+(defsubst tam--table-first-free (tbl)
+ "Return first-free field of TBL."
+ (aref tbl 4))
+(defsubst tam--table-first-free-set (tbl first-free)
+ "Set first-free field of TBL to FIRST-FREE."
+ (aset tbl 4 first-free))
+
+(defsubst tam--table-last-free (tbl)
+ "Return last-free field of TBL."
+ (aref tbl 5))
+(defsubst tam--table-last-free-set (tbl last-free)
+ "Set last-free field of TBL to LAST-FREE."
+ (aset tbl 5 last-free))
+
+(defsubst tam--table-first-used (tbl)
+ "Return first-used field of TBL."
+ (aref tbl 6))
+(defsubst tam--table-first-used-set (tbl first-used)
+ "Set first-used field of TBL to FIRST-USED."
+ (aset tbl 6 first-used))
+
+(defsubst tam--table-last-used (tbl)
+ "Return last-used field of TBL."
+ (aref tbl 7))
+(defsubst tam--table-last-used-set (tbl last-used)
+ "Set last-used field of TBL to LAST-USED."
+ (aset tbl 7 last-used))
+
+(defsubst tam--pool-table (pool)
+ "Return the tam--table record for POOL."
+ pool)
+
+(defsubst tam--pool-allocate (pool)
+ "Return the allocate field of POOL."
+ (aref pool 8))
+(defsubst tam--pool-allocate-set (pool allocate)
+ "Set the allocate field of POOL to ALLOCATE."
+ (aset pool 8 allocate))
+
+(defsubst tam--pool-reset (pool)
+ "Return the reset field of POOL."
+ (aref pool 9))
+(defsubst tam--pool-reset-set (pool reset)
+ "Set the reset field of POOL to RESET."
+ (aset pool 9 reset))
+
+
+(defun tam--table-initialize (tbl N &optional allocate)
+ "Initialize a tam--table or tam--pool record of size N."
+ (unless allocate
+ (setq allocate (lambda () nil)))
+ (tam--table-size-set tbl N)
+ (tam--table-used-set tbl 0)
+ (tam--table-first-used-set tbl nil)
+ (tam--table-last-used-set tbl nil)
+ (let ((v (make-vector N nil))
(N-1 (- N 1))
next
prev)
- (setf (tam--table-slots tbl) v)
- (setf (tam--table-used tbl) 0)
- (setf (tam--table-first-used tbl) nil)
- (setf (tam--table-last-used tbl) nil)
(dotimes (k N)
- (let ((s (tam--slot-create tbl k nil nil prev)))
+ (let ((s (tam--slot-create tbl k nil nil prev (funcall allocate))))
(aset v k s)
(setq prev s)))
(when (> N 1)
(setq next (aref v 1))
(dotimes (k N-1)
(setq next (aref v (1+ k)))
- (setf (tam--slot-next (aref v k)) next)))
- (setf (tam--table-first-free tbl) (aref v 0))
- (setf (tam--table-last-free tbl) (aref v N-1))
- tbl))
+ (tam--slot-next-set (aref v k) next)))
+ (tam--table-slots-set tbl v)
+ (tam--table-first-free-set tbl (aref v 0))
+ (tam--table-last-free-set tbl (aref v N-1)))
+ tbl)
+(defun tam-create-table (N)
+ "Create a tam table of size N"
+ (tam--table-initialize (tam--table-create) N))
+(defun tam-create-pool (N allocate &optional reset)
+ "Make a pool of N pre-allocated objects.
+Arguments:
+ N - number of pre-allocated objects
+ ALLOCATE - function of zero arguments returning an uninitialized object
+ RESET - function taking an object and setting it to an uninitialized state
+RESET must perform any required finalization."
+ (let ((pool
+ (tam--table-initialize (tam--pool-create) N allocate)))
+ (tam--pool-allocate-set pool allocate)
+ (tam--pool-reset-set pool reset)
+ pool))
-(defun tam-table-fullp (tbl)
+(defsubst tam-table-fullp (tbl)
"Test if TBL is full."
(<= (tam--table-size tbl) (tam--table-used tbl)))
-(defun tam-table-emptyp (tbl)
+(defsubst tam-table-emptyp (tbl)
"Test if TBL is empty."
(= (tam--table-used tbl) 0))
+
(defalias 'tam-table-size #'tam--table-size)
(defalias 'tam-table-used #'tam--table-used)
-(defun tam--table-get-slot (tbl idx)
+(defsubst tam-pool-fullp (pool)
+ "Test if POOL is full."
+ (tam-table-fullp pool))
+
+(defsubst tam-pool-emptyp (pool)
+ "Test if POOL is empty."
+ (tam-table-emptyp pool))
+
+(defalias 'tam-pool-size #'tam--table-size
+ "Return size of POOL.")
+(defalias 'tam-pool-used #'tam--table-used
+ "Return number of used objects in POOL.")
+
+(defsubst tam--table-get-slot (tbl idx)
"Get slot IDX of TBL."
(aref (tam--table-slots tbl) idx))
-(defun tam-table-get (tbl idx)
+(defsubst tam-table-get (tbl idx)
"Get contents of slot IDX of TBL."
(tam--slot-contents (aref (tam--table-slots tbl) idx)))
-
-(defun tam-allocate (tbl obj)
- "Allocate slot in TBL with contents OBJ.
-Return index or nil if table is full."
+(defsubst tam--allocate-slot (tbl)
+ "Return first free slot in TBL or nil if full.
+If slot is allocated, it is moved to live list."
(let ((s (tam--table-first-free tbl))
- next idx)
+ next)
(when (not (tam-table-fullp tbl))
- (setf (tam--slot-previous s) (tam--table-last-used tbl))
+ (tam--slot-previous-set s (tam--table-last-used tbl))
(if (tam-table-emptyp tbl)
- (setf (tam--table-first-used tbl) s)
- (setf (tam--slot-next (tam--table-last-used tbl)) s))
- (setf (tam--table-last-used tbl) s)
+ (tam--table-first-used-set tbl s)
+ (tam--slot-next-set (tam--table-last-used tbl) s))
+ (tam--table-last-used-set tbl s)
(setq next (tam--slot-next s))
- (setf (tam--table-first-free tbl) next)
- (setf (tam--slot-next s) nil)
- (setf (tam--slot-in-use s) t)
- (setf (tam--slot-contents s) obj)
- (cl-incf (tam--table-used tbl))
+ (tam--table-first-free-set tbl next)
+ (tam--slot-next-set s nil)
+ (tam--slot-in-use-set s t)
+ (tam--table-used-set tbl
+ (1+ (tam--table-used tbl)))
(when next
- (setf (tam--slot-previous next) nil))
+ (tam--slot-previous-set next nil))
(when (tam-table-fullp tbl)
- (setf (tam--table-last-free tbl) nil))
+ (tam--table-last-free-set tbl nil)))
+ s))
+
+(defsubst tam-allocate/inline (tbl obj)
+ "Allocate slot in TBL with contents OBJ.
+Return index or nil if table is full.
+Inlining version"
+ (let ((s (tam--allocate-slot tbl))
+ idx)
+ (when s
+ (tam--slot-contents-set s obj)
(setq idx (tam--slot-index s)))
idx))
-(defun tam-free (tbl idx)
- "Free slot at IDX in TBL.
-Return contents of slot IDX. Signals an error if IDX is not in use."
- (let ((s (tam--table-get-slot tbl idx))
- (last-free (tam--table-last-free tbl))
- prev next obj)
+(defun tam-allocate (tbl obj)
+ "Allocate slot in TBL with contents OBJ.
+Return index or nil if table is full."
+ (tam-allocate/inline tbl obj))
+
+(defsubst tam--free-slot (tbl s)
+ "Free slot S in TBL.
+Signals an error if S is not in use.
+Moves S from live list to end of free list otherwise."
+ (let ((last-free (tam--table-last-free tbl))
+ (idx (tam--slot-index s))
+ prev next)
(unless (tam--slot-in-use s)
(signal 'tam-already-free
(format "Attempt to free unused table entry %s"
idx)))
(setq prev (tam--slot-previous s))
(setq next (tam--slot-next s))
- (setq obj (tam--slot-contents s))
- (setf (tam--slot-next s) nil)
+ (tam--slot-next-set s nil)
(if prev
- (setf (tam--slot-next prev) next)
+ (tam--slot-next-set prev next)
;; else was first used
- (setf (tam--table-first-used tbl) next))
+ (tam--table-first-used-set tbl next))
(if next
- (setf (tam--slot-previous next) prev)
+ (tam--slot-previous-set next prev)
;; else was last used
- (setf (tam--table-last-used tbl) prev))
+ (tam--table-last-used-set tbl prev))
(if last-free
(progn
- (setf (tam--slot-next last-free) s)
- (setf (tam--slot-previous s) last-free))
+ (tam--slot-next-set last-free s)
+ (tam--slot-previous-set s last-free))
;; free list is empty
- (setf (tam--table-first-free tbl) s)
- (setf (tam--slot-previous s) nil))
- (setf (tam--table-last-free tbl) s)
- (setf (tam--slot-in-use s) nil)
- (setf (tam--slot-contents s) nil)
- (cl-decf (tam--table-used tbl))
+ (tam--table-first-free-set tbl s)
+ (tam--slot-previous-set s nil))
+ (tam--table-last-free-set tbl s)
+ (tam--slot-in-use-set s nil)
+ (tam--table-used-set tbl
+ (1- (tam--table-used tbl))))
+ s)
+
+(defsubst tam-free/inline (tbl idx)
+ "Free slot at IDX in TBL.
+Return contents of slot IDX. Signals an error if IDX is not in use.
+Inlined version"
+ (let ((s (tam--free-slot tbl (tam--table-get-slot tbl idx)))
+ obj)
+ (setq obj (tam--slot-contents s))
+ (tam--slot-contents-set s nil)
obj))
+(defun tam-free (tbl idx)
+ "Free slot at IDX in TBL.
+Return contents of slot IDX. Signals an error if IDX is not in use."
+ (tam-free/inline tbl idx))
+
+(defun tam--slot-list (s)
+ "Return list of slots with s at head"
+ (let (hd tl)
+ (when s
+ (setq hd (cons (tam--slot-index s) nil))
+ (setq tl hd)
+ (while (setq s (tam--slot-next s))
+ (setcdr tl (cons (tam--slot-index s) nil))
+ (setq tl (cdr tl))))
+ hd))
+
(defun tam-table-free-list (tbl)
"Return list of free indices in TBL."
- (cl-loop for s = (tam--table-first-free tbl) then (tam--slot-next s)
- while s
- collect (tam--slot-index s)))
+ (tam--slot-list (tam--table-first-free tbl)))
(defun tam-table-live-list (tbl)
"Return list of live indices in TBL."
- (cl-loop for s = (tam--table-first-used tbl) then (tam--slot-next s)
- while s
- collect (tam--slot-index s)))
+ (tam--slot-list (tam--table-first-used tbl)))
-(defun tam-create-pool (N allocate &optional reset)
- "Make a pool of N pre-allocated objects.
-Arguments:
- N - number of pre-allocated objects
- ALLOCATE - function of zero arguments returning an uninitialized object
- RESET - function taking an object and setting it to an uninitialized state
-RESET must perform any required finalization."
- (let ((tbl (tam-create-table N))
- (v (make-vector N nil)))
- (dotimes (k N)
- (aset v k (funcall allocate)))
- (tam--pool-create tbl v allocate reset)))
-(defun tam-pool-get (pool idx)
- "Get contents of slot IDX of POOL."
- (aref (tam--pool-objs pool) idx))
-(defun tam-pool-claim (pool)
- "Return a free object from POOL if available, nil otherwise."
- (let ((idx (tam-allocate (tam--pool-table pool) nil))
- obj)
- (when idx
- (setq obj (aref (tam--pool-objs pool) idx)))
- obj))
+(defsubst tam-claim/inline (pool)
+ "Return index of a free object from POOL if available, nil otherwise.
+Moves object to live list.
+Inlined version"
+ (let ((s (tam--allocate-slot pool))
+ idx)
+ (when s
+ (setq idx (tam--slot-index s)))
+ idx))
+
+(defun tam-claim (pool)
+ "Return index of a free object from POOL if available, nil otherwise.
+Moves object to live list."
+ (tam-claim/inline pool))
-(defun tam-pool-free (pool idx)
- "Free object IDX of POOL."
- (let ((obj (aref (tam--pool-objs pool) idx))
+(defsubst tam-release/inline (pool idx)
+ "Release object at index IDX of POOL."
+ (let ((s (tam-pool-get pool idx))
(reset (tam--pool-reset pool)))
- (tam-free (tam--pool-table pool) idx)
+ (tam--free-slot pool s)
(when reset
- (funcall reset obj))
+ (funcall reset (tam--slot-contents s)))
nil))
+(defun tam-release (pool idx)
+ "Release object at index IDX of POOL."
+ (tam-release/inline pool idx))
(provide 'tam)
;;; tam.el ends here
