Improve malloc debug

compiler/debug.corth

@@ -444,7 +444,7 @@ in let log-item log-stream in
        arg1 log-stream fput-log-item
 
     else type LOG-TYPE:STACK-SIZE-NOT-EQ = if
-      "error: stack size do not match the expected stack size\n" log-stream fputs
+      "error: the current local stack size does not match the expected stack size\n" log-stream fputs
       "expected: " log-stream fputs arg1 log-stream fput-types log-stream fputnl
       "got: " log-stream fputs arg2 log-stream fput-types log-stream fputnl
 

examples/malloc_example.corth

@@ -3,17 +3,20 @@ include "core/stack.corth"
 
 macro malloc:ARRAY-SIZE       0x4000 endmacro
 macro malloc:AVAIL-STACK-SIZE 0x100  endmacro
-include "dynamic/malloc.corth"
 include "dynamic/debug_malloc.corth"
 
+memory index sizeof(int) end
+
 proc allocate-space
   int -> ptr
 in let size in
-  size malloc let object in
+  size index @64 malloc let object in
     object mlength size != if
       "[INFO] Size does not match.\n" puts
+      1 exit drop
     else
-      "[INFO] Successfully allocated object.\n" puts
+      "[INFO] Successfully allocated object with index " puts index @64 puti ".\n" puts
+      index @inc64
     end
 
     STDOUT debug-dynamic-memory
@@ -24,10 +27,13 @@ end end
 proc deallocate-space
   ptr ->
 in let container in
-  container mfree if
-    "[INFO] Successfully deallocated object.\n" puts
-  else
-    "[INFO] Could not deallocate object.\n" puts
+  container debug-malloc:get-tag let tag in
+    container mfree if
+      "[INFO] Successfully deallocated object with index " puts tag puti ".\n" puts
+    else
+      "[INFO] Could not deallocate object.\n" puts
+      1 exit drop
+    end
   end
 
   STDOUT debug-dynamic-memory
@@ -37,6 +43,7 @@ proc main
   int int -> int
 in let argc argv in
   malloc:init
+  0 index !64
 
   STDOUT debug-dynamic-memory
 

std/dynamic/_malloc.corth

@@ -0,0 +1,238 @@
+// Before this library is included, malloc:ARRAY-SIZE and malloc:AVAIL-STACK-SIZE must be defined.
+// Before using any of the procedures or macros, malloc:init must be called.
+
+// malloc:array is a linked list with items called 'blocks'.
+
+// Block structure:
+//   int*   next-block
+//   byte[] container
+
+// malloc:avail-stack is a sorted stack that contains the pointers of the unused blocks.
+
+include "collections/stack64.corth"
+include "collections/sorted64.corth"
+
+memory malloc:array              malloc:ARRAY-SIZE       and
+       malloc:avail-stack-array  malloc:AVAIL-STACK-SIZE and
+       malloc:avail-stack-length sizeof(int)             end
+
+namespace malloc
+
+macro avail-stack malloc:avail-stack-array malloc:avail-stack-length endmacro
+
+
+proc _init -> in
+  // Set the available stack length to 0.
+  0 malloc:avail-stack-length !64
+
+  // Create the first block.
+  malloc:array malloc:ARRAY-SIZE + malloc:array !64
+
+  // Append the block as available to the available stack.
+  malloc:array malloc:avail-stack stack64:append
+end
+
+
+// ptr: block -> ptr: next-block
+macro next-block
+  @64
+endmacro
+
+
+// ptr: next-block ptr: block ->
+macro set-next-block
+  !64
+endmacro
+
+
+// ptr: container -> ptr: block
+macro block
+  8 -
+endmacro
+
+
+// ptr: block -> ptr: container
+macro container
+  8 +
+endmacro
+
+
+// ptr: block -> int: size
+// Returns the size of the block.
+// The size of the block is equal to the difference between the next block and the current block.
+macro block-size let _block_ in
+  _block_ malloc:next-block _block_ -
+end endmacro
+
+
+// ptr: block -> int: size
+// Returns the size of the block.
+// The size of the container is equal to the size of the block that contains the container minus eight.
+macro container-size
+  malloc:block-size 8 -
+endmacro
+
+
+proc find-min-available
+  // int: expected-size -> ptr: available-group int: group-size int: group-id
+  int -> ptr int int
+in let size in
+  memory available-group sizeof(ptr) and
+         available-size  sizeof(int) and
+         available-id    sizeof(int) in
+
+    // available-id is the ID of stack item that points to the group.
+    // group = stack[id]
+    // size = *group - group
+
+    NULLPTR available-group !64
+    MAX-INT available-size  !64
+
+    // Find the group with the smallest size that has enough space.
+    0 while dup malloc:avail-stack-length @64 < do let id in
+      id malloc:avail-stack stack64:get let group in
+        group malloc:block-size let group-size in
+          group-size size 8 + = if
+            // If group-size is equal to size + 8, then we have found the best possible block, no need to keep iterating.
+            group group-size id return
+          end
+
+          group-size size 16 + >= if
+            // If the group has enough space, that is, if the group has at least expected size plus sixteen bytes of free space.
+            group-size available-size @64 < if
+              // Find the smallest group.
+              group      available-group !64
+              group-size available-size  !64
+              id         available-id    !64
+            end
+          end
+        end
+      end
+    id end inc end drop
+
+    available-group @64 available-size @64 available-id @64
+  end
+end end
+
+endnamespace
+
+
+proc _malloc
+  // int: length -> ptr: addr
+  int -> ptr
+  // Allocates memory with a specific size, allows dynamic memory management.
+  // Always allocates the smallest availiable segment for memory efficiency.
+in let size in
+  // Check if the size argument is valid.
+  size is-neg if
+    NULLPTR return
+  end
+
+  // Find the block with the smallest size that has enough space.
+  size malloc:find-min-available let available-block available-size available-id in
+
+    // Could not find a block with enough size.
+    available-block malloc:next-block is-null if NULLPTR return end
+
+    size 8 + available-size = if
+      // Size was equal to available space, therefore the block should be kept intact.
+
+      available-id malloc:avail-stack stack64:pop drop
+    else
+      // Size was less than available, therefore the block should be split in two.
+
+      //    ____________________________
+      //   /                            \
+      // |-------|---------------------|-------|------|
+      // | &next |######container######| &next |@cont@|
+      // |-------|---------------------|-------|------|
+
+      // Will be split as:
+
+      //    _____________  _____________
+      //   /             \/             \
+      // |-------|------|-------|------|-------|------|
+      // | &next |@cont@| &next |#cont#| &next |@cont@|
+      // |-------|------|-------|------|-------|------|
+
+      // (# represents unused space, @ represents used space.)
+
+      // This means that even if the containers are empty, we need 16 bytes of free space for the pointers.
+      // To split a block into two sub-blocks with one of the sub-blocks having L bytes of space, the block must have at least L + 16 bytes of free space.
+
+      available-block malloc:container size + let new-next in
+
+        // Set the new block's next-block to the selected-block's next-block.
+        available-block malloc:next-block new-next malloc:set-next-block
+
+        // Set the next-block as the next block.
+        new-next available-block malloc:set-next-block
+
+        // Update the available blocks table.
+        new-next available-id malloc:avail-stack stack64:set
+      end
+    end
+
+    // Return the container position.
+    available-block malloc:container
+  end
+end end
+
+
+proc _mfree
+  // ptr: container -> bool: successful
+  ptr -> bool
+  // Frees space up allocated by malloc.
+in malloc:block let block in
+  block malloc:avail-stack-array malloc:avail-stack-array malloc:avail-stack-length @64 8 * + sorted64:available if drop
+    // If that block was already specified as free.
+    false return
+  end
+
+  malloc:avail-stack-array - 8 / let index in
+    // Add the block to the available blocks table.
+    block index malloc:avail-stack stack64:insert
+
+    // Merge the next block, if it is unused.
+    index inc malloc:avail-stack-length < if
+      block malloc:next-block index inc malloc:avail-stack stack64:get = if
+        // Remove the next block from the available blocks table.
+        index inc malloc:avail-stack stack64:pop drop
+
+        // Set the next-next block as the next block.
+        block malloc:next-block malloc:next-block block malloc:set-next-block
+      end
+    end
+
+    index is-pos if
+      index dec malloc:avail-stack stack64:get let prev-block in
+        // Merge the previous block, if it is unused.
+        prev-block malloc:next-block block = if
+          // Set the next block as the next block of the previous block.
+          block malloc:next-block prev-block malloc:set-next-block
+
+          // Remove the block from the available blocks table.
+          // TODO: There is the possibility of performing two consecutive pop operations, which causes a call to memcpy Twice. This could be made more efficient by calling memcpy only once.
+          index malloc:avail-stack stack64:pop drop
+        end
+      end
+    end
+  end
+end true end
+
+
+// Deallocates both the array and ALL of its sub items.
+macro _mfree-deep let _array_ in // ptr: array -> bool: success
+  _array_ while dup _array_ malloc:block malloc:next-block < do
+    dup @64 mfree drop
+  8 + end drop
+
+  _array_ mfree
+end endmacro
+
+
+macro _mlength
+  // ptr: addr -> int: length
+  // Returns the length of an object created using malloc.
+  malloc:block malloc:container-size
+endmacro

std/dynamic/debug_malloc.corth

@@ -1,6 +1,6 @@
 include "linux_x86/sys.corth"
 include "linux_x86/io/output.corth"
-include "dynamic/malloc.corth"
+include "dynamic/_malloc.corth"
 
 
 // Can be used to debug malloc segments.
@@ -54,7 +54,7 @@ in
 true end
 
 
-// Can bu used to see how much space is available and to check memory leaks.
+// Can be used to check the space available and to check memory leaks.
 proc get-available-dynamic-memory
   -> int
 in
@@ -68,3 +68,19 @@ in
     sum @64
   end
 end
+
+macro malloc:init malloc:_init endmacro
+
+// This returns a shifted pointer.
+// The created dynamicly-placed object contains debug tag information which is hidden from the user.
+macro malloc let _size_ _debug_ in
+  size 8 + _malloc peek _obj_ in _obj_ isn-null if
+    _debug_ _obj_ !64
+  end end 8 +
+end endmacro
+macro mfree       8 - _mfree       endmacro
+macro mfree-deep  _mfree-deep      endmacro
+macro mlength     8 - _mlength 8 - endmacro
+
+macro debug-malloc:get-tag 8 - @64 endmacro
+macro debug-malloc:set-tag 8 - !64 endmacro