Permalink
Browse files

Added a simple copying GC

  • Loading branch information...
1 parent 29ba32e commit 30093190194fbae48e75feb8548041d2a52fd6de Edwin Brady committed Sep 5, 2012
Showing with 145 additions and 9 deletions.
  1. +12 −1 iif/testmap.iif
  2. +2 −2 rts/Makefile
  3. +90 −0 rts/idris_gc.c
  4. +8 −0 rts/idris_gc.h
  5. +5 −0 rts/idris_main.c
  6. +18 −2 rts/idris_rts.c
  7. +9 −3 rts/idris_rts.h
  8. +1 −1 src/IRTS/LParser.hs
View
@@ -13,7 +13,18 @@ fun dumpList(xs) = case xs of {
| Cons(y, ys) => %IntString(y) ++ ", " ++ dumpList(ys)
}
+fun countFrom(x) = Cons(x, countFrom@(x+1))
+
+fun take(n, xs) = case n of {
+ 0 => Nil
+ | _ => case xs of {
+ Nil => Nil
+ | Cons(y, ys) => Cons(y, take(n-1, ys))
+ }
+ }
+
fun double(x) = x + x
fun main() = let mult = 2 in
- %WriteString(dumpList(map(twice(\ x => x*mult), Cons(4, Cons(6, Nil)))))
+ %WriteString(dumpList(map(twice(\ x => x*mult), take(1010, countFrom(10)))))
+
View
@@ -1,5 +1,5 @@
-OBJS = idris_rts.o
-HDRS = idris_rts.h
+OBJS = idris_rts.o idris_gc.o
+HDRS = idris_rts.h idris_gc.h
CFLAGS = -g
LIBTARGET = libidris_rts.a
View
@@ -0,0 +1,90 @@
+#include "idris_rts.h"
+#include "idris_gc.h"
+
+VAL copy(VM* vm, VAL x) {
+ int i;
+ VAL* argptr;
+ Closure* cl;
+ if (x==NULL || ISINT(x)) {
+ return x;
+ }
+ switch(x->ty) {
+ case CON:
+ cl = allocCon(vm, x->info.c.arity);
+ cl->info.c.tag = x->info.c.tag;
+ cl->info.c.arity = x->info.c.arity;
+
+ argptr = (VAL*)(cl->info.c.args);
+ for(i = 0; i < x->info.c.arity; ++i) {
+// *argptr = copy(vm, *((VAL*)(x->info.c.args)+i)); // recursive version
+ *argptr = *((VAL*)(x->info.c.args)+i);
+ argptr++;
+ }
+ break;
+ case FLOAT:
+ cl = MKFLOAT(vm, x->info.f);
+ break;
+ case STRING:
+ cl = MKSTR(vm, x->info.str);
+ break;
+ case PTR:
+ cl = MKPTR(vm, x->info.ptr);
+ break;
+ case FWD:
+ cl = x->info.ptr;
+ break;
+ }
+ x->ty = FWD;
+ x->info.ptr = cl;
+ return cl;
+}
+
+void cheney(VM *vm) {
+ VAL* argptr;
+ int i;
+ char* scan = vm->heap;
+
+ while(scan < vm->heap_next) {
+ size_t inc = *((size_t*)scan);
+ VAL heap_item = (VAL)(scan+sizeof(size_t)*2);
+ // If it's a CON, copy its arguments
+ switch(heap_item->ty) {
+ case CON:
+ argptr = (VAL*)(heap_item->info.c.args);
+ for(i = 0; i < heap_item->info.c.arity; ++i) {
+ *argptr = copy(vm, *argptr);
+ argptr++;
+ }
+ break;
+ }
+ scan += inc;
+ }
+}
+
+void gc(VM* vm) {
+ char* newheap = malloc(vm -> heap_size);
+ char* oldheap = vm -> heap;
+
+ vm->heap = newheap;
+ vm->heap_next = newheap;
+ vm->heap_end = newheap + vm->heap_size;
+
+ vm->collections++;
+
+ VAL* root;
+
+ for(root = vm->valstack; root < vm->valstack_top; ++root) {
+ *root = copy(vm, *root);
+ }
+ vm->ret = copy(vm, vm->ret);
+ cheney(vm);
+
+ // After reallocation, if we've still more than half filled the new heap, grow the heap
+ // for next time.
+
+ if ((vm->heap_next - vm->heap) > vm->heap_size >> 1) {
+ vm->heap_size += vm->heap_growth;
+ }
+
+ free(oldheap);
+}
View
@@ -0,0 +1,8 @@
+#ifndef _IDRISGC_H
+#define _IDRISGC_H
+
+#include "idris_rts.h"
+
+void gc(VM* vm);
+
+#endif
View
@@ -4,5 +4,10 @@ int main(int argc, char* argv[]) {
_idris_main(vm, NULL);
#ifdef IDRIS_DEBUG
printf("\nStack: %p %p\n", vm->valstack, vm->valstack_top);
+ printf("GCs: %d\n", vm->collections);
+ printf("Final heap size %d\n", (int)(vm->heap_size));
+ printf("Final heap use %d\n", (int)(vm->heap_next - vm->heap));
+ gc(vm);
+ printf("Final heap use after GC %d\n", (int)(vm->heap_next - vm->heap));
#endif
}
View
@@ -5,6 +5,7 @@
#include <stdarg.h>
#include "idris_rts.h"
+#include "idris_gc.h"
VM* init_vm(int stack_size, size_t heap_size) {
VAL* valstack = malloc(stack_size*sizeof(VAL));
@@ -22,12 +23,27 @@ VM* init_vm(int stack_size, size_t heap_size) {
vm -> stack_max = stack_size;
vm -> heap = malloc(heap_size);
vm -> heap_next = vm -> heap;
+ vm -> heap_end = vm -> heap + heap_size;
+ vm -> heap_size = heap_size;
+ vm -> collections = 0;
+ vm -> heap_growth = heap_size;
vm -> ret = NULL;
return vm;
}
-void* allocate(VM* vm, int size) {
- return malloc(size); // TMP!
+void* allocate(VM* vm, size_t size) {
+ if ((size & 7)!=0) {
+ size = 8 + ((size >> 3) << 3);
+ }
+ if (vm -> heap_next + size < vm -> heap_end) {
+ void* ptr = (void*)(((size_t*)(vm->heap_next))+2);
+ *((size_t*)(vm->heap_next)) = size+sizeof(size_t)*2;
+ vm -> heap_next += size+sizeof(size_t)*2;
+ return ptr;
+ } else {
+ gc(vm);
+ return allocate(vm, size);
+ }
}
void* allocCon(VM* vm, int arity) {
View
@@ -10,7 +10,7 @@
// Closures
typedef enum {
- CON, INT, FLOAT, STRING, UNIT, PTR
+ CON, INT, FLOAT, STRING, UNIT, PTR, FWD
} ClosureType;
typedef struct {
@@ -40,9 +40,13 @@ typedef struct {
VAL* valstack_base;
int* intstack_ptr;
double* floatstack_ptr;
- void* heap;
- void* heap_next;
+ char* heap;
+ char* heap_next;
+ char* heap_end;
int stack_max;
+ size_t heap_size;
+ size_t heap_growth;
+ int collections;
VAL ret;
} VM;
@@ -103,6 +107,7 @@ VAL MKCON(VM* vm, int tag, int arity, ...);
void PROJECT(VM* vm, VAL r, int loc, int arity);
void SLIDE(VM* vm, int args);
+void* allocCon(VM* vm, int arity);
void dumpVal(VAL r);
// Casts
@@ -128,4 +133,5 @@ VAL idris_readStr(VM* vm, FILE* h);
void stackOverflow();
+
#endif
View
@@ -52,7 +52,7 @@ fovm f = do defs <- parseFOVM f
let defuns = defunctionalise nexttag ctxtIn
-- print defuns
let checked = checkDefs defuns (toAlist defuns)
- print checked
+-- print checked
case checked of
OK c -> codegenC c "a.out" True ["math.h"] "" TRACE
Error e -> fail $ show e

0 comments on commit 3009319

Please sign in to comment.