gamelib/src/Allocator.cake

;; 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>"
          "<assert.h>")

(comptime-cond
 ('auto-test
  (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)
  (comptime-cond
   ('Allocator-no-asserts)
   ;; If in testing, we want to trigger errors without asserting
   ('auto-test
    (tokenize-push output
      (fprintf stderr "%s\n" (token-splice message))))
   ;; Assert on memory failures
   (true
    (tokenize-push output
      (assert (and 0 (token-splice message))))))
  (return true))

;;
;; Tests
;;

(comptime-cond
 ('auto-test
  (defun test--allocators (&return int)
    (scope
     (var block (* block-allocation) (block-allocation-create 1024))
     (unless (and block (path block > data))
       (fprintf stderr "Failed to allocate a block\n")
       (return 1))

     (scope
      (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)))

     (scope
      ;; 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))))