GameLib is a collection of libraries for creating applications in Cakelisp.
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

243 lines
10 KiB

;; Allocator.cake: Specialized allocators for performance and convenience
;; Define 'Allocator-no-asserts if your program is set up to handle memory failures
(add-cakelisp-search-directory "Dependencies/cakelisp/runtime")
(import "CHelpers.cake")
(c-import "<stdlib.h>"
(c-import "<stdio.h>")))
(forward-declare (struct block-allocation))
(defstruct-local block-allocation
size size_t
capacity size_t
data (* void))
(defun-local block-allocation-create (size size_t &return (* block-allocation))
;; Create the header alongside the block so it can all go away in one free
(var-cast-to new-block (* block-allocation) (malloc (+ size (sizeof (type block-allocation)))))
(unless new-block
(allocate-failure "System malloc failed. System out of memory?")
(return null))
(set (path new-block > size) 0)
(set (path new-block > capacity) size)
(set (path new-block > data) (type-cast (+ new-block 1) (* void)))
(return new-block))
(defun-local block-allocation-free (block (* block-allocation))
(free block))
;; Simple linear allocator based on a single block
(defun-local linear-allocate (block (* block-allocation) size size_t &return (* void))
(unless (and block (path block > data))
(allocate-failure "block allocation was not initialized")
(return null))
;; failed to allocate: not enough capacity for requested size
(unless (<= size (- (path block > capacity) (path block > size)))
(allocate-failure "failed to allocate: not enough capacity for requested size")
(return null))
(var-cast-to start (* void) (+ (type-cast (path block > data) (* char)) (path block > size)))
(set (path block > size) (+ (path block > size) size))
(return start))
(defun-local linear-allocate-clear (block (* block-allocation))
(when block
(set (path block > size) 0)))
;; Chain allocator
;; I'm not sure what this is normally called. Create a linked list of block
;; allocations, only allowing allocate, then freeing in one go. This gives similar performance to
;; a single block allocator, but can handle highly variable or unknown sizes.
;; - This will waste a bit of memory at the end of blocks if there isn't space. Use large block sizes
;; relative to the allocation sizes.
;; - If an allocation is larger than the chain block size, the new block will be sized to fit that
;; allocation. However, you should avoid this, because it means the next chain allocation will
;; definitely require another new block made. Try to keep your chain block sizes bigger than your
;; allocations.
;; !!! PITFALL !!!
;; The chain allocator is a singly linked list going in the forward direction. This means that in
;; order to traverse all blocks in the chain, you must pass in the root of the chain.
;; This is tricky because (chain-allocate) updates the chain pointer to be the most recent block,
;; which is NOT what you want to pass in to (chain-allocation-free). Always pass the very first
;; (root) block to (chain-allocation-free).
;; Advanced use:
;; You can use the chain allocator like a stack allocator via assuming a new chain root, then
;; freeing the chain starting from there.
;; You need to copy the root and free from that so that the parent chain's block size isn't changed.
;; Example:
;; (var chain-root (* chain-allocation) (chain-allocation-create 1024))
;; ;; Your program does a bunch of allocations on chain-root, then passes in last-chain-link
;; (var stack-before-my-operation chain-allocation (deref last-chain-link)) ;; Copy it to save the capacity
;; (var my-stack-allocator-root chain-allocation last-chain-link)
;; (var working-allocator (* chain-allocation) last-chain-link)
;; (var thing (* void) (chain-allocate (addr working-allocator) (sizeof thing)))
;; ;; All done, "pop" from our stack and reset the capacity
;; (chain-allocation-free my-stack-allocator-root)
;; (set (deref last-chain-link) stack-before-my-operation)
(defstruct-local chain-allocation
next-link (* chain-allocation)
new-block-size size_t
block block-allocation)
(defun-local chain-allocation-create (new-block-size size_t &return (* chain-allocation))
;; Create the header alongside the block so it can all go away in one free
(var-cast-to new-chain (* chain-allocation)
(malloc (+ new-block-size (sizeof (type chain-allocation)))))
(unless new-chain
(allocate-failure "System malloc failed. System out of memory?")
(return null))
(set (path new-chain > next-link) null)
(set (path new-chain > new-block-size) new-block-size)
(set (path new-chain > block . size) 0)
(set (path new-chain > block . capacity) new-block-size)
(set (path new-chain > block . data) (type-cast (+ new-chain 1) (* void)))
(return new-chain))
(defmacro each-link-in-chain-allocator (root any current-link-name symbol next-link-name symbol
&rest body any)
(tokenize-push output
(var (token-splice next-link-name) (* chain-allocation)
(token-splice root))
(while (token-splice next-link-name)
(var (token-splice current-link-name) (* chain-allocation) (token-splice next-link-name))
(set (token-splice next-link-name) (path (token-splice current-link-name) > next-link))
(token-splice-rest body tokens)))
(return true))
;; Must pass in the first block, not the final chain pointer!
(defun-local chain-allocation-free (root (* chain-allocation))
(each-link-in-chain-allocator root current-link next-link
(free current-link)))
;; You must pass in the address of chain because the chain may be extended
(defun-local chain-allocate (last-link-in-chain-in-out (* (* chain-allocation)) size size_t
&return (* void))
(var requested-size size_t size)
(var current-link (* chain-allocation) (deref last-link-in-chain-in-out))
(assert (and (not (path current-link > next-link))
"chain-allocate called with link that is not the last link in the chain."))
(var memory (* void) null)
;; Enough room in this link?
(when (<= requested-size (- (path current-link > block . capacity)
(path current-link > block . size)))
(return (linear-allocate (addr (path current-link > block)) requested-size)))
;; Not enough space in current link; let's allocate a new link
;; If the requested size is less than the chain has been allocating, use the chain size to
;; minimize allocations. If the size is larger, use that, and be fine having a chain with blocks
;; bigger than the max size. This isn't going to be very efficient for the next allocation, which
;; is why it's still important that the user picks a good block size.
(var chain-block-size size_t (path current-link > new-block-size))
(var requested-block-size size_t chain-block-size)
(when (> requested-size chain-block-size)
(set requested-block-size requested-size))
(var new-link (* chain-allocation) (chain-allocation-create requested-block-size))
(set (path current-link > next-link) new-link)
(set (deref last-link-in-chain-in-out) new-link)
(return (linear-allocate (addr (path new-link > block)) requested-size)))
;; Error handling behavior
(defmacro allocate-failure (message string)
;; If in testing, we want to trigger errors without asserting
(tokenize-push output
(fprintf stderr "%s\n" (token-splice message))))
;; Assert on memory failures
(tokenize-push output
(assert (and 0 (token-splice message))))))
(return true))
;; Tests
(defun test--allocators (&return int)
(var block (* block-allocation) (block-allocation-create 1024))
(unless (and block (path block > data))
(fprintf stderr "Failed to allocate a block\n")
(return 1))
(var fail-item (* void) (linear-allocate block 1025))
(when fail-item
(fprintf stderr "Expected to fail to allocate, but it succeeded\n")
(block-allocation-free block)
(return 1)))
;; Linear allocate
(var succeed-item (* void) (linear-allocate block 1024))
(unless succeed-item
(fprintf stderr "Expected to successfully allocate, but it failed\n")
(block-allocation-free block)
(return 1))
(fprintf stderr "Address of block: %p\nAddress of item: %p\n" block succeed-item)
;; Linear allocate from a full block (fail)
(var fail-item (* void) (linear-allocate block 1))
(when fail-item
(fprintf stderr "Expected to fail to allocate, but it succeeded\n")
(block-allocation-free block)
(return 1))
;; Linear allocate from a cleared block
(linear-allocate-clear block)
(set succeed-item (linear-allocate block 1024))
(unless succeed-item
(fprintf stderr "Expected to successfully allocate, but it failed\n")
(block-allocation-free block)
(return 1)))
(block-allocation-free block))
(scope ;; Chain allocator
(var chain-root (* chain-allocation) (chain-allocation-create 64))
(var chain (* chain-allocation) chain-root)
(unless chain
(fprintf stderr "Expected to successfully create chain, but it failed\n")
(return 1))
(unless (chain-allocate (addr chain) 32)
(fprintf stderr "Failed linear allocation\n")
(chain-allocation-free chain)
(return 1))
(unless (chain-allocate (addr chain) 32)
(fprintf stderr "Failed linear allocation to full link\n")
(chain-allocation-free chain)
(return 1))
(var previous-link (* chain-allocation) chain)
(unless (and (chain-allocate (addr chain) 32) (!= previous-link chain))
(fprintf stderr "Failed re-allocation after full link\n")
(chain-allocation-free chain)
(return 1))
(set previous-link chain)
(unless (and (chain-allocate (addr chain) 128) (!= previous-link chain))
(fprintf stderr "Failed allocation after requesting size larger than block\n")
(chain-allocation-free chain)
(return 1))
(each-link-in-chain-allocator chain-root current-link next-link
(fprintf stderr "Chain block %p\n\tsize %d\n\tcapacity %d\n"
current-link (type-cast (path current-link > block . size) int)
(type-cast (path current-link > block . capacity) int)))
(chain-allocation-free chain-root))
(return 0))))