3009319 · Idris-dev · git.iko.soy

iif/testmap.iif+12−1

compare with master

unifiedsplit

@@ -13,7 +13,18 @@ fun dumpList(xs) = case xs of {

13 | Cons(y, ys) => %IntString(y) ++ ", " ++ dumpList(ys)

14 }

15

16+fun countFrom(x) = Cons(x, countFrom@(x+1))

17+

18+fun take(n, xs) = case n of {

19+ 0 => Nil

20+ | _ => case xs of {

21+ Nil => Nil

22+ | Cons(y, ys) => Cons(y, take(n-1, ys))

23+ }

24+ }

25+

16fun double(x) = x + x

26fun double(x) = x + x

17

27

18fun main() = let mult = 2 in

28fun main() = let mult = 2 in

19− %WriteString(dumpList(map(twice(\ x => x*mult), Cons(4, Cons(6, Nil)))))

29+ %WriteString(dumpList(map(twice(\ x => x*mult), take(1010, countFrom(10)))))

30+

rts/Makefile+2−2

@@ -1,5 +1,5 @@

1−OBJS = idris_rts.o

1+OBJS = idris_rts.o idris_gc.o

2−HDRS = idris_rts.h

2+HDRS = idris_rts.h idris_gc.h

3CFLAGS = -g

4

5LIBTARGET = libidris_rts.a

rts/idris_gc.cnew file+90

@@ -0,0 +1,90 @@

1+#include "idris_rts.h"

2+#include "idris_gc.h"

3+

4+VAL copy(VM* vm, VAL x) {

5+ int i;

6+ VAL* argptr;

7+ Closure* cl;

8+ if (x==NULL || ISINT(x)) {

9+ return x;

10+ }

11+ switch(x->ty) {

12+ case CON:

13+ cl = allocCon(vm, x->info.c.arity);

14+ cl->info.c.tag = x->info.c.tag;

15+ cl->info.c.arity = x->info.c.arity;

16+

17+ argptr = (VAL*)(cl->info.c.args);

18+ for(i = 0; i < x->info.c.arity; ++i) {

19+// *argptr = copy(vm, *((VAL*)(x->info.c.args)+i)); // recursive version

20+ *argptr = *((VAL*)(x->info.c.args)+i);

21+ argptr++;

22+ }

23+ break;

24+ case FLOAT:

25+ cl = MKFLOAT(vm, x->info.f);

26+ break;

27+ case STRING:

28+ cl = MKSTR(vm, x->info.str);

29+ break;

30+ case PTR:

31+ cl = MKPTR(vm, x->info.ptr);

32+ break;

33+ case FWD:

34+ cl = x->info.ptr;

35+ break;

36+ }

37+ x->ty = FWD;

38+ x->info.ptr = cl;

39+ return cl;

40+}

41+

42+void cheney(VM *vm) {

43+ VAL* argptr;

44+ int i;

45+ char* scan = vm->heap;

46+

47+ while(scan < vm->heap_next) {

48+ size_t inc = *((size_t*)scan);

49+ VAL heap_item = (VAL)(scan+sizeof(size_t)*2);

50+ // If it's a CON, copy its arguments

51+ switch(heap_item->ty) {

52+ case CON:

53+ argptr = (VAL*)(heap_item->info.c.args);

54+ for(i = 0; i < heap_item->info.c.arity; ++i) {

55+ *argptr = copy(vm, *argptr);

56+ argptr++;

57+ }

58+ break;

59+ }

60+ scan += inc;

61+ }

62+}

63+

64+void gc(VM* vm) {

65+ char* newheap = malloc(vm -> heap_size);

66+ char* oldheap = vm -> heap;

67+

68+ vm->heap = newheap;

69+ vm->heap_next = newheap;

70+ vm->heap_end = newheap + vm->heap_size;

71+

72+ vm->collections++;

73+

74+ VAL* root;

75+

76+ for(root = vm->valstack; root < vm->valstack_top; ++root) {

77+ *root = copy(vm, *root);

78+ }

79+ vm->ret = copy(vm, vm->ret);

80+ cheney(vm);

81+

82+ // After reallocation, if we've still more than half filled the new heap, grow the heap

83+ // for next time.

84+

85+ if ((vm->heap_next - vm->heap) > vm->heap_size >> 1) {

86+ vm->heap_size += vm->heap_growth;

87+ }

88+

89+ free(oldheap);

90+}

rts/idris_gc.hnew file+8

@@ -0,0 +1,8 @@

1+#ifndef _IDRISGC_H

2+#define _IDRISGC_H

3+

4+#include "idris_rts.h"

5+

6+void gc(VM* vm);

7+

8+#endif

rts/idris_main.c+5

@@ -4,5 +4,10 @@ int main(int argc, char* argv[]) {

4 _idris_main(vm, NULL);

5#ifdef IDRIS_DEBUG

6 printf("\nStack: %p %p\n", vm->valstack, vm->valstack_top);

7+ printf("GCs: %d\n", vm->collections);

8+ printf("Final heap size %d\n", (int)(vm->heap_size));

9+ printf("Final heap use %d\n", (int)(vm->heap_next - vm->heap));

10+ gc(vm);

11+ printf("Final heap use after GC %d\n", (int)(vm->heap_next - vm->heap));

7#endif

12#endif

8}

13}

rts/idris_rts.c+18−2

@@ -5,6 +5,7 @@

5#include <stdarg.h>

6

7#include "idris_rts.h"

8+#include "idris_gc.h"

8

9

9VM* init_vm(int stack_size, size_t heap_size) {

10VM* init_vm(int stack_size, size_t heap_size) {

10 VAL* valstack = malloc(stack_size*sizeof(VAL));

11 VAL* valstack = malloc(stack_size*sizeof(VAL));

@@ -22,12 +23,27 @@ VM* init_vm(int stack_size, size_t heap_size) {

22 vm -> stack_max = stack_size;

23 vm -> stack_max = stack_size;

23 vm -> heap = malloc(heap_size);

24 vm -> heap = malloc(heap_size);

24 vm -> heap_next = vm -> heap;

25 vm -> heap_next = vm -> heap;

26+ vm -> heap_end = vm -> heap + heap_size;

27+ vm -> heap_size = heap_size;

28+ vm -> collections = 0;

29+ vm -> heap_growth = heap_size;

25 vm -> ret = NULL;

30 vm -> ret = NULL;

26 return vm;

31 return vm;

27}

32}

28

33

29−void* allocate(VM* vm, int size) {

34+void* allocate(VM* vm, size_t size) {

35+ if ((size & 7)!=0) {

36+ size = 8 + ((size >> 3) << 3);

37+ }

38+ if (vm -> heap_next + size < vm -> heap_end) {

39+ void* ptr = (void*)(((size_t*)(vm->heap_next))+2);

40+ *((size_t*)(vm->heap_next)) = size+sizeof(size_t)*2;

41+ vm -> heap_next += size+sizeof(size_t)*2;

30− return malloc(size); // TMP!

42+ return ptr;

43+ } else {

44+ gc(vm);

45+ return allocate(vm, size);

46+ }

31}

47}

32

48

33void* allocCon(VM* vm, int arity) {

49void* allocCon(VM* vm, int arity) {

rts/idris_rts.h+9−3

@@ -10,7 +10,7 @@

10// Closures

11

12typedef enum {

13− CON, INT, FLOAT, STRING, UNIT, PTR

13+ CON, INT, FLOAT, STRING, UNIT, PTR, FWD

14} ClosureType;

15

16typedef struct {

@@ -40,9 +40,13 @@ typedef struct {

40 VAL* valstack_base;

41 int* intstack_ptr;

42 double* floatstack_ptr;

43− void* heap;

43+ char* heap;

44− void* heap_next;

44+ char* heap_next;

45+ char* heap_end;

45 int stack_max;

46 int stack_max;

47+ size_t heap_size;

48+ size_t heap_growth;

49+ int collections;

46 VAL ret;

50 VAL ret;

47} VM;

51} VM;

48

52

@@ -103,6 +107,7 @@ VAL MKCON(VM* vm, int tag, int arity, ...);

103void PROJECT(VM* vm, VAL r, int loc, int arity);

107void PROJECT(VM* vm, VAL r, int loc, int arity);

104void SLIDE(VM* vm, int args);

108void SLIDE(VM* vm, int args);

105

109

110+void* allocCon(VM* vm, int arity);

106void dumpVal(VAL r);

111void dumpVal(VAL r);

107

112

108// Casts

113// Casts

@@ -128,4 +133,5 @@ VAL idris_readStr(VM* vm, FILE* h);

128

133

129void stackOverflow();

134void stackOverflow();

130

135

136+

131#endif

137#endif

src/IRTS/LParser.hs+1−1

@@ -52,7 +52,7 @@ fovm f = do defs <- parseFOVM f

52 let defuns = defunctionalise nexttag ctxtIn

53-- print defuns

54 let checked = checkDefs defuns (toAlist defuns)

55− print checked

55+-- print checked

56 case checked of

57 OK c -> codegenC c "a.out" True ["math.h"] "" TRACE

58 Error e -> fail $ show e