|
|
@ -15,20 +15,20 @@ |
|
|
|
(defstruct block-allocation |
|
|
|
size size_t |
|
|
|
capacity size_t |
|
|
|
data (* (unsigned char))) |
|
|
|
data (addr (unsigned char))) |
|
|
|
|
|
|
|
(defun block-allocation-create (size size_t &return (* block-allocation)) |
|
|
|
(defun block-allocation-create (size size_t &return (addr 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))))) |
|
|
|
(var-cast-to new-block (addr 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) (* (unsigned char)))) |
|
|
|
(set (path new-block > data) (type-cast (+ new-block 1) (addr (unsigned char)))) |
|
|
|
(return new-block)) |
|
|
|
|
|
|
|
(defun block-allocation-free (block (* block-allocation)) |
|
|
|
(defun block-allocation-free (block (addr block-allocation)) |
|
|
|
(free block)) |
|
|
|
|
|
|
|
;; |
|
|
@ -36,7 +36,7 @@ |
|
|
|
;; |
|
|
|
|
|
|
|
;; Unaligned! |
|
|
|
(defun linear-allocate (block (* block-allocation) size size_t &return (* void)) |
|
|
|
(defun linear-allocate (block (addr block-allocation) size size_t &return (addr void)) |
|
|
|
(unless (and block (path block > data)) |
|
|
|
(allocate-failure "block allocation was not initialized") |
|
|
|
(return null)) |
|
|
@ -45,11 +45,11 @@ |
|
|
|
(allocate-failure "failed to allocate: not enough capacity for requested size") |
|
|
|
(return null)) |
|
|
|
|
|
|
|
(var-cast-to start (* void) (+ (path block > data) (path block > size))) |
|
|
|
(var-cast-to start (addr void) (+ (path block > data) (path block > size))) |
|
|
|
(set (path block > size) (+ (path block > size) size)) |
|
|
|
(return start)) |
|
|
|
|
|
|
|
(defun linear-allocate-clear (block (* block-allocation)) |
|
|
|
(defun linear-allocate-clear (block (addr block-allocation)) |
|
|
|
(when block |
|
|
|
(set (path block > size) 0))) |
|
|
|
|
|
|
@ -76,24 +76,24 @@ |
|
|
|
;; 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)) |
|
|
|
;; (var chain-root (addr 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 my-thing (* thing) (chain-allocate-aligned (addr working-allocator) |
|
|
|
;; (var working-allocator (addr chain-allocation) last-chain-link) |
|
|
|
;; (var my-thing (addr thing) (chain-allocate-aligned (addr working-allocator) |
|
|
|
;; (sizeof thing) (alignof 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 chain-allocation |
|
|
|
next-link (* chain-allocation) |
|
|
|
next-link (addr chain-allocation) |
|
|
|
new-block-size size_t |
|
|
|
block block-allocation) |
|
|
|
|
|
|
|
(defun chain-allocation-create (new-block-size size_t &return (* chain-allocation)) |
|
|
|
(defun chain-allocation-create (new-block-size size_t &return (addr chain-allocation)) |
|
|
|
;; Create the header alongside the block so it can all go away in one free |
|
|
|
(var-cast-to new-chain (* chain-allocation) |
|
|
|
(var-cast-to new-chain (addr chain-allocation) |
|
|
|
(malloc (+ new-block-size (sizeof (type chain-allocation))))) |
|
|
|
(unless new-chain |
|
|
|
(allocate-failure "System malloc failed. System out of memory?") |
|
|
@ -102,28 +102,28 @@ |
|
|
|
(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) (* (unsigned char)))) |
|
|
|
(set (path new-chain > block . data) (type-cast (+ new-chain 1) (addr (unsigned char)))) |
|
|
|
(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) |
|
|
|
(var (token-splice next-link-name) (addr chain-allocation) |
|
|
|
(token-splice root)) |
|
|
|
(while (token-splice next-link-name) |
|
|
|
(var (token-splice current-link-name) (* chain-allocation) (token-splice next-link-name)) |
|
|
|
(var (token-splice current-link-name) (addr 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 chain-allocation-free (root (* chain-allocation)) |
|
|
|
(defun chain-allocation-free (root (addr chain-allocation)) |
|
|
|
(each-link-in-chain-allocator root current-link next-link |
|
|
|
(free current-link))) |
|
|
|
|
|
|
|
(defun-local chain-allocate-new-link (last-link-in-chain-in-out (* (* chain-allocation)) |
|
|
|
(defun-local chain-allocate-new-link (last-link-in-chain-in-out (addr (addr chain-allocation)) |
|
|
|
requested-size size_t) |
|
|
|
(var current-link (* chain-allocation) (deref last-link-in-chain-in-out)) |
|
|
|
(var current-link (addr chain-allocation) (deref last-link-in-chain-in-out)) |
|
|
|
|
|
|
|
;; 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 |
|
|
@ -133,18 +133,18 @@ |
|
|
|
(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)) |
|
|
|
(var new-link (addr 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)) |
|
|
|
|
|
|
|
;; You must pass in the address of chain because the chain may be extended |
|
|
|
(defun-local chain-allocate-internal (last-link-in-chain-in-out (* (* chain-allocation)) |
|
|
|
(defun-local chain-allocate-internal (last-link-in-chain-in-out (addr (addr chain-allocation)) |
|
|
|
requested-size size_t |
|
|
|
&return (* void)) |
|
|
|
(var current-link (* chain-allocation) (deref last-link-in-chain-in-out)) |
|
|
|
&return (addr void)) |
|
|
|
(var current-link (addr chain-allocation) (deref last-link-in-chain-in-out)) |
|
|
|
(assert (and (not (path current-link > next-link)) |
|
|
|
"chain-allocate-internal called with link that is not the last link in the chain.")) |
|
|
|
(var memory (* void) null) |
|
|
|
(var memory (addr void) null) |
|
|
|
;; Enough room in this link? |
|
|
|
(when (<= requested-size (- (path current-link > block . capacity) |
|
|
|
(path current-link > block . size))) |
|
|
@ -156,20 +156,20 @@ |
|
|
|
|
|
|
|
;; Use for streams of bytes and strings. Do not use for structs or data larger than byte alignment, |
|
|
|
;; or performance will suffer. |
|
|
|
(defun chain-allocate-unaligned (last-link-in-chain-in-out (* (* chain-allocation)) size size_t |
|
|
|
&return (* void)) |
|
|
|
(defun chain-allocate-unaligned (last-link-in-chain-in-out (addr (addr chain-allocation)) size size_t |
|
|
|
&return (addr void)) |
|
|
|
(return (chain-allocate-internal last-link-in-chain-in-out size))) |
|
|
|
|
|
|
|
;; Use for structured data |
|
|
|
(defun chain-allocate-aligned (last-link-in-chain-in-out (* (* chain-allocation)) size size_t |
|
|
|
(defun chain-allocate-aligned (last-link-in-chain-in-out (addr (addr chain-allocation)) size size_t |
|
|
|
alignment (unsigned int) |
|
|
|
&return (* void)) |
|
|
|
&return (addr void)) |
|
|
|
;; Used to goto back to the free space alignment when we need a new block |
|
|
|
(each-in-range 2 num-passes |
|
|
|
;; Eat up some extra bytes to ensure alignment |
|
|
|
(var current-block (* block-allocation) (addr (path (deref last-link-in-chain-in-out) > block))) |
|
|
|
(var next-free-memory (* (const (unsigned char))) (+ (path current-block > data) |
|
|
|
(path current-block > size))) |
|
|
|
(var current-block (addr block-allocation) (addr (path (deref last-link-in-chain-in-out) > block))) |
|
|
|
(var next-free-memory (addr (const (unsigned char))) (+ (path current-block > data) |
|
|
|
(path current-block > size))) |
|
|
|
(var-cast-to throwaway-bytes uintptr_t |
|
|
|
(- alignment |
|
|
|
(mod (type-cast (+ next-free-memory alignment) uintptr_t) |
|
|
@ -181,10 +181,10 @@ |
|
|
|
(if (<= total-size-to-request (- (path current-block > capacity) |
|
|
|
(path current-block > size))) |
|
|
|
(scope ;; Enough space. Allocate it! |
|
|
|
(var-cast-to space-before-alignment (* (unsigned char)) |
|
|
|
(var-cast-to space-before-alignment (addr (unsigned char)) |
|
|
|
(chain-allocate-internal last-link-in-chain-in-out |
|
|
|
total-size-to-request)) |
|
|
|
(return (type-cast (+ space-before-alignment throwaway-bytes) (* void)))) |
|
|
|
(return (type-cast (+ space-before-alignment throwaway-bytes) (addr void)))) |
|
|
|
(scope ;; Need a new block. We need to allocate the new block and re-compute alignment. |
|
|
|
;; Our data is going to start immediately after the block header. Let's make sure we request |
|
|
|
;; enough memory to do our alignment, assuming the block header is completely unaligned and a |
|
|
@ -203,13 +203,13 @@ |
|
|
|
(token-splice chain) |
|
|
|
(* (token-splice count) (sizeof (type (token-splice type)))) |
|
|
|
(alignof (type (token-splice type)))) |
|
|
|
(* (token-splice type)))) |
|
|
|
(addr (token-splice type)))) |
|
|
|
(tokenize-push output |
|
|
|
(type-cast (chain-allocate-aligned |
|
|
|
(token-splice chain) |
|
|
|
(sizeof (type (token-splice type))) |
|
|
|
(alignof (type (token-splice type)))) |
|
|
|
(* (token-splice type))))) |
|
|
|
(addr (token-splice type))))) |
|
|
|
(return true)) |
|
|
|
|
|
|
|
;; |
|
|
@ -237,13 +237,13 @@ |
|
|
|
('auto-test |
|
|
|
(defun test--allocators (&return int) |
|
|
|
(scope |
|
|
|
(var block (* block-allocation) (block-allocation-create 1024)) |
|
|
|
(var block (addr 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)) |
|
|
|
(var fail-item (addr void) (linear-allocate block 1025)) |
|
|
|
(when fail-item |
|
|
|
(fprintf stderr "Expected to fail to allocate, but it succeeded\n") |
|
|
|
(block-allocation-free block) |
|
|
@ -251,14 +251,14 @@ |
|
|
|
|
|
|
|
(scope |
|
|
|
;; Linear allocate |
|
|
|
(var succeed-item (* void) (linear-allocate block 1024)) |
|
|
|
(var succeed-item (addr 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)) |
|
|
|
(var fail-item (addr void) (linear-allocate block 1)) |
|
|
|
(when fail-item |
|
|
|
(fprintf stderr "Expected to fail to allocate, but it succeeded\n") |
|
|
|
(block-allocation-free block) |
|
|
@ -273,8 +273,8 @@ |
|
|
|
(block-allocation-free block)) |
|
|
|
|
|
|
|
(scope ;; Chain allocator |
|
|
|
(var chain-root (* chain-allocation) (chain-allocation-create 64)) |
|
|
|
(var chain (* chain-allocation) chain-root) |
|
|
|
(var chain-root (addr chain-allocation) (chain-allocation-create 64)) |
|
|
|
(var chain (addr chain-allocation) chain-root) |
|
|
|
(unless chain |
|
|
|
(fprintf stderr "Expected to successfully create chain, but it failed\n") |
|
|
|
(return 1)) |
|
|
@ -286,7 +286,7 @@ |
|
|
|
(fprintf stderr "Failed linear allocation to full link\n") |
|
|
|
(chain-allocation-free chain-root) |
|
|
|
(return 1)) |
|
|
|
(var previous-link (* chain-allocation) chain) |
|
|
|
(var previous-link (addr chain-allocation) chain) |
|
|
|
(unless (and (chain-allocate-unaligned (addr chain) 32) (!= previous-link chain)) |
|
|
|
(fprintf stderr "Failed re-allocation after full link\n") |
|
|
|
(chain-allocation-free chain-root) |
|
|
@ -302,9 +302,9 @@ |
|
|
|
;; Make sure we're at a wacky alignment |
|
|
|
(chain-allocate-unaligned (addr chain) 3) |
|
|
|
(defstruct my-align-struct |
|
|
|
thing (* void) |
|
|
|
thing (addr void) |
|
|
|
c (unsigned char)) |
|
|
|
(var-cast-to first-aligned (* my-align-struct) |
|
|
|
(var-cast-to first-aligned (addr my-align-struct) |
|
|
|
(chain-allocate-aligned (addr chain) |
|
|
|
(sizeof (type my-align-struct)) |
|
|
|
(alignof (type my-align-struct)))) |
|
|
@ -315,7 +315,7 @@ |
|
|
|
(return 1)) |
|
|
|
|
|
|
|
;; Ensure we are packed nicely once the first element is aligned |
|
|
|
(var-cast-to second-aligned (* my-align-struct) |
|
|
|
(var-cast-to second-aligned (addr my-align-struct) |
|
|
|
(chain-allocate-aligned (addr chain) |
|
|
|
(sizeof (type my-align-struct)) |
|
|
|
(alignof (type my-align-struct)))) |
|
|
@ -328,7 +328,7 @@ |
|
|
|
|
|
|
|
;; Make sure to exercise case where block is too small to fit aligned struct |
|
|
|
(each-in-range 100 i |
|
|
|
(var-cast-to many-aligned (* my-align-struct) |
|
|
|
(var-cast-to many-aligned (addr my-align-struct) |
|
|
|
(chain-allocate-aligned (addr chain) |
|
|
|
(sizeof (type my-align-struct)) |
|
|
|
(alignof (type my-align-struct)))) |
|
|
@ -340,7 +340,7 @@ |
|
|
|
|
|
|
|
;; Use valgrind to verify this one |
|
|
|
(var num-contiguous (const int) 100) |
|
|
|
(var contiguous-aligned-array (* my-align-struct) |
|
|
|
(var contiguous-aligned-array (addr my-align-struct) |
|
|
|
(chain-allocate-aligned-type (addr chain) my-align-struct num-contiguous)) |
|
|
|
(each-in-range num-contiguous i |
|
|
|
(set (field (at i contiguous-aligned-array) c) 'a')) |
|
|
|