Merge branch 'hw15'

regression/Makefile

@@ -12,4 +12,7 @@ $(TESTS): %: %.expr
 	@cat $@.input | $(RC) -s $< > $@.log && diff $@.log orig/$@.log
 
 clean:
-	rm -f test*.log *.s *~ $(TESTS)
+	$(RM) test*.log *.s *~ $(TESTS)
+	$(MAKE) clean -C expressions
+	$(MAKE) clean -C deep-expressions
+	$(MAKE) clean -C x86only

regression/deep-expressions/Makefile

@@ -12,4 +12,5 @@ $(TESTS): %: %.expr
 	@cat $@.input | $(RC) -s $< > $@.log && diff $@.log orig/$@.log
 
 clean:
-	rm -f *.log *.s *~ $(TESTS)
+	rm -f *.log *.s *~
+	find . -maxdepth 1 -type f -not -name '*.*' -not -name 'Makefile' -delete

regression/expressions/Makefile

@@ -12,4 +12,6 @@ $(TESTS): %: %.expr
 	@cat $@.input | $(RC) -s $< > $@.log && diff $@.log orig/$@.log
 
 clean:
-	rm -f *.log *.s *~ $(TESTS)
+	rm -f *.log *.s *~
+	find . -maxdepth 1 -type f -not -name '*.*' -not -name 'Makefile' -delete
+

regression/test039.expr

@@ -28,4 +28,3 @@ write (find (t, 6));
 write (find (t, 3));
 write (find (t, 2));
 write (find (t, 1))
-

runtime/Makefile

@@ -1,6 +1,12 @@
-all:
+all: gc_runtime.o runtime.o
-	gcc -m32 -c runtime.c
+	ar rc runtime.a gc_runtime.o runtime.o 
+
+gc_runtime.o: gc_runtime.s
+	gcc -g -fstack-protector-all -m32 -c gc_runtime.s
+
+runtime.o: runtime.c
+	gcc -g -fstack-protector-all -m32 -c runtime.c
 
 clean:
-	rm -f runtime.o *~
+	rm -f *.a *.o *~
 

runtime/gc_runtime.s

@@ -0,0 +1,114 @@
+			.data
+printf_format:		.string	"Stack root: %lx\n"
+printf_format2:		.string	"BOT: %lx\n"
+printf_format3:		.string	"TOP: %lx\n"
+printf_format4:		.string	"EAX: %lx\n"
+printf_format5:		.string	"LOL\n"
+__gc_stack_bottom:	.long	0
+__gc_stack_top:	        .long	0
+
+			.globl	__pre_gc
+			.globl	__post_gc
+			.globl	L__gc_init
+			.globl	__gc_root_scan_stack
+			.extern	init_pool
+			.extern	gc_test_and_copy_root
+			.text
+
+L__gc_init:		movl	%esp, __gc_stack_bottom
+			addl	$4, __gc_stack_bottom
+			call	init_pool
+			ret
+
+	// if __gc_stack_top is equal to 0
+	// then set __gc_stack_top to %ebp
+	// else return
+__pre_gc:
+			pushl	%eax
+			movl	__gc_stack_top, %eax
+			cmpl	$0, %eax
+			jne	__pre_gc_2
+			movl	%ebp, %eax
+			// addl	$8, %eax
+			movl	%eax, __gc_stack_top
+__pre_gc_2:
+			popl	%eax
+			ret
+
+	// if __gc_stack_top has been set by the caller
+	//   (i.e. it is equal to its %ebp)
+	// then set __gc_stack_top to 0
+	// else return
+__post_gc:
+			pushl	%eax
+			movl	__gc_stack_top, %eax
+			cmpl	%eax, %ebp
+			jnz	__post_gc2
+			movl	$0, __gc_stack_top
+__post_gc2:
+			popl	%eax
+			ret
+	
+	// Scan stack for roots
+	// strting from __gc_stack_top
+	// till __gc_stack_bottom
+__gc_root_scan_stack:
+			pushl	%ebp
+			movl	%esp, %ebp
+			pushl	%ebx
+			pushl	%edx
+			movl	__gc_stack_top, %eax
+			jmp 	next
+
+loop:
+			movl	(%eax), %ebx
+
+	// check that it is not a pointer to code section
+	// i.e. the following is not true:
+	// __executable_start <= (%eax) <= __etext
+check11:	
+			leal	__executable_start, %edx
+			cmpl	%ebx, %edx
+			jna	check12
+			jmp	check21
+
+check12:	
+			leal	__etext, %edx
+			cmpl	%ebx, %edx
+			jnb	next
+
+	// check that it is not a pointer into the program stack
+	// i.e. the following is not true:
+	// __gc_stack_bottom <= (%eax) <= __gc_stack_top
+check21:	
+			cmpl	%ebx, __gc_stack_top
+			jna	check22
+			jmp	loop2
+
+check22:
+			cmpl	%ebx, __gc_stack_bottom
+			jnb	next
+
+	// check if it a valid pointer
+	// i.e. the lastest bit is set to zero
+loop2:
+			andl	$0x00000001, %ebx
+			jnz     next
+gc_run_t:
+			pushl 	%eax
+  			pushl	%eax
+      			call	gc_test_and_copy_root
+        		addl	$4, %esp
+			popl	%eax
+
+next:
+			addl	$4, %eax
+			cmpl	%eax, __gc_stack_bottom
+			jne	loop
+returnn:
+			movl	$0, %eax
+			popl	%edx
+			popl	%ebx
+			movl	%ebp, %esp 
+			popl	%ebp
+			ret

runtime/runtime.c

@@ -2,18 +2,20 @@
 
 # include <stdio.h>
 # include <stdio.h>
-# include <malloc.h>
 # include <string.h>
 # include <stdarg.h>
-# include <alloca.h>
 # include <stdlib.h>
+# include <sys/mman.h>
+# include <assert.h>
 
-# define STRING_TAG 0x00000000
+// # define DEBUG_PRINT 1
-# define ARRAY_TAG  0x01000000
-# define SEXP_TAG   0x02000000
 
-# define LEN(x) (x & 0x00FFFFFF)
+# define STRING_TAG 0x00000001
-# define TAG(x) (x & 0xFF000000)
+# define ARRAY_TAG  0x00000003
+# define SEXP_TAG   0x00000005
+
+# define LEN(x) ((x & 0xFFFFFFF8) >> 3)
+# define TAG(x) (x & 0x00000007)
 
 # define TO_DATA(x) ((data*)((char*)(x)-sizeof(int)))
 # define TO_SEXP(x) ((sexp*)((char*)(x)-2*sizeof(int)))
@@ -32,22 +34,31 @@ typedef struct {
   data contents; 
 } sexp; 
 
+extern void* alloc (size_t);
+
 extern int Blength (void *p) {
-  data *a = TO_DATA(p);
+  data *a = (char*) BOX (NULL);
+  a = TO_DATA(p);
   return BOX(LEN(a->tag));
 }
 
 char* de_hash (int n) {
-  static char *chars = "_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNJPQRSTUVWXYZ";
+  static char *chars = (char*) BOX (NULL);
-  static char buf[6];
+  static char buf[6] = {0,0,0,0,0,0};
-  char *p = &buf[5];
+  char *p = (char*) BOX (NULL);
+  chars =  "_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNJPQRSTUVWXYZ";
+  p = &buf[5];
 
-  /*printf ("tag: %d\n", n);*/
+#ifdef DEBUG_PRINT
+  printf ("de_hash: tag: %d\n", n);
+#endif
   
   *p-- = 0;
 
   while (n != 0) {
-    /*printf ("char: %c\n", chars [n & 0x003F]);*/
+#ifdef DEBUG_PRINT
+    printf ("char: %c\n", chars [n & 0x003F]);
+#endif
     *p-- = chars [n & 0x003F];
     n = n >> 6;
   }
@@ -83,9 +94,10 @@ static void extendStringBuf () {
 }
 
 static void printStringBuf (char *fmt, ...) {
-  va_list args;
+  va_list args    = (va_list) BOX(NULL);
-  int     written, rest;
+  int     written = 0,
-  char   *buf;
+          rest    = 0;
+  char   *buf     = (char*) BOX(NULL);
 
  again:
   va_start (args, fmt);
@@ -102,9 +114,11 @@ static void printStringBuf (char *fmt, ...) {
 }
 
 static void printValue (void *p) {
+  data *a = (data*) BOX(NULL);
+  int i   = BOX(0);
   if (UNBOXED(p)) printStringBuf ("%d", UNBOX(p));
   else {
-    data *a = TO_DATA(p);
+    a = TO_DATA(p);
 
     switch (TAG(a->tag)) {      
     case STRING_TAG:
@@ -113,7 +127,7 @@ static void printValue (void *p) {
       
     case ARRAY_TAG:
       printStringBuf ("[");
-      for (int i = 0; i < LEN(a->tag); i++) {
+      for (i = 0; i < LEN(a->tag); i++) {
         printValue ((void*)((int*) a->contents)[i]);
 	if (i != LEN(a->tag) - 1) printStringBuf (", ");
       }
@@ -124,7 +138,7 @@ static void printValue (void *p) {
       printStringBuf ("`%s", de_hash (TO_SEXP(p)->tag));
       if (LEN(a->tag)) {
 	printStringBuf (" (");
-	for (int i = 0; i < LEN(a->tag); i++) {
+	for (i = 0; i < LEN(a->tag); i++) {
 	  printValue ((void*)((int*) a->contents)[i]);
 	  if (i != LEN(a->tag) - 1) printStringBuf (", ");
 	}
@@ -139,11 +153,10 @@ static void printValue (void *p) {
 }
 
 extern void* Belem (void *p, int i) {
-  data *a = TO_DATA(p);
+  data *a = (data *)BOX(NULL);
+  a = TO_DATA(p);
   i = UNBOX(i);
   
-  /* printf ("elem %d = %p\n", i, (void*) ((int*) a->contents)[i]); */
-
   if (TAG(a->tag) == STRING_TAG) {
     return (void*) BOX(a->contents[i]);
   }
@@ -152,17 +165,26 @@ extern void* Belem (void *p, int i) {
 }
 
 extern void* Bstring (void *p) {
-  int n = strlen (p);
+  int n   = BOX(0);
-  data *r = (data*) malloc (n + 1 + sizeof (int));
+  data *r = NULL;
 
-  r->tag = n;
+  __pre_gc () ;
+  
+  n = strlen (p);
+  r = (data*) alloc (n + 1 + sizeof (int));
+
+  r->tag = STRING_TAG | (n << 3);
   strncpy (r->contents, p, n + 1);
 
+  __post_gc();
+  
   return r->contents;
 }
 
 extern void* Bstringval (void *p) {
-  void *s;
+  void *s = BOX(NULL);
+
+  __pre_gc () ;
   
   createStringBuf ();
   printValue (p);
@@ -171,70 +193,98 @@ extern void* Bstringval (void *p) {
   
   deleteStringBuf ();
 
+  __post_gc ();
+
   return s;
 }
 
 extern void* Barray (int n, ...) {
-  va_list args;
+  va_list args = (va_list) BOX (NULL);
-  int i;
+  int     i    = BOX(0),
-  data *r = (data*) malloc (sizeof(int) * (n+1));
+          ai   = BOX(0);
+  data    *r   = (data*) BOX (NULL);
 
-  r->tag = ARRAY_TAG | n;
+  __pre_gc ();
+  
+#ifdef DEBUG_PRINT
+  printf ("Barray: create n = %d\n", n);
+  fflush(stdout);
+#endif
+  r = (data*) alloc (sizeof(int) * (n+1));
+
+  r->tag = ARRAY_TAG | (n << 3);
   
   va_start(args, n);
   
-  for (i=0; i<n; i++) {
+  for (i = 0; i<n; i++) {
-    int ai = va_arg(args, int);
+    ai = va_arg(args, int);
     ((int*)r->contents)[i] = ai; 
   }
   
   va_end(args);
 
+  __post_gc();
+
   return r->contents;
 }
 
 extern void* Bsexp (int n, ...) {
-  va_list args;
+  va_list args = (va_list) BOX (NULL);
-  int i;
+  int     i    = BOX(0);
-  sexp *r = (sexp*) malloc (sizeof(int) * (n+2));
+  int     ai   = BOX(0);
-  data *d = &(r->contents);
+  size_t * p   = NULL;
+  sexp   *r    = (sexp*) BOX (NULL);
+  data   *d    = (sexp*) BOX (NULL);
 
-  d->tag = SEXP_TAG | (n-1);
+  __pre_gc () ;
+  
+#ifdef DEBUG_PRINT
+  printf("Bsexp: allocate %zu!\n",sizeof(int) * (n+1));
+#endif
+  r = (sexp*) alloc (sizeof(int) * (n+1));
+  d = &(r->contents);
+  r->tag = 0;
+    
+  d->tag = SEXP_TAG | ((n-1) << 3);
   
   va_start(args, n);
   
   for (i=0; i<n-1; i++) {
-    int ai = va_arg(args, int);
+    ai = va_arg(args, int);
-    //printf ("arg %d = %x\n", i, ai);
+    
+    p = (size_t*) ai;
     ((int*)d->contents)[i] = ai;
   }
 
   r->tag = va_arg(args, int);
   va_end(args);
 
-  //printf ("tag %d\n", r->tag);
+  __post_gc();
-  //printf ("returning %p\n", d->contents);
 
   return d->contents;
 }
 
 extern int Btag (void *d, int t, int n) {
-  data *r = TO_DATA(d);
+  data *r = (data*) BOX (NULL);
+  r = TO_DATA(d);
   return BOX(TAG(r->tag) == SEXP_TAG && TO_SEXP(d)->tag == t && LEN(r->tag) == n);
 }
 
 extern int Barray_patt (void *d, int n) {
+  data *r = BOX(NULL);
   if (UNBOXED(d)) return BOX(0);
   else {
-    data *r = TO_DATA(d);
+    r = TO_DATA(d);
     return BOX(TAG(r->tag) == ARRAY_TAG && LEN(r->tag) == n);
   }
 }
 
 extern int Bstring_patt (void *x, void *y) {
+  data *rx = (data *) BOX (NULL),
+       *ry = (data *) BOX (NULL);
   if (UNBOXED(x)) return BOX(0);
   else {
-    data *rx = TO_DATA(x), *ry = TO_DATA(y);
+    rx = TO_DATA(x); ry = TO_DATA(y);
 
     if (TAG(rx->tag) != STRING_TAG) return BOX(0);
     
@@ -269,13 +319,13 @@ extern int Bsexp_tag_patt (void *x) {
 }
 
 extern void Bsta (int n, int v, void *s, ...) {
-  va_list args;
+  va_list args = (va_list) BOX (NULL);
-  int i, k;
+  int i = 0, k = 0;
-  data *a;
+  data *a = (data*) BOX (NULL);
   
   va_start(args, s);
 
-  for (i=0; i<n-1; i++) {
+  for (i = 0; i < n-1; i++) {
     k = UNBOX(va_arg(args, int));
     s = ((int**) s) [k];
   }
@@ -292,7 +342,7 @@ extern int Lraw (int x) {
 }
 
 extern void Lprintf (char *s, ...) {
-  va_list args;
+  va_list args = (va_list) BOX (NULL);
 
   va_start (args, s);
   vprintf  (s, args); // vprintf (char *, va_list) <-> printf (char *, ...) 
@@ -300,21 +350,29 @@ extern void Lprintf (char *s, ...) {
 }
 
 extern void* Lstrcat (void *a, void *b) {
-  data *da = TO_DATA(a);
+  data *da = (data*) BOX (NULL);
-  data *db = TO_DATA(b);
+  data *db = (data*) BOX (NULL);
+  data *d  = (data*) BOX (NULL);
 
-  data *d  = (data *) malloc (sizeof(int) + LEN(da->tag) + LEN(db->tag) + 1);
+  da = TO_DATA(a);
+  db = TO_DATA(b);
+
+  __pre_gc () ;
+  
+  d  = (data *) alloc (sizeof(int) + LEN(da->tag) + LEN(db->tag) + 1);
 
   d->tag = LEN(da->tag) + LEN(db->tag);
 
   strcpy (d->contents, da->contents);
   strcat (d->contents, db->contents);
 
+  __post_gc();
+  
   return d->contents;
 }
 
 extern void Lfprintf (FILE *f, char *s, ...) {
-  va_list args;
+  va_list args = (va_list) BOX (NULL);
 
   va_start (args, s);
   vfprintf (f, s, args);
@@ -331,7 +389,7 @@ extern void Lfclose (FILE *f) {
    
 /* Lread is an implementation of the "read" construct */
 extern int Lread () {
-  int result;
+  int result = BOX(0);
 
   printf ("> "); 
   fflush (stdout);
@@ -348,3 +406,290 @@ extern int Lwrite (int n) {
   return 0;
 }
 
+/* GC starts here */
+
+extern const size_t __gc_data_end, __gc_data_start;
+
+extern void L__gc_init ();
+extern void __pre_gc ();
+extern void __post_gc ();
+
+extern void __gc_root_scan_stack ();
+
+/* ======================================== */
+/*           Mark-and-copy                  */
+/* ======================================== */
+
+static size_t SPACE_SIZE = 128;
+# define POOL_SIZE (2*SPACE_SIZE)
+
+typedef struct {
+  size_t * begin;
+  size_t * end;
+  size_t * current;
+  size_t   size;
+} pool;
+
+static pool     from_space;
+static pool     to_space;
+size_t * current;
+
+static void swap (size_t ** a, size_t ** b) {
+  size_t * t = *a;
+  *a = *b;
+  *b = t;
+}
+
+static void gc_swap_spaces (void) {
+  swap (&from_space.begin, &to_space.begin);
+  swap (&from_space.end  , &to_space.end  );
+  from_space.current = current;
+  to_space.current   = to_space.begin;
+}
+
+# define IS_VALID_HEAP_POINTER(p)\
+  (!UNBOXED(p) &&		 \
+   from_space.begin <= p &&	 \
+   from_space.end   >  p)
+
+# define IN_PASSIVE_SPACE(p)	\
+  (to_space.begin <= p	&&	\
+   to_space.end   >  p)
+
+# define IS_FORWARD_PTR(p)			\
+  (!UNBOXED(p) && IN_PASSIVE_SPACE(p))
+
+extern size_t * gc_copy (size_t *obj);
+
+static void copy_elements (size_t *where, size_t *from, int len) {
+  int    i = 0;
+  void * p = NULL;
+  for (i = 0; i < len; i++) {
+    size_t elem = from[i];
+    if (!IS_VALID_HEAP_POINTER(elem)) {
+      *where = elem;
+      where++;
+    }
+    else {
+      p = gc_copy ((size_t*) elem);
+      *where = p;
+#ifdef DEBUG_PRINT
+      printf ("copy_elements: fix %x: %x\n", from, *where);
+#endif
+      where ++;
+    }
+  }
+}
+
+static void extend_spaces (void) {
+  void *p1 = mremap(from_space.begin, SPACE_SIZE, 2*SPACE_SIZE, 0);
+  void *p2 = mremap(to_space.begin  , SPACE_SIZE, 2*SPACE_SIZE, 0);
+  if (p1   == MAP_FAILED || p2 == MAP_FAILED) {
+    perror("EROOR: extend_spaces: mmap failed\n");
+    exit (1);
+  }
+#ifdef DEBUG_PRINT
+  printf ("extend: %x %x %x %x\n", p1, p2, from_space.begin, to_space.begin);
+  printf ("extend: %x %x %x\n", from_space.end, to_space.end, current);
+#endif
+  from_space.end  += SPACE_SIZE;
+  to_space.end    += SPACE_SIZE;
+  SPACE_SIZE      += SPACE_SIZE;
+  from_space.size =  SPACE_SIZE;
+  to_space.size   =  SPACE_SIZE;
+}
+
+extern size_t * gc_copy (size_t *obj) {
+  data   *d    = TO_DATA(obj);
+  sexp   *s    = NULL;
+  size_t *copy = NULL;
+  int     i    = 0;
+#ifdef DEBUG_PRINT
+  int len1, len2, len3;
+  void * objj;
+  void * newobjj = (void*)current;
+  printf("gc_copy: %x cur = %x starts\n", obj, current);
+#endif
+
+  if (!IS_VALID_HEAP_POINTER(obj)) {
+#ifdef DEBUG_PRINT
+    printf ("gc_copy: invalid ptr: %x\n", obj);
+#endif
+    return obj;
+  }
+
+  if (!IN_PASSIVE_SPACE(current) && current != to_space.end) {
+#ifdef DEBUG_PRINT
+    printf("ERROR: gc_copy: out-of-space %x %x %x\n", current, to_space.begin, to_space.end);
+    fflush(stdout);
+#endif
+    perror("ERROR: gc_copy: out-of-space\n");
+    exit (1);
+  }
+
+  if (IS_FORWARD_PTR(d->tag)) {
+#ifdef DEBUG_PRINT
+    printf ("gc_copy: IS_FORWARD_PTR: return! %x\n", (size_t *) d->tag);
+    fflush(stdout);
+#endif
+    return (size_t *) d->tag;
+  }
+
+  copy = current;
+#ifdef DEBUG_PRINT
+  objj = d;
+#endif
+  switch (TAG(d->tag)) {
+    case ARRAY_TAG:
+#ifdef DEBUG_PRINT
+      printf ("gc_copy:array_tag; len =  %zu\n", LEN(d->tag));
+      fflush(stdout);
+#endif
+      current += (LEN(d->tag) + 1) * sizeof (int);
+      *copy = d->tag;
+      copy++;
+      i = LEN(d->tag);
+      d->tag = (int) copy;
+      copy_elements (copy, obj, i);
+      break;
+
+    case STRING_TAG:
+#ifdef DEBUG_PRINT
+      printf ("gc_copy:string_tag; len = %d\n", LEN(d->tag) + 1);
+      fflush(stdout);
+#endif
+      current += LEN(d->tag) * sizeof(char) + sizeof (int);
+      *copy = d->tag;
+      copy++;
+      d->tag = (int) copy;
+      strcpy (&copy[0], (char*) obj);
+      break;
+
+  case SEXP_TAG  :
+      s = TO_SEXP(obj);
+#ifdef DEBUG_PRINT
+      objj = s;
+      len1 = LEN(s->contents.tag);
+      len2 = LEN(s->tag);
+      len3 = LEN(d->tag);
+      printf("len1 = %li, len2=%li, len3 = %li\n",len1,len2,len3);
+#endif
+      current += (LEN(s->contents.tag) + 2) * sizeof (int);
+      *copy = s->tag;
+      copy++;
+      *copy   = s->contents.tag;
+      copy++;
+      i = LEN(s->contents.tag);
+      d->tag = (int) copy;
+      copy_elements (copy, obj, i);
+      break;
+
+  default:
+#ifdef DEBUG_PRINT
+    printf ("ERROR: gc_copy: weird tag: %x", TAG(d->tag));
+    fflush(stdout);
+#endif
+    perror ("ERROR: gc_copy: weird tag");
+    exit (1);
+  }
+#ifdef DEBUG_PRINT
+  printf("gc_copy: %x (%x) -> %x (%x); new-current = %x\n", obj, objj, copy, newobjj, current);
+  fflush(stdout);
+#endif
+  return copy;
+}
+
+extern void gc_test_and_copy_root (size_t ** root) {
+  if (IS_VALID_HEAP_POINTER(*root)) {
+#ifdef DEBUG_PRINT
+    printf ("gc_test_and_copy_root: root %x %x\n", root, *root);
+#endif
+    *root = gc_copy (*root);
+  }
+}
+
+extern void gc_root_scan_data (void) {
+  size_t * p = &__gc_data_start;
+  while  (p != &__gc_data_end) {
+    gc_test_and_copy_root (p);
+    p++;
+  }
+}
+
+extern void init_pool (void) {
+  from_space.begin = mmap(NULL, SPACE_SIZE, PROT_READ | PROT_WRITE,
+			  MAP_PRIVATE | MAP_ANONYMOUS | MAP_32BIT, -1, 0);
+  to_space.begin   = mmap(NULL, SPACE_SIZE, PROT_READ | PROT_WRITE,
+			  MAP_PRIVATE | MAP_ANONYMOUS | MAP_32BIT, -1, 0);
+  if (to_space.begin   == MAP_FAILED ||
+      from_space.begin == MAP_FAILED) {
+    perror("EROOR: init_pool: mmap failed\n");
+    exit (1);
+  }
+  from_space.current = from_space.begin;
+  from_space.end     = from_space.begin + SPACE_SIZE;
+  from_space.size    = SPACE_SIZE;
+  to_space.current   = to_space.begin;
+  to_space.end       = to_space.begin + SPACE_SIZE;
+  to_space.size      = SPACE_SIZE;
+}
+
+static int free_pool (pool * p) {
+  return munmap((void *)p->begin, p->size);
+}
+
+static void * gc (size_t size) {
+  current = to_space.begin;
+#ifdef DEBUG_PRINT
+  printf("\ngc: current: %x; to_space.b = %x; to_space.e = %x; f_space.b = %x; f_space.e = %x\n",
+	 current, to_space.begin, to_space.end, from_space.begin, from_space.end);
+#endif
+  gc_root_scan_data  ();
+#ifdef DEBUG_PRINT
+  printf("gc: data is scanned\n");
+#endif
+  __gc_root_scan_stack ();
+  if (!IN_PASSIVE_SPACE(current)) {
+    perror ("ASSERT: !IN_PASSIVE_SPACE(current)\n");
+    exit (1);
+  }
+
+  while (current + size >= to_space.end) {
+#ifdef DEBUG_PRINT
+    printf ("gc pre-extend_spaces : %x %x %x \n", current, size, to_space.end);
+#endif
+    extend_spaces ();
+#ifdef DEBUG_PRINT
+    printf ("gc post-extend_spaces: %x %x %x \n", current, size, to_space.end);
+#endif
+  }
+  assert (IN_PASSIVE_SPACE(current));
+  assert (current + size < to_space.end);
+
+  gc_swap_spaces ();
+  from_space.current = current + size;
+#ifdef DEBUG_PRINT
+    printf ("gc: end: (allocate!) return %x; from_space.current %x; from_space.end \n\n",
+	    current, from_space.current, from_space.end);
+#endif
+  return (void *) current;
+}
+
+extern void * alloc (size_t size) {
+  void * p = (void*)BOX(NULL);
+  if (from_space.current + size < from_space.end) {
+#ifdef DEBUG_PRINT
+    printf("alloc: current: %x %zu", from_space.current, size);
+#endif
+    p = (void*) from_space.current;
+    from_space.current += size;
+#ifdef DEBUG_PRINT
+    printf(";new current: %x \n", from_space.current);
+#endif
+    return p;
+  }
+#ifdef DEBUG_PRINT
+  printf("alloc: call gc: %zu\n", size);
+#endif
+  return gc (size);
+}

runtime/testgc.expr

@@ -0,0 +1,9 @@
+fun print_list (l) {
+  case l of
+    `nil         -> skip
+  | `cons (n, t) -> write (n); print_list (t)
+  esac
+}
+
+x := `cons (4, `cons(3, `cons(2 , `cons (1, `cons (0, `cons (1, `cons (2, `cons (3, `cons (4, `cons (5, `nil))))))))));
+print_list (x)

src/X86.ml

@@ -19,6 +19,8 @@ let word_size = 4;;
 | L of int     (* an immediate operand             *)
 with show
 
+let show_opnd = show(opnd)
+              
 (* For convenience we define the following synonyms for the registers: *)         
 let ebx = R 0
 let ecx = R 1
@@ -52,6 +54,7 @@ type instr =
 (* arithmetic correction: or 0x0001                     *) | Or1   of opnd
 (* arithmetic correction: shl 1                         *) | Sal1  of opnd
 (* arithmetic correction: shr 1                         *) | Sar1  of opnd
+                                                           | Repmovsl 
                                                                                                                                    
 (* Instruction printer *)
 let show instr =
@@ -91,6 +94,7 @@ let show instr =
   | Or1    s           -> Printf.sprintf "\torl\t$0x0001,\t%s" (opnd s)
   | Sal1   s           -> Printf.sprintf "\tsall\t%s" (opnd s)
   | Sar1   s           -> Printf.sprintf "\tsarl\t%s" (opnd s)
+  | Repmovsl           -> Printf.sprintf "\trep movsl\t"
                                          
 (* Opening stack machine to use instructions without fully qualified names *)
 open SM
@@ -164,7 +168,7 @@ let compile env code =
              (env, Mov (M ("$" ^ s), l) :: call)
              
 	  | LD x ->
-             let s, env' = (env#global x)#allocate in
+             let s, env' = (env#variable x)#allocate in
              env',
 	     (match s with
 	      | S _ | M _ -> [Mov (env'#loc x, eax); Mov (eax, s)]
@@ -172,7 +176,7 @@ let compile env code =
 	     )
                
           | STA (x, n) ->
-             let s, env = (env#global x)#allocate in
+             let s, env = (env#variable x)#allocate in
              let push =
                match s with
                | S _ | M _ -> [Mov (env#loc x, eax); Mov (eax, s)]
@@ -182,7 +186,7 @@ let compile env code =
              env, push @ code
                            
 	  | ST x ->
-	     let s, env' = (env#global x)#pop in
+	     let s, env' = (env#variable x)#pop in
              env',
              (match s with
               | S _ | M _ -> [Mov (s, eax); Mov (eax, env'#loc x)]
@@ -288,14 +292,20 @@ let compile env code =
                      
           | BEGIN (f, a, l) ->
              let env = env#enter f a l in
-             env, [Push ebp; Mov (esp, ebp); Binop ("-", M ("$" ^ env#lsize), esp)]
+             env, [Push ebp; Mov (esp, ebp); Binop ("-", M ("$" ^ env#lsize), esp);
+                        Mov (esp, edi);
+	                Mov (M "$filler", esi);
+	                Mov (M ("$" ^ (env#allocated_size)), ecx);
+	                Repmovsl
+                  ]
                             
           | END ->             
-             env, [Label env#epilogue;
+             env#endfunc, [Label env#epilogue;
                    Mov (ebp, esp);
                    Pop ebp;
                    Ret;
-                   Meta (Printf.sprintf "\t.set\t%s,\t%d" env#lsize (env#allocated * word_size))
+                   Meta (Printf.sprintf "\t.set\t%s,\t%d" env#lsize (env#allocated * word_size));
+                   Meta (Printf.sprintf "\t.set\t%s,\t%d" env#allocated_size env#allocated)
                   ]
                     
           | RET b ->
@@ -386,6 +396,14 @@ class env =
     val fname       = ""      (* function name                     *)
     val stackmap    = M.empty (* labels to stack map               *)
     val barrier     = false   (* barrier condition                 *)
+    val max_locals_size = 0
+
+    method max_locals_size = max_locals_size
+      
+    method endfunc =
+      if stack_slots > max_locals_size
+      then {< max_locals_size = stack_slots >}
+      else self
                         
     method show_stack =
       GT.show(list) (GT.show(opnd)) stack
@@ -425,13 +443,13 @@ class env =
     (* allocates a fresh position on a symbolic stack *)
     method allocate =    
       let x, n =
-	let rec allocate' = function
+        let rec allocate' = function
-	| []                            -> ebx          , 0
+        | []                            -> ebx          , 0
-	| (S n)::_                      -> S (n+1)      , n+2
+        | (S n)::_                      -> S (n+1)      , n+2
-	| (R n)::_ when n < num_of_regs -> R (n+1)      , stack_slots
+        | (R n)::_ when n < num_of_regs -> R (n+1)      , stack_slots
-	| _                             -> S static_size, static_size+1
+        | _                             -> S static_size, static_size+1
-	in
+        in
-	allocate' stack
+        allocate' stack
       in
       x, {< stack_slots = max n stack_slots; stack = x::stack >}
 
@@ -458,8 +476,11 @@ class env =
       done;
       !h      
              
-    (* registers a global variable in the environment *)
+    (* registers a variable in the environment *)
-    method global x  = {< globals = S.add ("global_" ^ x) globals >}
+    method variable x =
+      match self#loc x with
+      | M name -> {< globals = S.add name globals >}
+      | _      -> self
 
     (* registers a string constant *)
     method string x =
@@ -478,6 +499,8 @@ class env =
     (* gets a number of stack positions allocated *)
     method allocated = stack_slots
 
+    method allocated_size = Printf.sprintf "LS%s_SIZE" fname
+                                
     (* enters a function *)
     method enter f a l =
       let n = List.length l in
@@ -515,14 +538,26 @@ class env =
    the stack code, then generates x86 assember code, then prints the assembler file
 *)
 let genasm (ds, stmt) =
-  let stmt = Language.Stmt.Seq (stmt, Language.Stmt.Return (Some (Language.Expr.Call ("raw", [Language.Expr.Const 0])))) in
+  let stmt =
+    Language.Stmt.Seq (
+        Language.Stmt.Call ("__gc_init", []),
+        Language.Stmt.Seq (stmt, Language.Stmt.Return (Some (Language.Expr.Call ("raw", [Language.Expr.Const 0]))))
+      )
+  in
   let env, code =
     compile
       (new env)
       ((LABEL "main") :: (BEGIN ("main", [], [])) :: SM.compile (ds, stmt))
   in
-  let data = Meta "\t.data" :: (List.map (fun s      -> Meta (Printf.sprintf "%s:\t.int\t0"         s  )) env#globals) @
+  let gc_start, gc_end = "__gc_data_start", "__gc_data_end" in
-                               (List.map (fun (s, v) -> Meta (Printf.sprintf "%s:\t.string\t\"%s\"" v s)) env#strings) in 
+  let data = [Meta "\t.data";
+              Meta (Printf.sprintf "filler:\t.fill\t%d, 4, 1" env#max_locals_size);
+              Meta (Printf.sprintf "\t.globl\t%s" gc_start); Meta (Printf.sprintf "\t.globl\t%s" gc_end)] @
+             [Meta (Printf.sprintf "%s:" gc_start)] @
+             (List.map (fun s      -> Meta (Printf.sprintf "%s:\t.int\t1"         s  )) env#globals) @
+             [Meta (Printf.sprintf "%s:" gc_end)] @
+             (List.map (fun (s, v) -> Meta (Printf.sprintf "%s:\t.string\t\"%s\"" v s)) env#strings)
+  in
   let asm = Buffer.create 1024 in
   List.iter
     (fun i -> Buffer.add_string asm (Printf.sprintf "%s\n" @@ show i))
@@ -535,5 +570,5 @@ let build prog name =
   Printf.fprintf outf "%s" (genasm prog);
   close_out outf;
   let inc = try Sys.getenv "RC_RUNTIME" with _ -> "../runtime" in
-  Sys.command (Printf.sprintf "gcc -m32 -o %s %s/runtime.o %s.s" name inc name)
+  Sys.command (Printf.sprintf "gcc -g -m32 -o %s %s/gc_runtime.o %s/runtime.o %s.s" name inc inc name)
  

src/testgc.expr

@@ -0,0 +1,22 @@
+fun f () local b {
+  b := 7;
+  test ();
+  b := y;
+  test ();
+  b := 9;
+  test ();
+  return 0
+}
+
+--x := 0;
+--y := 0;
+--z := 0;
+--t := 0;
+--test ();
+y := "abc";
+test ();
+t := [];
+test ();
+t := 0;
+test ();
+f ()