/* vm.c   by Michael Thorpe   2017-04-12 */

#include <stdlib.h>
#include "lisp.h"
#include "vm.h"

typedef struct catcher catcher;
struct catcher {
	catcher *previous;
	unsigned int pc;
	unsigned int sp;
};

typedef struct context context;
struct context {
	context *caller;
	unsigned int pc;
	unsigned int sp;
	unsigned char *code;
	unsigned int codelen;
	obj **stack;
	unsigned int stacksize;
	catcher *catcher;
	obj *args; /* not INCREF()ed */
	obj *func;
};

static obj *bytefuncerror;
static obj *stackunderflowerror;

#ifdef DEBUG
#include <stdio.h>

static int vmdebug=0;
static obj *vmdebugobj=0;

static obj *set_vm_debug(obj *on) {
	obj *old;

	if(&integer_objtype==on->type) {
		if(on->value.i<0 || 2<on->value.i)
			return(throwrangecheck(on));
		vmdebug=on->value.i;
	} else if(&nilobj==on) {
		vmdebug=0;
	} else {
		return(throwtypeerror(on));
	}
	old=vmdebugobj;
	vmdebugobj=on;
	return(old);
}

static void writeobj(obj *o) {
	obj *s;

	s=(o->type->tostring)(INCREF(o));
	if(s) {
		fwrite(s->value.s.data,1,s->value.s.len,stderr);
		DECREF(s);
	}
}
#endif

static obj *run_init(obj *func) {
	context *c,*c2;
	catcher *tmpcatcher;
	obj *o,*o2,**tmpstack;
	signed int oparg=0;
	unsigned int i;

#define NEEDARGS(n); if(c->sp<(n)) {throw(INCREF(stackunderflowerror),INCREF(c->func)); goto handle_exception;}

	c=(context *)malloc(sizeof(context));
	if(!c) {
		DECREF(func);
		return(throwoom());
	}
	c->caller=0;
	c->pc=0;
	c->sp=0;
	c->code=(unsigned char *)func->value.bytefunc.code->value.s.data;
	c->codelen=func->value.bytefunc.code->value.s.len;
	c->stack=0;
	c->stacksize=0;
	c->catcher=0;
	c->args=func->value.bytefunc.objs;
	c->func=func;
start_function:
#ifdef DEBUG
	if(vmdebug) {
		fprintf(stderr,"%p: starting function %p with:",c,c->func);
		for(i=c->sp;i>0;i--) {
			fprintf(stderr,"\t");
			writeobj(c->stack[i-1]);
		}
		fprintf(stderr,"\n");
	}
#endif
	while(1) {
next_op:
		oparg=0;
		if(c->codelen<c->pc)
			goto bytefunc_error;
		if(0x80 & c->code[c->pc]) {
			oparg=(0x7F & c->code[c->pc]);
			if(0x40 & c->code[c->pc])
				oparg|=~0x7F;
			while(1) {
				c->pc++;
				if(c->codelen<c->pc)
					goto bytefunc_error;
				if(!(0x80 & c->code[c->pc]))
					break;
				if(oparg<~0xFFFFFF || 0xFFFFFF<oparg) /* Let's not get ridiculous */
					goto bytefunc_error;
				oparg<<=7;
				oparg|=(0x7F & c->code[c->pc]);
			}
		}
#ifdef DEBUG
		if(vmdebug>1) {
			fprintf(stderr,"%p.%u(%p): %2.2X (",c->func,c->pc,c,c->code[c->pc]);
			switch(c->code[c->pc]) {
			case OP_NIL: fprintf(stderr,"NIL"); break;
			case OP_POP: fprintf(stderr,"POP"); break;
			case OP_EXCH: fprintf(stderr,"EXCH"); break;
			case OP_INDEX: fprintf(stderr,"INDEX"); break;
			case OP_PUT: fprintf(stderr,"PUT"); break;
			case OP_LOCALOBJ: fprintf(stderr,"LOCALOBJ"); break;
			case OP_ADD: fprintf(stderr,"ADD"); break;
			case OP_SUB: fprintf(stderr,"SUB"); break;
			case OP_MUL: fprintf(stderr,"MUL"); break;
			case OP_DIV: fprintf(stderr,"DIV"); break;
			case OP_CMP: fprintf(stderr,"CMP"); break;
			case OP_GOTO: fprintf(stderr,"GOTO"); break;
			case OP_BT: fprintf(stderr,"BT"); break;
			case OP_BF: fprintf(stderr,"BF"); break;
			case OP_RET: fprintf(stderr,"RET"); break;
			case OP_CALL: fprintf(stderr,"CALL"); break;
			case OP_RETCALL: fprintf(stderr,"RETCALL"); break;
			case OP_CATCH: fprintf(stderr,"CATCH"); break;
			case OP_TOSS: fprintf(stderr,"TOSS"); break;
			case OP_THROW: fprintf(stderr,"THROW"); break;
			case OP_DEFINE: fprintf(stderr,"DEFINE"); break;
			case OP_LOOKUP: fprintf(stderr,"LOOKUP"); break;
			case OP_SET: fprintf(stderr,"SET"); break;
			case OP_UNDEFINE: fprintf(stderr,"UNDEFINE"); break;
			case OP_NEEDARGS: fprintf(stderr,"NEEDARGS"); break;
			case OP_EXTYPE: fprintf(stderr,"EXTYPE"); break;
			case OP_EXVALUE: fprintf(stderr,"EXVALUE"); break;
			case OP_EQ: fprintf(stderr,"EQ"); break;
			case OP_AND: fprintf(stderr,"AND"); break;
			case OP_OR: fprintf(stderr,"OR"); break;
			case OP_NOT: fprintf(stderr,"NOT"); break;
			case OP_PUSHI: fprintf(stderr,"PUSHI"); break;
			case OP_OBJTYPE: fprintf(stderr,"OBJTYPE"); break;
			case OP_CONS: fprintf(stderr,"CONS"); break;
			case OP_CAR: fprintf(stderr,"CAR"); break;
			case OP_CDR: fprintf(stderr,"CDR"); break;
			case OP_QUOTE: fprintf(stderr,"QUOTE"); break;
			case OP_UNQUOTE: fprintf(stderr,"UNQUOTE"); break;
			case OP_BITSEL: fprintf(stderr,"BITSEL"); break;
			case OP_ASR: fprintf(stderr,"ASR"); break;
			case OP_PAIR: fprintf(stderr,"PAIR"); break;
			default: fprintf(stderr,"???"); break;
			}
			fprintf(stderr,") %d\tSTACK:",oparg);
			for(i=c->sp;i>0;i--) {
				fprintf(stderr,"\t");
				writeobj(c->stack[i-1]);
			}
			fprintf(stderr,"\n");
		}
#endif
		switch(c->code[c->pc]) {
		case OP_NIL:
			if(oparg)
				goto bytefunc_error;
			o=INCREF(&nilobj);
push_obj:
			if(c->stacksize<=c->sp) {
				tmpstack=(obj **)realloc(c->stack,(c->stacksize+8)*sizeof(obj *));
				if(!tmpstack) {
					DECREF(o);
					throwoom();
					goto handle_exception;
				}
				c->stack=tmpstack;
				c->stacksize+=8;
			}
			c->stack[c->sp++]=o;
			break;
		case OP_INDEX:
			if(oparg<0)
				goto bytefunc_error;
			NEEDARGS(1+oparg);
			o=INCREF(c->stack[c->sp-1-oparg]);
			goto push_obj;
		case OP_PUT:
			if(oparg<0)
				goto bytefunc_error;
			NEEDARGS(1+oparg+1);
			o=c->stack[--c->sp];
			DECREF(c->stack[c->sp-1-oparg]);
			c->stack[c->sp-1-oparg]=o;
			break;
		case OP_POP:
			if(oparg<0)
				goto bytefunc_error;
			oparg++;
			NEEDARGS(oparg);
			while(oparg--) {
				--c->sp;
				DECREF(c->stack[c->sp]);
			}
			break;
		case OP_EXCH:
			if(oparg<0)
				goto bytefunc_error;
			NEEDARGS(oparg+2);
			i=oparg/2;
			do {
				o=c->stack[c->sp-1-i];
				c->stack[c->sp-1-i]=c->stack[c->sp-1-(oparg+1-i)];
				c->stack[c->sp-1-(oparg+1-i)]=o;
			} while(i--);
			break;
		case OP_LOCALOBJ:
			if(oparg<0)
				goto bytefunc_error;
			o=c->args;
			while(1) {
				if(&cons_objtype != o->type)
					goto bytefunc_error;
				if(!oparg--) {
					o=INCREF(o->value.c.a);
					goto push_obj;
				}
				o=o->value.c.d;
			}
		case OP_ADD:
			if(oparg)
				goto bytefunc_error;
			NEEDARGS(2);
			o=c->stack[--c->sp];
			o=add(c->stack[--c->sp],o);
			if(!o)
				goto handle_exception;
			c->stack[c->sp++]=o;
			break;
		case OP_SUB:
			if(oparg)
				goto bytefunc_error;
			NEEDARGS(2);
			o=c->stack[--c->sp];
			o=sub(c->stack[--c->sp],o);
			if(!o)
				goto handle_exception;
			c->stack[c->sp++]=o;
			break;
		case OP_MUL:
			if(oparg)
				goto bytefunc_error;
			NEEDARGS(2);
			o=c->stack[--c->sp];
			o=mul(c->stack[--c->sp],o);
			if(!o)
				goto handle_exception;
			c->stack[c->sp++]=o;
			break;
		case OP_DIV:
			if(oparg)
				goto bytefunc_error;
			NEEDARGS(2);
			o=c->stack[--c->sp];
			o=div2(c->stack[--c->sp],o);
			if(!o)
				goto handle_exception;
			c->stack[c->sp++]=o;
			break;
		case OP_CMP:
			if(oparg<0 || 6<oparg)
				goto bytefunc_error;
			NEEDARGS(2);
			o=c->stack[--c->sp];
			o=numcmp(c->stack[--c->sp],o,oparg);
			if(!o)
				goto handle_exception;
			c->stack[c->sp++]=o;
			break;
		case OP_GOTO:
op_goto:
			c->pc+=1+oparg;
			/* The c->pc range checking will catch jumps-too-far problems */
			goto next_op;
		case OP_BT:
			NEEDARGS(1);
			o=c->stack[--c->sp];
			DECREF(o);
			if(&nilobj != o)
				goto op_goto;
			break;
		case OP_BF:
			NEEDARGS(1);
			o=c->stack[--c->sp];
			DECREF(o);
			if(&nilobj==o)
				goto op_goto;
			break;
		case OP_RET:
			if(oparg<0)
				goto bytefunc_error;
			if(c->sp != oparg+1)
				goto bytefunc_error;
			if(c->catcher)
				goto bytefunc_error;
			DECREF(c->func);
			o=c->stack[--c->sp];
			while(c->sp) {
				--c->sp;
				DECREF(c->stack[c->sp]);
			}
			free(c->stack);
#ifdef DEBUG
			if(vmdebug) {
				fprintf(stderr,"%p: returning from %p with:\t",c,c->func);
				writeobj(o);
				fprintf(stderr,"\n");
			}
#endif
			c2=c->caller;
			free(c);
			c=c2;
			/* This opcode has different meaning in the base bytecode */
			if(!c)
				return(o);
			goto push_obj;
		case OP_RETCALL:
			if(c->catcher)
				goto bytefunc_error;
			if(c->sp != oparg+1)
				goto bytefunc_error;
		case OP_CALL:
			if(oparg<0)
				goto bytefunc_error;
			NEEDARGS(1+oparg);
			o=c->stack[--c->sp];
			if(&bytefunc_objtype==o->type) {
				if(OP_RETCALL==(c->code[c->pc])) {
					DECREF(c->func);
					c->pc=0;
					c->code=(unsigned char *)o->value.bytefunc.code->value.s.data;
					c->codelen=o->value.bytefunc.code->value.s.len;
					c->args=o->value.bytefunc.objs;
					c->func=o;
				} else {
					tmpstack=(obj **)malloc(oparg*sizeof(obj *));
					if(!tmpstack) {
						DECREF(o);
						throwoom();
						goto handle_exception;
					}
					c2=(context *)malloc(sizeof(context));
					if(!c2) {
						free(tmpstack);
						DECREF(o);
						throwoom();
						goto handle_exception;
					}
					c2->caller=c;
					c2->pc=0;
					c2->sp=0;
					c2->code=(unsigned char *)o->value.bytefunc.code->value.s.data;
					c2->codelen=o->value.bytefunc.code->value.s.len;
					c2->stack=tmpstack;
					c2->stacksize=oparg;
					c2->catcher=0;
					c2->args=o->value.bytefunc.objs;
					c2->func=o;
					while(c2->sp<oparg) {
						c2->stack[c2->sp]=c->stack[c->sp-oparg+c2->sp];
						c2->sp++;
					}
					c->sp-=oparg;
					c=c2;
				}
				goto start_function;
			} else if(&rawfunc_objtype==o->type) {
/* This should get simplified or merged with applyrawfunc: */
				o2=INCREF(&nilobj);
				while(oparg--) {
					o2=cons(c->stack[--c->sp],o2);
					if(!o2) {
						DECREF(o);
						goto handle_exception;
					}
				}
				if(OP_RETCALL==(c->code[c->pc])) {
#ifdef DEBUG
					if(vmdebug)
						fprintf(stderr,"%p: retcalling rawfunc from %p\n",c,c->func);
#endif
					DECREF(c->func);
					free(c->stack);
					c2=c->caller;
					free(c);
					c=c2;
					/* This opcode has different meaning in the base bytecode */
					if(!c)
						return(applyrawfunc(o,o2));
					o=applyrawfunc(o,o2);
					if(!o)
						goto handle_exception;
					goto push_obj;
				} else {
					o=applyrawfunc(o,o2);
					if(!o)
						goto handle_exception;
					c->stack[c->sp++]=o;
				}
			} else {
				throwtypeerror(o);
				goto handle_exception;
			}
			break;
		case OP_CATCH:
			tmpcatcher=(catcher *)malloc(sizeof(catcher));
			if(!tmpcatcher) {
				throwoom();
				goto handle_exception;
			}
			tmpcatcher->previous=c->catcher;
			tmpcatcher->pc=c->pc+1+oparg;
			tmpcatcher->sp=c->sp;
			c->catcher=tmpcatcher;
			break;
		case OP_TOSS: /* Basically reverses the last OP_CATCH done in this function */
			if(oparg)
				goto bytefunc_error;
			if(!c->catcher)
				goto bytefunc_error;
			tmpcatcher=c->catcher;
			c->catcher=tmpcatcher->previous;
			free(tmpcatcher);
			break;
		case OP_THROW: /* OP_THROW takes the exception as the top value, "backwards" from throw() */
			if(oparg)
				goto bytefunc_error;
			NEEDARGS(2);
			o=c->stack[--c->sp];
			throw(o,c->stack[--c->sp]);
			goto handle_exception;
		case OP_DEFINE: /* OP_DEFINE takes the name as the top value, "backwards" from define() */
			if(oparg)
				goto bytefunc_error;
			NEEDARGS(2);
			o=c->stack[--c->sp];
			o=define(o,c->stack[--c->sp]);
			if(!o)
				goto handle_exception;
			c->stack[c->sp++]=o;
			break;
		case OP_LOOKUP:
			if(oparg)
				goto bytefunc_error;
			NEEDARGS(1);
			o=lookup(c->stack[--c->sp]);
			if(!o)
				goto handle_exception;
			c->stack[c->sp++]=o;
			break;
		case OP_SET: /* OP_SET takes the name as the top value, "backwards" from set() */
			if(oparg)
				goto bytefunc_error;
			NEEDARGS(2);
			o=c->stack[--c->sp];
			o=set(o,c->stack[--c->sp]);
			if(!o)
				goto handle_exception;
			c->stack[c->sp++]=o;
			break;
		case OP_UNDEFINE:
			if(oparg)
				goto bytefunc_error;
			NEEDARGS(1);
			o=c->stack[--c->sp];
			o=undefine(o);
			if(!o)
				goto handle_exception;
			c->stack[c->sp++]=o;
			break;
		case OP_NEEDARGS:
			if(oparg<0)
				goto bytefunc_error;
			if(oparg != c->sp) {
				throwargumenterror(INCREF(func));
				goto handle_exception;
			}
			break;
		case OP_EXTYPE:
			if(oparg)
				goto bytefunc_error;
			o=INCREF(exception);
			goto push_obj;
		case OP_EXVALUE:
			if(oparg)
				goto bytefunc_error;
			o=INCREF(exceptionvalue);
			goto push_obj;
		case OP_EQ:
			if(oparg)
				goto bytefunc_error;
			NEEDARGS(2);
			o2=c->stack[--c->sp];
			DECREF(o2);
			o=c->stack[--c->sp];
			DECREF(o);
			if(o != o2)
				c->stack[c->sp++]=INCREF(&nilobj);
			else
				c->stack[c->sp++]=INCREF(&trueobj);
			break;
		case OP_AND:
			if(oparg)
				goto bytefunc_error;
			NEEDARGS(2);
			o2=c->stack[--c->sp];
			DECREF(o2);
			o=c->stack[--c->sp];
			DECREF(o);
			if(&nilobj==o || &nilobj==o2)
				c->stack[c->sp++]=INCREF(&nilobj);
			else
				c->stack[c->sp++]=INCREF(&trueobj);
			break;
		case OP_OR:
			if(oparg)
				goto bytefunc_error;
			NEEDARGS(2);
			o2=c->stack[--c->sp];
			DECREF(o2);
			o=c->stack[--c->sp];
			DECREF(o);
			if(&nilobj==o && &nilobj==o2)
				c->stack[c->sp++]=INCREF(&nilobj);
			else
				c->stack[c->sp++]=INCREF(&trueobj);
			break;
		case OP_NOT:
			if(oparg)
				goto bytefunc_error;
			NEEDARGS(1);
			o=c->stack[--c->sp];
			DECREF(o);
			if(&nilobj != o)
				c->stack[c->sp++]=INCREF(&nilobj);
			else
				c->stack[c->sp++]=INCREF(&trueobj);
			break;
		case OP_PUSHI:
			o=new_object(&integer_objtype);
			if(!o)
				goto handle_exception;
			o->value.i=oparg;
			goto push_obj;
			break;
		case OP_OBJTYPE:
			if(oparg)
				goto bytefunc_error;
			NEEDARGS(1);
			o=c->stack[c->sp-1];
			c->stack[c->sp-1]=INCREF(o->type->nameobj);
			DECREF(o);
			break;
		case OP_CONS:
			if(oparg)
				goto bytefunc_error;
			NEEDARGS(2);
			o2=c->stack[--c->sp];
			o=c->stack[--c->sp];
			o=cons(o,o2);
			if(!o)
				goto handle_exception;
			c->stack[c->sp++]=o;
			break;
		case OP_CAR:
			if(oparg)
				goto bytefunc_error;
			NEEDARGS(1);
			o=c->stack[--c->sp];
			if(&cons_objtype != o->type) {
				throwtypeerror(o);
				goto handle_exception;
			}
			o2=CAR(o);
			c->stack[c->sp++]=INCREF(o2);
			DECREF(o);
			break;
		case OP_CDR:
			if(oparg)
				goto bytefunc_error;
			NEEDARGS(1);
			o=c->stack[--c->sp];
			if(&cons_objtype != o->type) {
				throwtypeerror(o);
				goto handle_exception;
			}
			o2=CDR(o);
			c->stack[c->sp++]=INCREF(o2);
			DECREF(o);
			break;
		case OP_QUOTE:
			if(oparg)
				goto bytefunc_error;
			NEEDARGS(1);
			o=c->stack[--c->sp];
			o=quoteobj(o);
			if(!o)
				goto handle_exception;
			c->stack[c->sp++]=o;
			break;
		case OP_UNQUOTE:
			if(oparg)
				goto bytefunc_error;
			NEEDARGS(1);
			o=c->stack[--c->sp];
			o=unquote(o);
			if(!o)
				goto handle_exception;
			c->stack[c->sp++]=o;
			break;
		case OP_BITSEL:
			if(oparg)
				goto bytefunc_error;
			NEEDARGS(3);
			c->sp-=3;
			o=bitselect(c->stack[c->sp],c->stack[c->sp+1],c->stack[c->sp+2]);
			if(!o)
				goto handle_exception;
			c->stack[c->sp++]=o;
			break;
		case OP_ASR:
			if(oparg)
				goto bytefunc_error;
			NEEDARGS(2);
			o=c->stack[--c->sp];
			o=asr(c->stack[--c->sp],o);
			if(!o)
				goto handle_exception;
			c->stack[c->sp++]=o;
			break;
		case OP_PAIR:
			if(oparg)
				goto bytefunc_error;
			NEEDARGS(1);
			o=c->stack[--c->sp];
			c->stack[c->sp++]=INCREF((&cons_objtype==o->type)?&trueobj:&nilobj);
			DECREF(o);
			break;
		default:
			goto bytefunc_error;
		}
		c->pc++;
	}
bytefunc_error:
	throw(INCREF(bytefuncerror),INCREF(c->func));
handle_exception:
#ifdef DEBUG
	if(vmdebug) {
		fprintf(stderr,"EXCEPTION: ");
		writeobj(exception);
		fprintf(stderr,"\nEXCEPTION-VALUE: ");
		writeobj(exceptionvalue);
		fprintf(stderr,"\nSTACK:\n");
		for(i=c->sp;i>0;i--) {
			fprintf(stderr,"\t");
			writeobj(c->stack[i-1]);
			fprintf(stderr,"\n");
		}
	}
#endif
	while(!c->catcher) {
#ifdef DEBUG
		if(vmdebug)
			fprintf(stderr,"exception thrown; popping context %p to %p\n",c,c->caller);
#endif
		DECREF(c->func);
		if(c->stack) {
			while(c->sp) {
				--c->sp;
				DECREF(c->stack[c->sp]);
			}
			free(c->stack);
		}
		c2=c->caller;
		free(c);
		c=c2;
		if(!c)
			return(0);
	}
#ifdef DEBUG
	if(vmdebug)
		fprintf(stderr,"exception thrown; caught by catcher %p in context %p\n",c->catcher,c);
#endif
	c->pc=c->catcher->pc;
	while(c->catcher->sp<c->sp) {
		--c->sp;
		DECREF(c->stack[c->sp]);
	}
	tmpcatcher=c->catcher;
#ifdef DEBUG
	if(vmdebug)
		fprintf(stderr,"setting PC to %u and SP to %u\n",c->pc,c->sp);
#endif
	c->catcher=tmpcatcher->previous;
	free(tmpcatcher);
	goto next_op;
}

int run_vm() {
	obj *o;

	o=new_word("#init",5);
	if(!o)
		return(1);
	o=lookup(o);
	if(!o)
		return(1);
	o=run_init(o);
	if(o)
		DECREF(o);
#ifdef DEBUG
	DECREF(vmdebugobj);
	vmdebug=0;
	vmdebugobj=0;
#endif
	return(&nilobj==o?0:1);
}

int vm_init() {
	obj *c,*o,*s;

	if(!(bytefuncerror=new_word("bytefunc-error",14))
#ifdef DEBUG
	|| store_builtin_ns1("vm-debug",set_vm_debug)
#endif
	|| !(stackunderflowerror=new_word("stack-underflow-error",21)))
		return(1);
#ifdef DEBUG
	vmdebug=0;
	vmdebugobj=INCREF(&nilobj);
#endif
	c=INCREF(&nilobj);
#define ADD_OP(name,code); s=new_word(name,sizeof(name)-1); if(!s) return(1); o=new_object(&integer_objtype); if(!o) return(1); o->value.i=code; o=cons(s,o); if(!o) return(1); c=cons(o,c); if(!c) return(1);
#include "opcodes.c"
	s=new_word("#vm-opcodes",11);
	if(!s) return(1);
	o=define(s,c);
	if(!o) return(1);
	DECREF(o);
	return(0);
}

void vm_exit() {
	DECREF(bytefuncerror); bytefuncerror=0;
	DECREF(stackunderflowerror); stackunderflowerror=0;
#ifdef DEBUG
	vmdebug=0;
	if(vmdebugobj) {
		DECREF(vmdebugobj); vmdebugobj=0;
	}
#endif
}