diff --git a/Makefile b/Makefile index ba871a28..f5f428de 100644 --- a/Makefile +++ b/Makefile @@ -45,7 +45,8 @@ test2: examples/hello-library/int-test/hello.c libcyclone.a # ./cyclone -t examples/hello-library/hello.scm # ./cyclone -t examples/hello-library/libs/lib2.sld # gcc examples/hello-library/int-test/lib2.c -I. -g -c -o lib2.o - gcc examples/hello-library/int-test/hello.c -L. -lcyclone -lm -I. -g -o hello +# gcc examples/hello-library/int-test/hello.c -L. -lcyclone -lm -I. -g -o hello + gcc examples/hello-library/hello.c -L. -lcyclone -lm -I. -g -o hello icyc: cyclone icyc.scm eval.scm parser.scm runtime.h ./cyclone icyc.scm diff --git a/runtime.c b/runtime.c index f7f8cba3..7cd00154 100644 --- a/runtime.c +++ b/runtime.c @@ -1,6 +1,26 @@ #include "cyclone.h" #include "runtime.h" +/* Funcall section, these are hardcoded here to support + functions in this module. */ +#define funcall1(cfn,a1) if (type_of(cfn) == cons_tag || prim(cfn)) { Cyc_apply(0, (closure)a1, cfn); } else { ((cfn)->fn)(1,cfn,a1);} +/* Return to continuation after checking for stack overflow. */ +#define return_funcall1(cfn,a1) \ +{char stack; \ + if (check_overflow(&stack,stack_limit1)) { \ + object buf[1]; buf[0] = a1;\ + GC(cfn,buf,1); return; \ + } else {funcall1((closure) (cfn),a1); return;}} +#define funcall2(cfn,a1,a2) if (type_of(cfn) == cons_tag || prim(cfn)) { Cyc_apply(1, (closure)a1, cfn,a2); } else { ((cfn)->fn)(2,cfn,a1,a2);} +/* Return to continuation after checking for stack overflow. */ +#define return_funcall2(cfn,a1,a2) \ +{char stack; \ + if (check_overflow(&stack,stack_limit1)) { \ + object buf[2]; buf[0] = a1;buf[1] = a2;\ + GC(cfn,buf,2); return; \ + } else {funcall2((closure) (cfn),a1,a2); return;}} +/*END funcall section */ + /* Global variables. */ clock_t start; /* Starting time. */ char *stack_begin; /* Initialized by main. */ @@ -90,6 +110,17 @@ object find_or_add_symbol(const char *name){ } /* END symbol table */ +/* Global table */ +list global_table = nil; + +void add_global(object *glo) { + // It would probably be more efficient to allocate + // a contiguous block of memory for this... for now + // this is more expedient + global_table = mcons(mcvar(glo), global_table); +} +/* END Global table */ + /* Mutation table * * Keep track of mutations (EG: set-car!) so that new @@ -813,6 +844,18 @@ object Cyc_io_peek_char(object port) { return Cyc_EOF; } +/* This heap cons is used only for initialization. */ +list mcons(a,d) object a,d; +{register cons_type *c = malloc(sizeof(cons_type)); + c->tag = cons_tag; c->cons_car = a; c->cons_cdr = d; + return c;} + +cvar_type *mcvar(object *var) { + cvar_type *c = malloc(sizeof(cvar_type)); + c->tag = cvar_tag; + c->pvar = var; + return c;} + void _Cyc_91global_91vars(object cont, object args){ return_funcall1(cont, Cyc_global_variables); } void _car(object cont, object args) { @@ -1028,7 +1071,443 @@ void _write(object cont, object args) { void _display(object cont, object args) { return_funcall1(cont, Cyc_display(car(args)));} +// JAE TODO: need to refactor cyc_eval out of here, +// and use #define's to mask global (IE, use another +// runtime global and have the __glo_ expand into it +#ifdef CYC_EVAL +static void _call_95cc(object cont, object args){ + return_funcall2(__glo_call_95cc, cont, car(args)); +} +defprimitive(call_95cc, call/cc, &_call_95cc); // Moved up here due to ifdef +#endif /* CYC_EVAL */ +/* + * @param cont - Continuation for the function to call into + * @param func - Function to execute + * @param args - A list of arguments to the function + */ +object apply(object cont, object func, object args){ + common_type buf; + +//printf("DEBUG apply: "); +//Cyc_display(args); +//printf("\n"); + if (!is_object_type(func)) { + printf("Call of non-procedure: "); + Cyc_display(func); + exit(1); + } + + switch(type_of(func)) { + case primitive_tag: + // TODO: should probably check arg counts and error out if needed + ((primitive_type *)func)->fn(cont, args); + break; + case closure0_tag: + case closure1_tag: + case closure2_tag: + case closure3_tag: + case closure4_tag: + case closureN_tag: + buf.integer_t = Cyc_length(args); + dispatch(buf.integer_t.value, ((closure)func)->fn, func, cont, args); + break; + +#ifdef CYC_EVAL + case cons_tag: + { + make_cons(c, func, args); + + if (!nullp(func) && eq(quote_Cyc_191procedure, car(func))) { + ((closure)__glo_eval)->fn(3, __glo_eval, cont, &c, nil); + } else { + printf("Unable to evaluate: "); + Cyc_display(&c); + printf("\n"); + exit(1); + } + } +#endif /* CYC_EVAL */ + + default: + printf("Invalid object type %ld\n", type_of(func)); + exit(1); + } + return nil; // Never reached +} + +// Version of apply meant to be called from within compiled code +void Cyc_apply(int argc, closure cont, object prim, ...){ + va_list ap; + object tmp; + int i; + list args = alloca(sizeof(cons_type) * argc); + + va_start(ap, prim); + + for (i = 0; i < argc; i++) { + tmp = va_arg(ap, object); + args[i].tag = cons_tag; + args[i].cons_car = tmp; + args[i].cons_cdr = (i == (argc-1)) ? nil : &args[i + 1]; + } + //printf("DEBUG applying primitive to "); + //Cyc_display((object)&args[0]); + //printf("\n"); + + va_end(ap); + apply(cont, prim, (object)&args[0]); +} +// END apply + +/* Extract args from given array, assuming cont is the first arg in buf */ +void Cyc_apply_from_buf(int argc, object prim, object *buf) { + list args; + object cont; + int i; + + if (argc == 0) { + printf("Internal error in Cyc_apply_from_buf, argc is 0\n"); + exit(1); + } + + args = alloca(sizeof(cons_type) * (argc - 1)); + cont = buf[0]; + + for (i = 1; i < argc; i++) { + args[i - 1].tag = cons_tag; + args[i - 1].cons_car = buf[i]; + args[i - 1].cons_cdr = (i == (argc-1)) ? nil : &args[i]; + } + + apply(cont, prim, (object)&args[0]); +} + +char *transport(x, gcgen) char *x; int gcgen; +/* Transport one object. WARNING: x cannot be nil!!! */ +{ + if (nullp(x)) return x; + if (obj_is_char(x)) return x; +#if DEBUG_GC + printf("entered transport "); + printf("transport %ld\n", type_of(x)); +#endif + switch (type_of(x)) + {case cons_tag: + {register list nx = (list) allocp; + type_of(nx) = cons_tag; car(nx) = car(x); cdr(nx) = cdr(x); + forward(x) = nx; type_of(x) = forward_tag; + allocp = ((char *) nx)+sizeof(cons_type); + return (char *) nx;} + case closure0_tag: + {register closure0 nx = (closure0) allocp; + type_of(nx) = closure0_tag; nx->fn = ((closure0) x)->fn; + forward(x) = nx; type_of(x) = forward_tag; + allocp = ((char *) nx)+sizeof(closure0_type); + return (char *) nx;} + case closure1_tag: + {register closure1 nx = (closure1) allocp; + type_of(nx) = closure1_tag; nx->fn = ((closure1) x)->fn; + nx->elt1 = ((closure1) x)->elt1; + forward(x) = nx; type_of(x) = forward_tag; + x = (char *) nx; allocp = ((char *) nx)+sizeof(closure1_type); + return (char *) nx;} + case closure2_tag: + {register closure2 nx = (closure2) allocp; + type_of(nx) = closure2_tag; nx->fn = ((closure2) x)->fn; + nx->elt1 = ((closure2) x)->elt1; + nx->elt2 = ((closure2) x)->elt2; + forward(x) = nx; type_of(x) = forward_tag; + x = (char *) nx; allocp = ((char *) nx)+sizeof(closure2_type); + return (char *) nx;} + case closure3_tag: + {register closure3 nx = (closure3) allocp; + type_of(nx) = closure3_tag; nx->fn = ((closure3) x)->fn; + nx->elt1 = ((closure3) x)->elt1; + nx->elt2 = ((closure3) x)->elt2; + nx->elt3 = ((closure3) x)->elt3; + forward(x) = nx; type_of(x) = forward_tag; + x = (char *) nx; allocp = ((char *) nx)+sizeof(closure3_type); + return (char *) nx;} + case closure4_tag: + {register closure4 nx = (closure4) allocp; + type_of(nx) = closure4_tag; nx->fn = ((closure4) x)->fn; + nx->elt1 = ((closure4) x)->elt1; + nx->elt2 = ((closure4) x)->elt2; + nx->elt3 = ((closure4) x)->elt3; + nx->elt4 = ((closure4) x)->elt4; + forward(x) = nx; type_of(x) = forward_tag; + x = (char *) nx; allocp = ((char *) nx)+sizeof(closure4_type); + return (char *) nx;} + case closureN_tag: + {register closureN nx = (closureN) allocp; + int i; + type_of(nx) = closureN_tag; nx->fn = ((closureN) x)->fn; + nx->num_elt = ((closureN) x)->num_elt; + nx->elts = (object *)(((char *)nx) + sizeof(closureN_type)); + for (i = 0; i < nx->num_elt; i++) { + nx->elts[i] = ((closureN) x)->elts[i]; + } + forward(x) = nx; type_of(x) = forward_tag; + x = (char *) nx; allocp = ((char *) nx)+sizeof(closureN_type) + sizeof(object) * nx->num_elt; + return (char *) nx;} + case string_tag: + {register string_type *nx = (string_type *) allocp; + type_of(nx) = string_tag; + if (gcgen == 0) { + // Minor, data heap is not relocated + nx->str = ((string_type *)x)->str; + } else { + // Major collection, data heap is moving + nx->str = dhallocp; + int len = strlen(((string_type *) x)->str); + memcpy(dhallocp, ((string_type *) x)->str, len + 1); + dhallocp += len + 1; + } + forward(x) = nx; type_of(x) = forward_tag; + x = (char *) nx; allocp = ((char *) nx)+sizeof(integer_type); + return (char *) nx;} + case integer_tag: + {register integer_type *nx = (integer_type *) allocp; + type_of(nx) = integer_tag; nx->value = ((integer_type *) x)->value; + forward(x) = nx; type_of(x) = forward_tag; + x = (char *) nx; allocp = ((char *) nx)+sizeof(integer_type); + return (char *) nx;} + case double_tag: + {register double_type *nx = (double_type *) allocp; + type_of(nx) = double_tag; nx->value = ((double_type *) x)->value; + forward(x) = nx; type_of(x) = forward_tag; + x = (char *) nx; allocp = ((char *) nx)+sizeof(double_type); + return (char *) nx;} + case port_tag: + {register port_type *nx = (port_type *) allocp; + type_of(nx) = port_tag; nx->fp = ((port_type *) x)->fp; + nx->mode = ((port_type *) x)->mode; + forward(x) = nx; type_of(x) = forward_tag; + x = (char *) nx; allocp = ((char *) nx)+sizeof(port_type); + return (char *) nx;} + case cvar_tag: + {register cvar_type *nx = (cvar_type *) allocp; + type_of(nx) = cvar_tag; nx->pvar = ((cvar_type *) x)->pvar; + forward(x) = nx; type_of(x) = forward_tag; + x = (char *) nx; allocp = ((char *) nx)+sizeof(cvar_type); + return (char *) nx;} + case forward_tag: + return (char *) forward(x); + case eof_tag: break; + case primitive_tag: break; + case boolean_tag: break; + case symbol_tag: break; // JAE TODO: raise an error here? Should not be possible in real code, though (IE, without GC DEBUG flag) + default: + printf("transport: bad tag x=%p x.tag=%ld\n",(void *)x,type_of(x)); exit(0);} + return x;} + +/* Use overflow macro which already knows which way the stack goes. */ +/* Major collection, transport objects on stack or old heap */ +#define transp(p) \ +temp = (p); \ +if ((check_overflow(low_limit,temp) && \ + check_overflow(temp,high_limit)) || \ + (check_overflow(old_heap_low_limit - 1, temp) && \ + check_overflow(temp,old_heap_high_limit + 1))) \ + (p) = (object) transport(temp,major); + +void GC_loop(int major, closure cont, object *ans, int num_ans) +{char foo; + int i; + register object temp; + register object low_limit = &foo; /* Move live data above us. */ + register object high_limit = stack_begin; + register char *scanp = allocp; /* Cheney scan pointer. */ + register object old_heap_low_limit = low_limit; // Minor-GC default + register object old_heap_high_limit = high_limit; // Minor-GC default + + char *tmp_bottom = bottom; /* Bottom of tospace. */ + char *tmp_allocp = allocp; /* Cheney allocate pointer. */ + char *tmp_alloc_end = alloc_end; + char *tmp_dhbottom = dhbottom; + char *tmp_dhallocp = dhallocp; + char *tmp_dhallocp_end = dhalloc_end; + if (major) { + // Initialize new heap (TODO: make a function for this) + bottom = calloc(1,global_heap_size); + allocp = (char *) ((((long) bottom)+7) & -8); + alloc_end = allocp + global_heap_size - 8; + scanp = allocp; + old_heap_low_limit = tmp_bottom; + old_heap_high_limit = tmp_alloc_end; + + dhallocp = dhbottom = calloc(1, global_heap_size); + dhalloc_end = dhallocp + global_heap_size - 8; + } + +#if DEBUG_GC + printf("\n=== started GC type = %d === \n", major); +#endif + /* Transport GC's continuation and its argument. */ + transp(cont); + gc_cont = cont; + gc_num_ans = num_ans; +#if DEBUG_GC + printf("DEBUG done transporting cont\n"); +#endif + + /* Prevent overrunning buffer */ + if (num_ans > NUM_GC_ANS) { + printf("Fatal error - too many arguments (%d) to GC\n", num_ans); + exit(1); + } + + for (i = 0; i < num_ans; i++){ + transp(ans[i]); + gc_ans[i] = ans[i]; + } +#if DEBUG_GC + printf("DEBUG done transporting gc_ans\n"); +#endif + + /* Transport mutations. */ + { + list l; + for (l = mutation_table; !nullp(l); l = cdr(l)) { + object o = car(l); + if (type_of(o) == cons_tag) { + // Transport, if necessary + // TODO: need to test this with major GC, and + // GC's of list/car-cdr from same generation + transp(car(o)); + transp(cdr(o)); + } else if (type_of(o) == forward_tag) { + // Already transported, skip + } else { + printf("Unexpected type %ld transporting mutation\n", type_of(o)); + exit(1); + } + } + } + clear_mutations(); /* Reset for next time */ + + /* Transport global variables. */ + transp(Cyc_global_variables); /* Internal global used by the runtime */ + { //JAE TODO: GC_GLOBALS + list l = global_table; + for(; !nullp(l); l = cdr(l)){ + cvar_type *c = (cvar_type *)car(l); + transp((c->pvar)); // TODO: proper syntax here? + } + } + while (scanpelt1); + scanp += sizeof(closure1_type); break; + case closure2_tag: +#if DEBUG_GC + printf("DEBUG transport closure2 \n"); +#endif + transp(((closure2) scanp)->elt1); transp(((closure2) scanp)->elt2); + scanp += sizeof(closure2_type); break; + case closure3_tag: +#if DEBUG_GC + printf("DEBUG transport closure3 \n"); +#endif + transp(((closure3) scanp)->elt1); transp(((closure3) scanp)->elt2); + transp(((closure3) scanp)->elt3); + scanp += sizeof(closure3_type); break; + case closure4_tag: +#if DEBUG_GC + printf("DEBUG transport closure4 \n"); +#endif + transp(((closure4) scanp)->elt1); transp(((closure4) scanp)->elt2); + transp(((closure4) scanp)->elt3); transp(((closure4) scanp)->elt4); + scanp += sizeof(closure4_type); break; + case closureN_tag: +#if DEBUG_GC + printf("DEBUG transport closureN \n"); +#endif + {int i; int n = ((closureN) scanp)->num_elt; + for (i = 0; i < n; i++) { + transp(((closureN) scanp)->elts[i]); + } + scanp += sizeof(closureN_type) + sizeof(object) * n; + } + break; + case string_tag: +#if DEBUG_GC + printf("DEBUG transport string \n"); +#endif + scanp += sizeof(string_type); break; + case integer_tag: +#if DEBUG_GC + printf("DEBUG transport integer \n"); +#endif + scanp += sizeof(integer_type); break; + case double_tag: +#if DEBUG_GC + printf("DEBUG transport double \n"); +#endif + scanp += sizeof(double_type); break; + case port_tag: +#if DEBUG_GC + printf("DEBUG transport port \n"); +#endif + scanp += sizeof(port_type); break; + case cvar_tag: +#if DEBUG_GC + printf("DEBUG transport cvar \n"); +#endif + scanp += sizeof(cvar_type); break; + case eof_tag: + case primitive_tag: + case symbol_tag: + case boolean_tag: + default: + printf("GC: bad tag scanp=%p scanp.tag=%ld\n",(void *)scanp,type_of(scanp)); + exit(0);} + + if (major) { + free(tmp_bottom); + free(tmp_dhbottom); + } +} + +void GC(cont,ans,num_ans) closure cont; object *ans; int num_ans; +{ + /* Only room for one more minor-GC, so do a major one. + * Not sure this is the best strategy, it may be better to do major + * ones sooner, perhaps after every x minor GC's. + * + * Also may need to consider dynamically increasing heap size, but + * by how much (1.3x, 1.5x, etc) and when? I suppose when heap usage + * after a collection is above a certain percentage, then it would be + * necessary to increase heap size the next time. + */ + if (allocp >= (bottom + (global_heap_size - global_stack_size))) { + //printf("Possibly only room for one more minor GC. no_gcs = %ld\n", no_gcs); + no_major_gcs++; + GC_loop(1, cont, ans, num_ans); + } else { + no_gcs++; /* Count the number of minor GC's. */ + GC_loop(0, cont, ans, num_ans); + } + + /* You have to let it all go, Neo. Fear, doubt, and disbelief. Free your mind... */ + longjmp(jmp_main,1); /* Return globals gc_cont, gc_ans. */ +} /** diff --git a/runtime.h b/runtime.h index 5f1c9c5c..7b31ef5b 100644 --- a/runtime.h +++ b/runtime.h @@ -9,8 +9,6 @@ #ifndef CYCLONE_RUNTIME_H #define CYCLONE_RUNTIME_H -#include "cyclone.h" - extern long global_stack_size; extern long global_heap_size; extern const object Cyc_EOF; @@ -67,6 +65,7 @@ void dispatch_string_91append(int argc, object clo, object cont, object str1, .. string_type Cyc_string_append(int argc, object str1, ...); string_type Cyc_string_append_va_list(int, object, va_list); list mcons(object,object); +cvar_type *mcvar(object *var); object terpri(void); object Cyc_display(object); object Cyc_write(object); @@ -137,6 +136,9 @@ object find_symbol_by_name(const char *name); object find_or_add_symbol(const char *name); extern list symbol_table; +extern list global_table; +void add_global(object *glo); + void add_mutation(object var, object value); void clear_mutations(); extern list mutation_table; @@ -182,17 +184,6 @@ extern const object boolean_t; extern const object boolean_f; extern const object quote_Cyc_191procedure; -// JAE TODO: will probably need to refactor this, since modules (libs) -// can have globals, too -JAE TODO: DECLARE_GLOBALS - -#ifdef CYC_EVAL -static void _call_95cc(object cont, object args){ - return_funcall2(__glo_call_95cc, cont, car(args)); -} -defprimitive(call_95cc, call/cc, &_call_95cc); // Moved up here due to ifdef -#endif /* CYC_EVAL */ - /* This section is auto-generated via --autogen */ extern const object primitive_Cyc_91global_91vars; extern const object primitive_Cyc_91get_91cvar; @@ -304,434 +295,4 @@ void Cyc_rt_raise(object err); void Cyc_rt_raise_msg(const char *err); /* END exception handler */ -/* - * - * @param cont - Continuation for the function to call into - * @param func - Function to execute - * @param args - A list of arguments to the function - */ -object apply(object cont, object func, object args){ - common_type buf; - -//printf("DEBUG apply: "); -//Cyc_display(args); -//printf("\n"); - if (!is_object_type(func)) { - printf("Call of non-procedure: "); - Cyc_display(func); - exit(1); - } - - switch(type_of(func)) { - case primitive_tag: - // TODO: should probably check arg counts and error out if needed - ((primitive_type *)func)->fn(cont, args); - break; - case closure0_tag: - case closure1_tag: - case closure2_tag: - case closure3_tag: - case closure4_tag: - case closureN_tag: - buf.integer_t = Cyc_length(args); - dispatch(buf.integer_t.value, ((closure)func)->fn, func, cont, args); - break; - -#ifdef CYC_EVAL - case cons_tag: - { - make_cons(c, func, args); - - if (!nullp(func) && eq(quote_Cyc_191procedure, car(func))) { - ((closure)__glo_eval)->fn(3, __glo_eval, cont, &c, nil); - } else { - printf("Unable to evaluate: "); - Cyc_display(&c); - printf("\n"); - exit(1); - } - } -#endif /* CYC_EVAL */ - - default: - printf("Invalid object type %ld\n", type_of(func)); - exit(1); - } - return nil; // Never reached -} - -// Version of apply meant to be called from within compiled code -void Cyc_apply(int argc, closure cont, object prim, ...){ - va_list ap; - object tmp; - int i; - list args = alloca(sizeof(cons_type) * argc); - - va_start(ap, prim); - - for (i = 0; i < argc; i++) { - tmp = va_arg(ap, object); - args[i].tag = cons_tag; - args[i].cons_car = tmp; - args[i].cons_cdr = (i == (argc-1)) ? nil : &args[i + 1]; - } - //printf("DEBUG applying primitive to "); - //Cyc_display((object)&args[0]); - //printf("\n"); - - va_end(ap); - apply(cont, prim, (object)&args[0]); -} -// END apply - -/* Extract args from given array, assuming cont is the first arg in buf */ -void Cyc_apply_from_buf(int argc, object prim, object *buf) { - list args; - object cont; - int i; - - if (argc == 0) { - printf("Internal error in Cyc_apply_from_buf, argc is 0\n"); - exit(1); - } - - args = alloca(sizeof(cons_type) * (argc - 1)); - cont = buf[0]; - - for (i = 1; i < argc; i++) { - args[i - 1].tag = cons_tag; - args[i - 1].cons_car = buf[i]; - args[i - 1].cons_cdr = (i == (argc-1)) ? nil : &args[i]; - } - - apply(cont, prim, (object)&args[0]); -} - -char *transport(x, gcgen) char *x; int gcgen; -/* Transport one object. WARNING: x cannot be nil!!! */ -{ - if (nullp(x)) return x; - if (obj_is_char(x)) return x; -#if DEBUG_GC - printf("entered transport "); - printf("transport %ld\n", type_of(x)); -#endif - switch (type_of(x)) - {case cons_tag: - {register list nx = (list) allocp; - type_of(nx) = cons_tag; car(nx) = car(x); cdr(nx) = cdr(x); - forward(x) = nx; type_of(x) = forward_tag; - allocp = ((char *) nx)+sizeof(cons_type); - return (char *) nx;} - case closure0_tag: - {register closure0 nx = (closure0) allocp; - type_of(nx) = closure0_tag; nx->fn = ((closure0) x)->fn; - forward(x) = nx; type_of(x) = forward_tag; - allocp = ((char *) nx)+sizeof(closure0_type); - return (char *) nx;} - case closure1_tag: - {register closure1 nx = (closure1) allocp; - type_of(nx) = closure1_tag; nx->fn = ((closure1) x)->fn; - nx->elt1 = ((closure1) x)->elt1; - forward(x) = nx; type_of(x) = forward_tag; - x = (char *) nx; allocp = ((char *) nx)+sizeof(closure1_type); - return (char *) nx;} - case closure2_tag: - {register closure2 nx = (closure2) allocp; - type_of(nx) = closure2_tag; nx->fn = ((closure2) x)->fn; - nx->elt1 = ((closure2) x)->elt1; - nx->elt2 = ((closure2) x)->elt2; - forward(x) = nx; type_of(x) = forward_tag; - x = (char *) nx; allocp = ((char *) nx)+sizeof(closure2_type); - return (char *) nx;} - case closure3_tag: - {register closure3 nx = (closure3) allocp; - type_of(nx) = closure3_tag; nx->fn = ((closure3) x)->fn; - nx->elt1 = ((closure3) x)->elt1; - nx->elt2 = ((closure3) x)->elt2; - nx->elt3 = ((closure3) x)->elt3; - forward(x) = nx; type_of(x) = forward_tag; - x = (char *) nx; allocp = ((char *) nx)+sizeof(closure3_type); - return (char *) nx;} - case closure4_tag: - {register closure4 nx = (closure4) allocp; - type_of(nx) = closure4_tag; nx->fn = ((closure4) x)->fn; - nx->elt1 = ((closure4) x)->elt1; - nx->elt2 = ((closure4) x)->elt2; - nx->elt3 = ((closure4) x)->elt3; - nx->elt4 = ((closure4) x)->elt4; - forward(x) = nx; type_of(x) = forward_tag; - x = (char *) nx; allocp = ((char *) nx)+sizeof(closure4_type); - return (char *) nx;} - case closureN_tag: - {register closureN nx = (closureN) allocp; - int i; - type_of(nx) = closureN_tag; nx->fn = ((closureN) x)->fn; - nx->num_elt = ((closureN) x)->num_elt; - nx->elts = (object *)(((char *)nx) + sizeof(closureN_type)); - for (i = 0; i < nx->num_elt; i++) { - nx->elts[i] = ((closureN) x)->elts[i]; - } - forward(x) = nx; type_of(x) = forward_tag; - x = (char *) nx; allocp = ((char *) nx)+sizeof(closureN_type) + sizeof(object) * nx->num_elt; - return (char *) nx;} - case string_tag: - {register string_type *nx = (string_type *) allocp; - type_of(nx) = string_tag; - if (gcgen == 0) { - // Minor, data heap is not relocated - nx->str = ((string_type *)x)->str; - } else { - // Major collection, data heap is moving - nx->str = dhallocp; - int len = strlen(((string_type *) x)->str); - memcpy(dhallocp, ((string_type *) x)->str, len + 1); - dhallocp += len + 1; - } - forward(x) = nx; type_of(x) = forward_tag; - x = (char *) nx; allocp = ((char *) nx)+sizeof(integer_type); - return (char *) nx;} - case integer_tag: - {register integer_type *nx = (integer_type *) allocp; - type_of(nx) = integer_tag; nx->value = ((integer_type *) x)->value; - forward(x) = nx; type_of(x) = forward_tag; - x = (char *) nx; allocp = ((char *) nx)+sizeof(integer_type); - return (char *) nx;} - case double_tag: - {register double_type *nx = (double_type *) allocp; - type_of(nx) = double_tag; nx->value = ((double_type *) x)->value; - forward(x) = nx; type_of(x) = forward_tag; - x = (char *) nx; allocp = ((char *) nx)+sizeof(double_type); - return (char *) nx;} - case port_tag: - {register port_type *nx = (port_type *) allocp; - type_of(nx) = port_tag; nx->fp = ((port_type *) x)->fp; - nx->mode = ((port_type *) x)->mode; - forward(x) = nx; type_of(x) = forward_tag; - x = (char *) nx; allocp = ((char *) nx)+sizeof(port_type); - return (char *) nx;} - case cvar_tag: - {register cvar_type *nx = (cvar_type *) allocp; - type_of(nx) = cvar_tag; nx->pvar = ((cvar_type *) x)->pvar; - forward(x) = nx; type_of(x) = forward_tag; - x = (char *) nx; allocp = ((char *) nx)+sizeof(cvar_type); - return (char *) nx;} - case forward_tag: - return (char *) forward(x); - case eof_tag: break; - case primitive_tag: break; - case boolean_tag: break; - case symbol_tag: break; // JAE TODO: raise an error here? Should not be possible in real code, though (IE, without GC DEBUG flag) - default: - printf("transport: bad tag x=%p x.tag=%ld\n",(void *)x,type_of(x)); exit(0);} - return x;} - -/* Use overflow macro which already knows which way the stack goes. */ -/* Major collection, transport objects on stack or old heap */ -#define transp(p) \ -temp = (p); \ -if ((check_overflow(low_limit,temp) && \ - check_overflow(temp,high_limit)) || \ - (check_overflow(old_heap_low_limit - 1, temp) && \ - check_overflow(temp,old_heap_high_limit + 1))) \ - (p) = (object) transport(temp,major); - -void GC_loop(int major, closure cont, object *ans, int num_ans) -{char foo; - int i; - register object temp; - register object low_limit = &foo; /* Move live data above us. */ - register object high_limit = stack_begin; - register char *scanp = allocp; /* Cheney scan pointer. */ - register object old_heap_low_limit = low_limit; // Minor-GC default - register object old_heap_high_limit = high_limit; // Minor-GC default - - char *tmp_bottom = bottom; /* Bottom of tospace. */ - char *tmp_allocp = allocp; /* Cheney allocate pointer. */ - char *tmp_alloc_end = alloc_end; - char *tmp_dhbottom = dhbottom; - char *tmp_dhallocp = dhallocp; - char *tmp_dhallocp_end = dhalloc_end; - if (major) { - // Initialize new heap (TODO: make a function for this) - bottom = calloc(1,global_heap_size); - allocp = (char *) ((((long) bottom)+7) & -8); - alloc_end = allocp + global_heap_size - 8; - scanp = allocp; - old_heap_low_limit = tmp_bottom; - old_heap_high_limit = tmp_alloc_end; - - dhallocp = dhbottom = calloc(1, global_heap_size); - dhalloc_end = dhallocp + global_heap_size - 8; - } - -#if DEBUG_GC - printf("\n=== started GC type = %d === \n", major); -#endif - /* Transport GC's continuation and its argument. */ - transp(cont); - gc_cont = cont; - gc_num_ans = num_ans; -#if DEBUG_GC - printf("DEBUG done transporting cont\n"); -#endif - - /* Prevent overrunning buffer */ - if (num_ans > NUM_GC_ANS) { - printf("Fatal error - too many arguments (%d) to GC\n", num_ans); - exit(1); - } - - for (i = 0; i < num_ans; i++){ - transp(ans[i]); - gc_ans[i] = ans[i]; - } -#if DEBUG_GC - printf("DEBUG done transporting gc_ans\n"); -#endif - - /* Transport mutations. */ - { - list l; - for (l = mutation_table; !nullp(l); l = cdr(l)) { - object o = car(l); - if (type_of(o) == cons_tag) { - // Transport, if necessary - // TODO: need to test this with major GC, and - // GC's of list/car-cdr from same generation - transp(car(o)); - transp(cdr(o)); - } else if (type_of(o) == forward_tag) { - // Already transported, skip - } else { - printf("Unexpected type %ld transporting mutation\n", type_of(o)); - exit(1); - } - } - } - clear_mutations(); /* Reset for next time */ - - /* Transport global variables. */ - transp(Cyc_global_variables); /* Internal global used by the runtime */ - JAE TODO: GC_GLOBALS - while (scanpelt1); - scanp += sizeof(closure1_type); break; - case closure2_tag: -#if DEBUG_GC - printf("DEBUG transport closure2 \n"); -#endif - transp(((closure2) scanp)->elt1); transp(((closure2) scanp)->elt2); - scanp += sizeof(closure2_type); break; - case closure3_tag: -#if DEBUG_GC - printf("DEBUG transport closure3 \n"); -#endif - transp(((closure3) scanp)->elt1); transp(((closure3) scanp)->elt2); - transp(((closure3) scanp)->elt3); - scanp += sizeof(closure3_type); break; - case closure4_tag: -#if DEBUG_GC - printf("DEBUG transport closure4 \n"); -#endif - transp(((closure4) scanp)->elt1); transp(((closure4) scanp)->elt2); - transp(((closure4) scanp)->elt3); transp(((closure4) scanp)->elt4); - scanp += sizeof(closure4_type); break; - case closureN_tag: -#if DEBUG_GC - printf("DEBUG transport closureN \n"); -#endif - {int i; int n = ((closureN) scanp)->num_elt; - for (i = 0; i < n; i++) { - transp(((closureN) scanp)->elts[i]); - } - scanp += sizeof(closureN_type) + sizeof(object) * n; - } - break; - case string_tag: -#if DEBUG_GC - printf("DEBUG transport string \n"); -#endif - scanp += sizeof(string_type); break; - case integer_tag: -#if DEBUG_GC - printf("DEBUG transport integer \n"); -#endif - scanp += sizeof(integer_type); break; - case double_tag: -#if DEBUG_GC - printf("DEBUG transport double \n"); -#endif - scanp += sizeof(double_type); break; - case port_tag: -#if DEBUG_GC - printf("DEBUG transport port \n"); -#endif - scanp += sizeof(port_type); break; - case cvar_tag: -#if DEBUG_GC - printf("DEBUG transport cvar \n"); -#endif - scanp += sizeof(cvar_type); break; - case eof_tag: - case primitive_tag: - case symbol_tag: - case boolean_tag: - default: - printf("GC: bad tag scanp=%p scanp.tag=%ld\n",(void *)scanp,type_of(scanp)); - exit(0);} - - if (major) { - free(tmp_bottom); - free(tmp_dhbottom); - } -} - -void GC(cont,ans,num_ans) closure cont; object *ans; int num_ans; -{ - /* Only room for one more minor-GC, so do a major one. - * Not sure this is the best strategy, it may be better to do major - * ones sooner, perhaps after every x minor GC's. - * - * Also may need to consider dynamically increasing heap size, but - * by how much (1.3x, 1.5x, etc) and when? I suppose when heap usage - * after a collection is above a certain percentage, then it would be - * necessary to increase heap size the next time. - */ - if (allocp >= (bottom + (global_heap_size - global_stack_size))) { - //printf("Possibly only room for one more minor GC. no_gcs = %ld\n", no_gcs); - no_major_gcs++; - GC_loop(1, cont, ans, num_ans); - } else { - no_gcs++; /* Count the number of minor GC's. */ - GC_loop(0, cont, ans, num_ans); - } - - /* You have to let it all go, Neo. Fear, doubt, and disbelief. Free your mind... */ - longjmp(jmp_main,1); /* Return globals gc_cont, gc_ans. */ -} - -/* This heap cons is used only for initialization. */ -list mcons(a,d) object a,d; -{register cons_type *c = malloc(sizeof(cons_type)); - c->tag = cons_tag; c->cons_car = a; c->cons_cdr = d; - return c;} - - #endif /* CYCLONE_RUNTIME_H */