#include "closure.h" #include #include #include #include #include VAL one; void dumpCon(con* c) { printf("%d", c->tag); } void dumpClosure(Closure* c) { switch(GETTY(c)) { case FUN: printf("FUN["); break; case THUNK: printf("THUNK["); break; case CON: printf("CON["); dumpCon((con*)c->info); break; case INT: printf("INT[%d", ((int)c)>>1); break; case BIGINT: printf("BIGINT["); break; case FLOAT: printf("FLOAT["); break; case BIGFLOAT: printf("BIGFLOAT["); break; case STRING: printf("STRING["); break; case UNIT: printf("UNIT["); break; case PTR: printf("PTR["); break; case FREEVAR: printf("FREEVAR["); break; default: printf("[%d,%d", GETTY(c), (int)c->info); } printf("]\n"); } inline VAL CLOSURE(func x, int arity, int args, void** block) { VAL c = EMALLOC(sizeof(Closure)+sizeof(fun)); // MKCLOSURE; fun* fn = (fun*)(c+1); fn->fn = x; fn->arity = arity; if (args==0) { fn->args = 0; fn->arg_end = 0; } else { fn->args = MKARGS(args); fn->arg_end=fn->args+args; memcpy((void*)(fn->args), (void*)block, args*sizeof(VAL)); } SETTY(c, FUN); c->info = (void*)fn; return c; } inline VAL CONSTRUCTOR(int tag, int arity, void** block) { VAL c = EMALLOC(sizeof(Closure)+sizeof(con)); // MKCLOSURE; con* cn = (con*)(c+1); cn->tag = tag; if (arity==0) { cn->args = 0; } else { cn->args = MKARGS(arity); memcpy((void*)(cn->args), (void*)block, arity*sizeof(VAL)); } SETTY(c, CON); c->info = (void*)cn; return c; } inline VAL CONSTRUCTOR1(int tag, VAL a1) { VAL c = EMALLOC(sizeof(Closure)+sizeof(con)); // MKCLOSURE; con* cn = (con*)(c+1); cn->tag = tag; cn->args = MKARGS(1); cn->args[0] = a1; SETTY(c,CON); c->info = (void*)cn; return c; } inline VAL CONSTRUCTOR2(int tag, VAL a1, VAL a2) { VAL c = EMALLOC(sizeof(Closure)+sizeof(con)); // MKCLOSURE; con* cn = (con*)(c+1); cn->tag = tag; cn->args = MKARGS(2); cn->args[0] = a1; cn->args[1] = a2; SETTY(c,CON); c->info = (void*)cn; return c; } inline VAL CONSTRUCTOR3(int tag, VAL a1, VAL a2, VAL a3) { VAL c = EMALLOC(sizeof(Closure)+sizeof(con)); // MKCLOSURE; con* cn = (con*)(c+1); cn->tag = tag; cn->args = MKARGS(3); cn->args[0] = a1; cn->args[1] = a2; cn->args[2] = a3; SETTY(c,CON); c->info = (void*)cn; return c; } inline VAL CONSTRUCTOR4(int tag, VAL a1, VAL a2, VAL a3, VAL a4) { VAL c = EMALLOC(sizeof(Closure)+sizeof(con)); // MKCLOSURE; con* cn = (con*)(c+1); cn->tag = tag; cn->args = MKARGS(2); cn->args[0] = a1; cn->args[1] = a2; cn->args[2] = a3; cn->args[3] = a4; SETTY(c,CON); c->info = (void*)cn; return c; } inline VAL CONSTRUCTOR5(int tag, VAL a1, VAL a2, VAL a3, VAL a4, VAL a5) { VAL c = EMALLOC(sizeof(Closure)+sizeof(con)); // MKCLOSURE; con* cn = (con*)(c+1); cn->tag = tag; cn->args = MKARGS(5); cn->args[0] = a1; cn->args[1] = a2; cn->args[2] = a3; cn->args[3] = a4; cn->args[4] = a5; SETTY(c,CON); c->info = (void*)cn; return c; } // This needs to make a copy inline VAL CLOSURE_ADDN(VAL xin, int args, void** block) { assert(GETTY(xin) == FUN); fun* finf = (fun*)xin->info; VAL x = CLOSURE(finf->fn, finf->arity, finf->arg_end-finf->args, finf->args); fun* fn = (fun*)(x->info); int diff = fn->arg_end - fn->args; fn->args = MOREARGS(fn->args, args + diff); fn->arg_end = fn->args + diff; memcpy((void*)(fn->arg_end), (void*)block, args*sizeof(VAL)); fn->arg_end += args; return x; } /* VAL CLOSURE_ADDN(VAL xin, int args, void** block) { switch(args) { case 1: return CLOSURE_ADD1(xin,block[0]); case 2: return CLOSURE_ADD2(xin,block[0],block[1]); case 3: return CLOSURE_ADD3(xin,block[0],block[1],block[2]); case 4: return CLOSURE_ADD4(xin,block[0],block[1],block[2],block[3]); case 5: return CLOSURE_ADD5(xin,block[0],block[1],block[2],block[3],block[4]); default: return aux_CLOSURE_ADDN(xin,args,block); } } */ inline VAL CLOSURE_ADD1(VAL xin, VAL a1) { assert(GETTY(xin)==FUN); fun* finf = (fun*)xin->info; VAL x = CLOSURE(finf->fn, finf->arity, finf->arg_end-finf->args, finf->args); fun* fn = (fun*)(x->info); int diff = fn->arg_end - fn->args; fn->args = MOREARGS(fn->args, diff + 1); fn->arg_end = fn->args + diff; fn->arg_end[0] = a1; fn->arg_end+=1; return x; } inline VAL CLOSURE_ADD2(VAL xin, VAL a1, VAL a2) { assert(GETTY(xin)==FUN); fun* finf = (fun*)xin->info; VAL x = CLOSURE(finf->fn, finf->arity, finf->arg_end-finf->args, finf->args); fun* fn = (fun*)(x->info); int diff = fn->arg_end - fn->args; fn->args = MOREARGS(fn->args, diff + 2); fn->arg_end = fn->args + diff; fn->arg_end[0] = a1; fn->arg_end[1] = a2; fn->arg_end+=2; return x; } inline VAL CLOSURE_ADD3(VAL xin, VAL a1, VAL a2, VAL a3) { assert(GETTY(xin)==FUN); fun* finf = (fun*)xin->info; VAL x = CLOSURE(finf->fn, finf->arity, finf->arg_end-finf->args, finf->args); fun* fn = (fun*)(x->info); int diff = fn->arg_end - fn->args; fn->args = MOREARGS(fn->args, diff + 3); fn->arg_end = fn->args + diff; fn->arg_end[0] = a1; fn->arg_end[1] = a2; fn->arg_end[2] = a3; fn->arg_end+=3; return x; } inline VAL CLOSURE_ADD4(VAL xin, VAL a1, VAL a2, VAL a3, VAL a4) { assert(GETTY(xin)==FUN); fun* finf = (fun*)xin->info; VAL x = CLOSURE(finf->fn, finf->arity, finf->arg_end-finf->args, finf->args); fun* fn = (fun*)(x->info); int diff = fn->arg_end - fn->args; fn->args = MOREARGS(fn->args, diff + 4); fn->arg_end = fn->args + diff; fn->arg_end[0] = a1; fn->arg_end[1] = a2; fn->arg_end[2] = a3; fn->arg_end[3] = a4; fn->arg_end+=4; return x; } inline VAL CLOSURE_ADD5(VAL xin, VAL a1, VAL a2, VAL a3, VAL a4, VAL a5) { assert(GETTY(xin)==FUN); fun* finf = (fun*)xin->info; VAL x = CLOSURE(finf->fn, finf->arity, finf->arg_end-finf->args, finf->args); fun* fn = (fun*)(x->info); int diff = fn->arg_end - fn->args; fn->args = MOREARGS(fn->args, diff + 5); fn->arg_end = fn->args + diff; fn->arg_end[0] = a1; fn->arg_end[1] = a2; fn->arg_end[2] = a3; fn->arg_end[3] = a4; fn->arg_end[4] = a5; fn->arg_end+=2; return x; } inline VAL CLOSURE_APPLY(VAL f, int args, void** block) { VAL c = EMALLOC(sizeof(Closure)+sizeof(thunk)); // MKCLOSURE; thunk* fn = (thunk*)(c+1); if (ISFUN(f)) { return CLOSURE_ADDN(f,args,block); } fn->fn = (void*)f; fn->numargs = args; if (args==0) { fn->args = 0; } else { fn->args = MKARGS(args); memcpy((void*)(fn->args), (void*)block, args*sizeof(VAL)); } SETTY(c,THUNK); c->info = (void*)fn; return c; } inline VAL aux_CLOSURE_APPLY1(VAL f, VAL a1) { VAL c = EMALLOC(sizeof(Closure)+sizeof(thunk)); // MKCLOSURE; thunk* fn = (thunk*)(c+1); if (ISFUN(f)) { return CLOSURE_ADD1(f,a1); } fn->fn = (void*)f; fn->numargs = 1; fn->args = MKARGS(1); fn->args[0] = a1; SETTY(c,THUNK); c->info = (void*)fn; return c; } inline VAL aux_CLOSURE_APPLY2(VAL f, VAL a1, VAL a2) { VAL c = EMALLOC(sizeof(Closure)+sizeof(thunk)); // MKCLOSURE; thunk* fn = (thunk*)(c+1); if (ISFUN(f)) { return CLOSURE_ADD2(f,a1,a2); } fn->fn = (void*)f; fn->numargs = 2; fn->args = MKARGS(2); fn->args[0] = a1; fn->args[1] = a2; SETTY(c,THUNK); c->info = (void*)fn; return c; } inline VAL aux_CLOSURE_APPLY3(VAL f, VAL a1, VAL a2, VAL a3) { VAL c = EMALLOC(sizeof(Closure)+sizeof(thunk)); // MKCLOSURE; thunk* fn = (thunk*)(c+1); if (ISFUN(f)) { return CLOSURE_ADD3(f,a1,a2,a3); } fn->fn = (void*)f; fn->numargs = 2; fn->args = MKARGS(3); fn->args[0] = a1; fn->args[1] = a2; fn->args[2] = a3; SETTY(c,THUNK); c->info = (void*)fn; return c; } inline VAL aux_CLOSURE_APPLY4(VAL f, VAL a1, VAL a2, VAL a3, VAL a4) { VAL c = EMALLOC(sizeof(Closure)+sizeof(thunk)); // MKCLOSURE; thunk* fn = (thunk*)(c+1); if (ISFUN(f)) { return CLOSURE_ADD4(f,a1,a2,a3,a4); } fn->fn = (void*)f; fn->numargs = 2; fn->args = MKARGS(4); fn->args[0] = a1; fn->args[1] = a2; fn->args[2] = a3; fn->args[3] = a4; SETTY(c,THUNK); c->info = (void*)fn; return c; } inline VAL aux_CLOSURE_APPLY5(VAL f, VAL a1, VAL a2, VAL a3, VAL a4, VAL a5) { VAL c = EMALLOC(sizeof(Closure)+sizeof(thunk)); // MKCLOSURE; thunk* fn = (thunk*)(c+1); if (ISFUN(f)) { return CLOSURE_ADD5(f,a1,a2,a3,a4,a5); } fn->fn = (void*)f; fn->numargs = 2; fn->args = MKARGS(5); fn->args[0] = a1; fn->args[1] = a2; fn->args[2] = a3; fn->args[3] = a4; fn->args[4] = a5; SETTY(c,THUNK); c->info = (void*)fn; return c; } inline VAL CLOSURE_APPLY1(VAL f, VAL a1) { if (ISFUN(f)) { fun* finf = (fun*)(f->info); int got = finf->arg_end-finf->args; if (finf->arity == (got+1)) { void* block[got+1]; memcpy(block, finf->args, got*sizeof(VAL)); block[got] = a1; return (VAL)(finf->fn(block)); } else return CLOSURE_ADD1(f,a1); } else return aux_CLOSURE_APPLY1(f,a1); } inline VAL CLOSURE_APPLY2(VAL f, VAL a1, VAL a2) { if (ISFUN(f)) { fun* finf = (fun*)(f->info); int got = finf->arg_end-finf->args; if (finf->arity == (got+2)) { void* block[got+2]; memcpy(block, finf->args, got*sizeof(VAL)); block[got] = a1; block[got+1] = a2; return (VAL)(finf->fn(block)); } else return CLOSURE_ADD2(f,a1,a2); } else return aux_CLOSURE_APPLY2(f,a1,a2); } inline VAL CLOSURE_APPLY3(VAL f, VAL a1, VAL a2, VAL a3) { if (ISFUN(f)) { fun* finf = (fun*)(f->info); int got = finf->arg_end-finf->args; if (finf->arity == (got+3)) { void* block[got+3]; memcpy(block, finf->args, got*sizeof(VAL)); block[got] = a1; block[got+1] = a2; block[got+2] = a3; return (VAL)(finf->fn(block)); } else return CLOSURE_ADD3(f,a1,a2,a3); } else return aux_CLOSURE_APPLY3(f,a1,a2,a3); } inline VAL CLOSURE_APPLY4(VAL f, VAL a1, VAL a2, VAL a3, VAL a4) { if (ISFUN(f)) { fun* finf = (fun*)(f->info); int got = finf->arg_end-finf->args; if (finf->arity == (got+4)) { void* block[got+4]; memcpy(block, finf->args, got*sizeof(VAL)); block[got] = a1; block[got+1] = a2; block[got+2] = a3; block[got+3] = a4; return (VAL)(finf->fn(block)); } else return CLOSURE_ADD4(f,a1,a2,a3,a4); } else return aux_CLOSURE_APPLY4(f,a1,a2,a3,a4); } inline VAL CLOSURE_APPLY5(VAL f, VAL a1, VAL a2, VAL a3, VAL a4, VAL a5) { if (ISFUN(f)) { fun* finf = (fun*)(f->info); int got = finf->arg_end-finf->args; if (finf->arity == (got+5)) { void* block[got+5]; memcpy(block, finf->args, got*sizeof(VAL)); block[got] = a1; block[got+1] = a2; block[got+2] = a3; block[got+3] = a4; block[got+4] = a5; return (VAL)(finf->fn(block)); } else return CLOSURE_ADD5(f,a1,a2,a3,a4,a5); } else return aux_CLOSURE_APPLY5(f,a1,a2,a3,a4,a5); } VAL DO_EVAL(VAL x) { // dummy value we'll never inspect, leave it alone. if (x==NULL) return x; VAL result; // VAL x = (VAL)(*xin); fun* fn; thunk* th; int excess; // dumpClosure(x); switch(GETTY(x)) { case CON: case INT: case FLOAT: case STRING: case PTR: case UNIT: return x; // Already evaluated case FUN: // If the number of arguments is right, run it. fn = (fun*)(x->info); excess = (fn->arg_end - fn->args) - fn->arity; if (excess == 0) { result = fn->fn(fn->args); // If the result is still a function, better eval again to make // more progress. // It could reasonably be null though, so be careful. It's null // if it was a foreign/io call in particular. if (result) { if (GETTY(result)==FUN || GETTY(result)==THUNK) { result=DO_EVAL(result); } /* if (ISINT(result)) { printf("Updating with %d\n", x); } else { printf("Updating %d %d with %d\n", x, GETTY(x), result); }*/ UPDATE(x,result); } else { SETTY(x, INT); x->info=(void*)42; } } // If there are too many arguments, run it with the right number // then apply the remaining arguments to the resulting closure else if (excess > 0) { result = fn->fn(fn->args); result = CLOSURE_APPLY(result, excess, fn->args + fn->arity); result = DO_EVAL(result); UPDATE(x,result); return x; } break; case THUNK: th = (thunk*)(x->info); // Evaluate inner thunk, which should give us a function th->fn = DO_EVAL((VAL)(th->fn)); // Apply this thunk's arguments to it CLOSURE_APPLY((VAL)th->fn, th->numargs, th->args); // And off we go again... th->fn = DO_EVAL((VAL)(th->fn)); UPDATE(x,((VAL)(th->fn))); return x; break; default: assert(0); // Can't happen } return x; } /* void* DO_PROJECT(VAL x, int arg) { assert(x->ty == CON); con* cn = (con*)x->info; return cn->args[arg]; } */ void* MKINT(int x) { return (void*)((x<<1)+1); // VAL c = MKCLOSURE; // SETTY(c, INT); // c->info = (void*)x; // return c; } void* NEWBIGINT(char* intstr) { mpz_t* bigint; VAL c = EMALLOC(sizeof(Closure)+sizeof(mpz_t)); bigint = (mpz_t*)(c+1); mpz_init(*bigint); mpz_set_str(*bigint, intstr, 10); SETTY(c, BIGINT); c->info = (void*)bigint; return c; } void* MKBIGINT(mpz_t* big) { mpz_t* bigint; VAL c = EMALLOC(sizeof(Closure)+sizeof(mpz_t)); bigint = (mpz_t*)(c+1); mpz_init(*bigint); mpz_set(*bigint, *big); SETTY(c, BIGINT); c->info = (void*)bigint; return c; } int GETINT(void* x) { return ((int)x)>>1; } mpz_t* GETBIGINT(void* x) { return ((mpz_t*)(((VAL)x)->info)); } void* MKSTR(char* x) { VAL c = MKCLOSURE; SETTY(c, STRING); c->info = (void*)(EMALLOC(strlen(x)*sizeof(char)+1)); strcpy(c->info,x); return c; } void* MKPTR(void* x) { VAL c = MKCLOSURE; SETTY(c, PTR); c->info = x; return c; } char* GETSTR(void* x) { return (char*)(((VAL)x)->info); } void* GETPTR(void* x) { return (void*)(((VAL)x)->info); } void ERROR(char* msg) { printf("*** error : %s ***\n",msg); assert(0); exit(1); } void* MKFREE(int x) { VAL c = MKCLOSURE; SETTY(c, FREEVAR); c->info = (void*)x; return c; } void init_evm() { one = MKINT(1); }