mirror of
https://github.com/justinethier/cyclone.git
synced 2025-05-23 20:15:05 +02:00
Fixes to get new runtime to build
This commit is contained in:
Justin Ethier
parent
60d343ee2c
commit
92e25a8640
3 changed files with 485 additions and 444 deletions
3
Makefile
3
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
|
||||
|
|
|
|||
479
runtime.c
479
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 (scanp<allocp) /* Scan the newspace. */
|
||||
switch (type_of(scanp))
|
||||
{case cons_tag:
|
||||
#if DEBUG_GC
|
||||
printf("DEBUG transport cons_tag\n");
|
||||
#endif
|
||||
transp(car(scanp)); transp(cdr(scanp));
|
||||
scanp += sizeof(cons_type); break;
|
||||
case closure0_tag:
|
||||
#if DEBUG_GC
|
||||
printf("DEBUG transport closure0 \n");
|
||||
#endif
|
||||
scanp += sizeof(closure0_type); break;
|
||||
case closure1_tag:
|
||||
#if DEBUG_GC
|
||||
printf("DEBUG transport closure1 \n");
|
||||
#endif
|
||||
transp(((closure1) scanp)->elt1);
|
||||
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. */
|
||||
}
|
||||
|
||||
|
||||
/**
|
||||
|
|
|
|||
447
runtime.h
447
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 (scanp<allocp) /* Scan the newspace. */
|
||||
switch (type_of(scanp))
|
||||
{case cons_tag:
|
||||
#if DEBUG_GC
|
||||
printf("DEBUG transport cons_tag\n");
|
||||
#endif
|
||||
transp(car(scanp)); transp(cdr(scanp));
|
||||
scanp += sizeof(cons_type); break;
|
||||
case closure0_tag:
|
||||
#if DEBUG_GC
|
||||
printf("DEBUG transport closure0 \n");
|
||||
#endif
|
||||
scanp += sizeof(closure0_type); break;
|
||||
case closure1_tag:
|
||||
#if DEBUG_GC
|
||||
printf("DEBUG transport closure1 \n");
|
||||
#endif
|
||||
transp(((closure1) scanp)->elt1);
|
||||
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 */
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue