From 61b83a12934698e9e3b5053eea5182c0589b2c3d Mon Sep 17 00:00:00 2001
From: Jesse McDonald <nybble41@gmail.com>
Date: Sat, 24 Oct 2009 19:49:08 -0500
Subject: [PATCH] Add support for (strong) boxes, value vectors, and byte
 strings.

---
 gc.c | 74 ++++++++++++++++++++++++++++++++++++++++++++----------------
 1 file changed, 55 insertions(+), 19 deletions(-)

diff --git a/gc.c b/gc.c
index 688de74..b014a16 100644
--- a/gc.c
+++ b/gc.c
@@ -5,6 +5,7 @@
 #include <stdbool.h>
 #include <stdio.h>
 #include <stdlib.h>
+#include <string.h>
 #include <time.h>
 
 #ifndef NDEBUG
@@ -20,14 +21,17 @@ typedef uintptr_t value_t;
 /* Object: aaaaaaaa aaaaaaaa aaaaaaaa aaaaaa10                       */
 /* Fixnum: snnnnnnn nnnnnnnn nnnnnnnn nnnnnnn1                       */
 
-#define NIL          ((value_t)0)
 
-/* Special values (1 <= n < 1024) */
+/* Special values (0 <= n < 1024) */
 /* These correspond to pairs within the first page of memory */
 #define SPECIAL_VALUE(n) ((value_t)(4*n))
 #define MAX_SPECIAL      SPECIAL_VALUE(1023)
 
+#define NIL              SPECIAL_VALUE(0)
 #define BROKEN_HEART     SPECIAL_VALUE(1)
+#define TYPE_TAG_BOX     SPECIAL_VALUE(2)
+#define TYPE_TAG_VECTOR  SPECIAL_VALUE(3)
+#define TYPE_TAG_BYTESTR SPECIAL_VALUE(4)
 
 typedef struct pair
 {
@@ -44,6 +48,20 @@ typedef struct object
   } payload;
 } object_t;
 
+typedef struct vector
+{
+  value_t tag;
+  size_t  size;
+  value_t elements[0];
+} vector_t;
+
+typedef struct byte_string
+{
+  value_t tag;
+  size_t  size;
+  uint8_t bytes[0];
+} byte_string_t;
+
 typedef struct gc_root
 {
   value_t value;
@@ -81,7 +99,7 @@ static inline value_t pair_value(pair_t *p)
   return (value_t)p;
 }
 
-static inline value_t object_value(object_t *obj)
+static inline value_t object_value(void *obj)
 {
   return (value_t)obj | 2;
 }
@@ -237,11 +255,26 @@ static void transfer_object(value_t *value)
     {
       switch (obj->tag)
       {
-#if 0
       case TYPE_TAG_VECTOR:
+        {
+          const vector_t *vec = (const vector_t*)obj;
+          const size_t nbytes = sizeof(vector_t) + sizeof(value_t) * vec->size;
+          vector_t *newvec = (vector_t*)gc_alloc(nbytes);
+          memcpy(newvec, vec, nbytes);
+          new_value = object_value(newvec);
+        }
         break;
-#endif
-      default: /* pair or compatible */
+      case TYPE_TAG_BYTESTR:
+        {
+          const byte_string_t *str = (const byte_string_t*)obj;
+          const size_t nbytes = sizeof(byte_string_t) + str->size;
+          byte_string_t *newstr = (byte_string_t*)gc_alloc(nbytes);
+          memcpy(newstr, str, nbytes);
+          new_value = object_value(newstr);
+        }
+        break;
+      case TYPE_TAG_BOX:
+      default: /* pair */
         {
           pair_t *p = (pair_t*)gc_alloc(sizeof(pair_t));
           const pair_t *q = (const pair_t*)obj;
@@ -250,14 +283,7 @@ static void transfer_object(value_t *value)
           //debug(("Moved pair from 0x%0.8X to 0x%0.8X.\n", q, p));
 
           /* Keep the original tag bits (pair or object) */
-#if 0
-          if (is_pair(*value))
-            new_value = pair_value(p);
-          else
-            new_value = object_value((object_t*)p);
-#else
           new_value = pair_value(p) | (*value & 2);
-#endif
         }
         break;
       }
@@ -288,16 +314,26 @@ static inline size_t transfer_children(object_t *obj)
 {
   switch (obj->tag)
   {
-#if 0  /* Don't support other kinds of GC objects yet */
   case TYPE_TAG_VECTOR:
     {
-      return sizeof(*obj) +
-            sizeof(value_t) * from_fixnum(obj->payload.values[0]);
+      vector_t *vec = (vector_t*)obj;
+      const intptr_t nelem = from_fixnum(vec->size);
+
+      for (intptr_t i = 0; i < nelem; ++i)
+      {
+        transfer_object(&vec->elements[i]);
+      }
+
+      return sizeof(vector_t) + (nelem * sizeof(value_t));
     }
-#endif
-  default:
+  case TYPE_TAG_BYTESTR:
+    {
+      const byte_string_t *str = (const byte_string_t*)obj;
+      return sizeof(byte_string_t) + from_fixnum(str->size);
+    }
+  case TYPE_TAG_BOX:
+  default: /* pair */
     {
-      /* Object is a pair or compatible type (e.g. box) */
       pair_t *p = (pair_t*)obj;
       transfer_object(&p->car);
       transfer_object(&p->cdr);