Add chain allocator, fix TinyCC pthread

src/Allocator.cake

@@ -52,6 +52,105 @@
   (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)
@@ -72,39 +171,73 @@
 (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)))
+     (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
-     ;; 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)
+     (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))
-     (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)
+     (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))
-     ;; 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)
+
+     (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))))

src/TinyCCompiler.cake

@@ -106,7 +106,8 @@ void test(void)
 
 (comptime-cond
  ('Unix
-  (add-library-dependency "dl")))
+  (add-library-dependency "dl")
+  (add-library-dependency "pthread")))
 
 ;; This is an unofficial mirror
 (add-dependency-git-submodule