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.
 
 
 
 
 
 

110 lines
3.6 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>"
"<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)))
(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)
(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)
(return 0))))