conservatory
/
vx-scheme
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
vx-scheme/src/vm.cpp

1053 lines
32 KiB
C++
Raw Permalink Blame History

//----------------------------------------------------------------------
// vx-scheme : Scheme interpreter.
// Copyright (c) 2002,2003,2006 and onwards Colin Smith.
//
// You may distribute under the terms of the Artistic License,
// as specified in the LICENSE file.
//
// vm.cpp : PAIP-style virtual machine for compiled Scheme code
//
#include "vx-scheme.h"
enum operand_type {
OP_NONE,
OP_INT,
OP_SYMBOL,
OP_SUBR,
OP_LEXADDR
};
// Extract information from a VM instruction.
#define INSN_OPCODE(_insn) ((_insn)->ca.i >> 24) // ca.i unsigned
#define SET_OPCODE(_insn, value) \
(((_insn)->ca.i = (_insn)->ca.i & 0xffffff | value<<24))
#define INSN_COUNT(_insn) (((_insn)->ca.i >> 16) & 0xff)
#define LEXA_ESKIP(_insn) ((_insn)->cd.i >> 16)
#define LEXA_BSKIP(_insn) ((_insn)->cd.i & 0xffff)
#define OPCODE(name,operand) {intern(name),operand}
typedef struct {
psymbol opcode;
enum operand_type opnd_type;
} vm_op;
// XXX issues:
// 1) the order of opcodes is willy-nilly.
// 2) there are magic number references to opcode numbers in this file.
// Be careful.
// 3) I forget what (3) is.
static vm_op optab [] = { // opcode number
OPCODE ("consti", OP_INT), // 0
OPCODE ("nil", OP_NONE),
OPCODE ("subr", OP_SUBR),
OPCODE ("gref", OP_SYMBOL),
OPCODE ("gset", OP_SYMBOL),
OPCODE ("lref", OP_LEXADDR), // 5
OPCODE ("lset", OP_LEXADDR),
OPCODE ("goto", OP_INT),
OPCODE ("false?p", OP_INT),
OPCODE ("false?", OP_INT),
OPCODE ("true?p", OP_INT), // 10
OPCODE ("true?", OP_INT),
OPCODE ("proc", OP_NONE),
OPCODE ("extend", OP_INT),
OPCODE ("extend!", OP_NONE),
OPCODE ("extend.", OP_INT), // 15
OPCODE ("save", OP_INT),
OPCODE ("return", OP_NONE),
OPCODE ("pop", OP_NONE),
OPCODE ("dup", OP_NONE),
OPCODE ("take", OP_INT), // 20
OPCODE ("cc", OP_NONE),
OPCODE ("resume", OP_NONE),
OPCODE ("apply.", OP_NONE),
OPCODE ("apply", OP_INT),
OPCODE ("unspc", OP_NONE), // 25
OPCODE ("unassn", OP_NONE),
OPCODE ("lit", OP_INT),
OPCODE ("vector-set!", OP_INT), // starting here:
OPCODE ("vector-ref", OP_INT), // scheme primitives allocated to opcode
OPCODE ("car", OP_INT), // 30
OPCODE ("cdr", OP_INT),
OPCODE ("zero?", OP_INT),
OPCODE ("+", OP_INT),
OPCODE ("*", OP_INT),
OPCODE ("quotient", OP_INT), // 35
OPCODE ("remainder", OP_INT),
OPCODE ("-", OP_INT),
OPCODE ("not", OP_INT),
OPCODE ("null?", OP_INT),
OPCODE ("eq?", OP_INT), // 40
OPCODE ("pair?", OP_INT),
OPCODE ("cons", OP_INT),
OPCODE ("gref.", OP_INT),
OPCODE ("false", OP_NONE),
OPCODE ("true", OP_NONE), // 45
OPCODE ("int", OP_INT),
OPCODE ("promise", OP_NONE),
OPCODE ("gset.", OP_INT),
};
static const int n_vmops = sizeof(optab) / sizeof(*optab);
// exact_top_n: return true if the top n elements of the stack contained
// in cv are of exact type (in this implementation, exact is synonymous
// with integer).
static bool exact_top_n (cellvector * cv, int n) {
int sz = cv->size();
for (int ix = sz - n; ix < sz; ++ix)
switch (cv->get_unchecked(ix)->type()) {
case Cell::Int: continue;
case Cell::Real: return false;
default: return false;
}
return true;
}
// Context::extend
// Extend an environment with the list of bindings in blist.
Cell* Context::extend(Cell* envt, Cell* blist) {
Cell * xe = gc_protect(make_vector(0));
cellvector * cv = xe->unsafe_vector_value();
FOR_EACH(b, blist)
cv->push (car (b));
envt = cons(xe, envt);
gc_unprotect();
return envt;
}
// Context::extend_from_vector
// Extend environment envt with elements from the vector v, in
// reverse order. (The compiler arranges to compile function
// arguments from left to right. This means that the "rightmost"
// argument to a function will be at the top of the stack.
// References to parameters are by integer index, with the leftmost
// argument numbered zero.)
Cell* Context::extend_from_vector (Cell* envt, cellvector* v, int n) {
int size = v->size();
r_nu = make_vector(n);
cellvector* new_vec = r_nu->unsafe_vector_value();
for (int ix = 0, iy = size - n; ix < n; ++ix, ++iy)
new_vec->set_unchecked(ix, v->get_unchecked(iy));
v->discard(n);
envt = cons(r_nu, envt);
return envt;
}
void Context::adjoin (Cell* envt, Cell* val) {
car(envt)->unsafe_vector_value()->push(val);
}
// Context::pop_list
// Context::push_list
// 'pop' pops the specified number of elements off the machine stack and
// returns a list of the elements. The last element popped will be first
// in the list. 'Push' pushes the supplied list onto the stack. Elements
// are pushed in the order given.
Cell* Context::pop_list (int n) {
r_tmp = nil;
for (int ix = 0; ix < n; ++ix) {
r_tmp = cons (gc_protect (m_stack.pop ()), r_tmp);
gc_unprotect ();
}
return r_tmp;
}
int Context::push_list(Cell* list) {
int count = 0;
FOR_EACH(a, list) {
m_stack.push(car(a));
++count;
}
return count;
}
void Context::print_insn(int addr, Cell* insn) {
vm_op * op = optab + INSN_OPCODE(insn);
printf ("%4d:\t%s\t", addr, op->opcode->key);
switch (op->opnd_type) {
case OP_INT:
printf ("%" PRIdPTR, insn->cd.i);
break;
case OP_SYMBOL:
printf ("%s", insn->cd.y->key);
break;
case OP_SUBR: printf ("%" PRIdPTR ",%s", INSN_COUNT (insn),
insn->flag(Cell::QUICK)
? insn->cd.f->name
: insn->cd.y->key);
// XXX comment
break;
case OP_LEXADDR:
printf ("%" PRIdPTR ",%" PRIdPTR, LEXA_ESKIP(insn), LEXA_BSKIP(insn));
break;
case OP_NONE:
;
}
printf("\n");
}
// Context::vm_evaluator
// Run the expression through the virtual machine's evaluator, if it's
// present. (The evaluator is compiled code produced by the bootstrapper.)
//
Cell* Context::vm_evaluator(Cell* form) {
if (!eval_cproc) {
Cell* binding;
if ((binding = find_var(root_envt, intern("eval"), 0)))
eval_cproc = cdr(binding);
}
if (eval_cproc) {
r_tmp = form;
r_exp = cons(form, nil);
// save(r_envt);
// r_envt = root_envt;
return execute(eval_cproc, r_exp);
// restore(r_envt);
}
error("can't find eval");
return make_boolean(false);
}
Cell* Context::execute (Cell* proc, Cell* args) {
cellvector *insns, *literals;
intptr_t pc;
int type;
intptr_t start;
unsigned int count;
unsigned int n_args = 0;
unsigned int b_skip = 0;
unsigned int e_skip = 0;
// Note the initial stack size.
int initial_stackdepth = m_stack.size();
save_i (-1);
// Push any arguments we received onto the stack.
FOR_EACH(a, args) {
++n_args;
save(car(a));
}
r_cproc = proc;
bool trace = OS::flag (TRACE_VM);
bool trace_stack = OS::flag (TRACE_VMSTACK);
bool count_insns = OS::flag (COUNT_INSNS);
int xcount [n_vmops];
if (count_insns)
for (int ix = 0; ix < n_vmops; ++ix)
xcount [ix] = 0;
cellvector* root_bindings = car(root_envt)->unsafe_vector_value();
PROC:
r_cproc->typecheck (Cell::Cproc);
insns = r_cproc->cd.cv->get (0)->unsafe_vector_value();
literals = r_cproc->cd.cv->get (1)->unsafe_vector_value();
r_envt = r_cproc->cd.cv->get (2);
pc = r_cproc->cd.cv->get (3)->IntValue ();
XEQ:
Cell * insn = insns->get_unchecked (pc); // trust compiler!
unsigned int opcode = INSN_OPCODE (insn);
if (count_insns)
++xcount [opcode];
if (trace) {
if (trace_stack) {
printf ("\t");
for (int ix = m_stack.size() - 1; ix >= 0; --ix) {
Cell * c = m_stack.get_unchecked(ix);
if (!((reinterpret_cast<intptr_t>(c))&1)) {
if (c == root_envt) printf("#<root-envt> ");
else c->write (stdout);
} else printf ("%" PRIdPTR, (reinterpret_cast<intptr_t>(c))>>1);
fputc (' ', stdout);
}
printf("\n");
}
print_insn(pc, insn);
}
switch (opcode)
{
case 0: // consti
save_i (insn->cd.i);
break;
case 1: // nil
m_stack.push (nil);
break;
case 2: // subr
if (!insn->flag(Cell::QUICK)) {
Cell* subr = find_var(root_envt, insn->cd.y, 0);
if (!subr) error("missing primitive procedure");
Cell* proc = cdr(subr);
type = proc->type();
if (type == Cell::Cproc) {
// Yuck. When the current procedure was compiled, the
// routine we are about to invoke was a builtin (subr): now
// it's a compiled procedure. The optimized calling
// convention for subrs no longer applies. We must pop
// the args off the stack, then push a continuation, then
// re-push the args, and dispatch to the procedure.
n_args = INSN_COUNT(insn);
cellvector cv;
for (unsigned int ix = 0; ix < n_args; ++ix)
cv.push(m_stack.pop());
save(r_envt);
save(r_cproc);
save_i(pc+1);
for (unsigned int ix = 0; ix < n_args; ++ix)
m_stack.push(cv.pop());
r_cproc = proc;
goto PROC;
} else if (type == Cell::Subr) {
insn->cd.f = cdr(subr)->SubrValue();
insn->flag(Cell::QUICK, true);
} else {
error("subr invoked on non-procedure");
}
}
r_val = pop_list (INSN_COUNT (insn));
// Subr's can change anything (in particular they can reenter execute).
save(r_envt);
save(r_cproc);
r_val = insn->cd.f->subr(this, r_val);
restore(r_cproc);
restore(r_envt);
m_stack.push(r_val);
break;
case 3: { // gref
unsigned int index;
r_val = find_var (root_envt, insn->cd.y, &index);
if (!r_val) {
error ("reference to undefined global variable: ", insn->cd.y->key);
} else {
if (cdr(r_val) == NULL) error("yikes"); // XXX
// Quicken the instruction.
SET_OPCODE(insn, 43); // gref. XXX: magic number (among others)
insn->cd.i = index;
m_stack.push (cdr (r_val));
}
break;
}
case 4: { // gset
unsigned int index;
set_var (root_envt, insn->cd.y, m_stack.pop (), &index);
// Quicken the instruction.
SET_OPCODE(insn, 48); // gset. XXX: magic number
insn->cd.i = index;
break;
}
case 5: // lref
e_skip = LEXA_ESKIP (insn);
b_skip = LEXA_BSKIP (insn);
r_tmp = r_envt;
for (unsigned int ix = 0; ix < e_skip; ++ix)
r_tmp = cdr (r_tmp);
m_stack.push (car (r_tmp)->cd.cv->get (b_skip));
break;
case 6: // lset
e_skip = LEXA_ESKIP (insn);
b_skip = LEXA_BSKIP (insn);
r_tmp = r_envt;
for (unsigned int ix = 0; ix < e_skip; ++ix)
r_tmp = cdr (r_tmp);
car (r_tmp)->cd.cv->set (b_skip, m_stack.pop ());
break;
case 7: // goto
pc = insn->cd.i;
goto XEQ;
case 8: // false?p
if (!m_stack.pop ()->istrue ()) {
pc = insn->cd.i;
goto XEQ;
}
break;
case 9: // false?
if (!m_stack.top ()->istrue ()) {
pc = insn->cd.i;
goto XEQ;
}
break;
case 10: // true?p
if (m_stack.pop ()->istrue ()) {
pc = insn->cd.i;
goto XEQ;
}
break;
case 11: // true?
if (m_stack.top ()->istrue ()) {
pc = insn->cd.i;
goto XEQ;
}
break;
case 12: // proc
// pop the starting instruction from the stack and compose it
// with the current environment.
restore_i (start);
m_stack.push (make_compiled_procedure (r_cproc->cd.cv->get_unchecked (0),
r_cproc->cd.cv->get_unchecked (1),
r_envt,
start));
break;
case 13: // extend
if (n_args < insn->cd.i)
error ("vm: not enough arguments to procedure");
r_envt = extend_from_vector (r_envt, &m_stack, insn->cd.i);
//r_envt = extend (r_envt, gc_protect (pop_list (insn->cd.i)));
//gc_unprotect ();
break;
case 14: // extend!
r_envt = extend (r_envt, gc_protect (pop_list (1)));
gc_unprotect ();
break;
case 15: // extend.
if (n_args < insn->cd.i)
error ("vm: not enough arguments to procedure");
r_val = pop_list (n_args - insn->cd.i);
r_envt = extend (r_envt, gc_protect (pop_list (insn->cd.i)));
gc_unprotect ();
adjoin (r_envt, r_val);
break;
case 16: // save
// make a continuation that will invoke the indicated
// instruction slot in this segment.
save (r_envt);
save (r_cproc);
save_i (insn->cd.i);
break;
case 17: // return
r_val = m_stack.pop (); // value
RETURN:
restore_i (pc);
if (pc < 0)
goto FINISH;
restore (r_cproc);
insns = r_cproc->cd.cv->get (0)->VectorValue ();
literals = r_cproc->cd.cv->get (1)->VectorValue ();
restore (r_envt);
save (r_val);
goto XEQ;
case 18: // pop
m_stack.pop ();
break;
case 19: // dup
m_stack.push (m_stack.top ());
break;
case 20: { // take
// Remove the n'th item from the stack and push it onto the top.
// (We count from zero). 'take 0' would be a no-op; 'take 1'
// would swap the top two elements. We use an unchecked get
// because we "trust the compiler."
intptr_t target = insn->cd.i;
int last = m_stack.size() - 1;
r_tmp = m_stack.get_unchecked(last-target);
for (int ix = last-target; ix < last; ++ix)
m_stack.set(ix, m_stack.get_unchecked(ix+1));
m_stack.set(last, r_tmp);
break;
}
case 21: { // cc
r_tmp = make_vector(m_stack.size());
cellvector* saved_stack = r_tmp->VectorValue();
for (int ix = 0; ix < m_stack.size(); ++ix)
saved_stack->set(ix, m_stack.get(ix));
r_nu = cons(r_tmp, nil);
r_envt = extend(r_envt, r_nu);
m_stack.push(make_compiled_procedure(cc_procedure, empty_vector,
r_envt, 0));
r_envt = cdr(r_envt);
// YYY
break;
}
case 22: { // resume
r_val = m_stack.pop();
r_tmp = m_stack.pop();
cellvector* new_stack = r_tmp->VectorValue();
m_stack.clear(); // !
for (int ix = 0; ix < new_stack->size(); ++ix)
m_stack.push(new_stack->get(ix));
goto RETURN;
}
case 23: // apply.
// Covert stack from: rest ... a2 a1 proc
// to: proc a1 a2 ... rest
// with 'rest' spliced in in the correct order.
// Then do as in an ordinary apply. This exists
// only to support the 'apply' special procedure.
r_tmp = m_stack.pop();
for (count = 0; count < n_args-2; ++count)
r_tmp = cons(m_stack.pop(), r_tmp);
r_proc = m_stack.pop();
count = push_list(r_tmp);
m_stack.push(r_proc);
// dummy up the 'real' arument count that the
// microcode for 'apply' will see below.
insn->cd.i = count;
/* FALL THROUGH */
case 24: // apply
r_exp = m_stack.pop ();
type = r_exp->type ();
if (type == Cell::Cproc) {
n_args = insn->cd.i;
r_cproc = r_exp;
goto PROC;
} else if (type == Cell::Subr) {
r_val = pop_list(insn->cd.i);
save(r_envt);
save(r_cproc);
r_val = r_exp->SubrValue()->subr(this, r_val);
restore(r_cproc);
restore(r_envt);
goto RETURN;
} else {
r_exp->write(stderr);
error ("vm: inapplicable");
}
break;
case 25: // unspc
m_stack.push (unspecified);
break;
case 26: // unassn
m_stack.push (unassigned);
break;
case 27: // lit
m_stack.push (literals->get (insn->cd.i));
break;
case 28: { // vector-set!
n_args = insn->cd.i;
if (n_args != 3)
error ("bad arguments to vector-set!");
int ix = m_stack.size() - 1;
cellvector * cv = m_stack.get(ix-2)->VectorValue();
cv->set(m_stack.get(ix-1)->IntValue(), m_stack.get(ix));
m_stack.discard(3);
m_stack.push(unspecified);
break;
}
case 29: { // vector-ref
n_args = insn->cd.i;
if (n_args != 2)
error ("bad arguments to vector-ref!");
intptr_t ix = m_stack.pop()->IntValue();
cellvector * cv = m_stack.pop()->VectorValue();
m_stack.push(cv->get(ix));
break;
}
case 30: // car
m_stack.push(car(m_stack.pop()));
break;
case 31: // cdr
m_stack.push(cdr(m_stack.pop()));
break;
case 32: { // zero?
Cell * c = m_stack.pop();
Cell::Type t = c->type();
if (t == Cell::Int)
m_stack.push(make_boolean(c->IntValue() == 0));
else if (t == Cell::Real)
m_stack.push(make_boolean(c->RealValue() == 0.0));
else
error ("non-numeric type");
break;
}
case 33: { // +
// get n; see if top n elements are all exact or not; add them
// accumulating in situ (to avoid consing an argument list),
// discard those elements and push the result.
n_args = insn->cd.i;
int sz = m_stack.size ();
if (exact_top_n (&m_stack, n_args)) {
intptr_t sum = 0;
for (int ix = sz - n_args; ix < sz; ++ix)
sum += m_stack.get (ix)->IntValue(); // exact_top_n guarantees this is OK
m_stack.discard (n_args);
m_stack.push(make_int(sum));
} else {
double sum = 0.0;
for (int ix = sz - n_args; ix < sz; ++ix)
sum += m_stack.get (ix)->asReal ();
m_stack.discard(n_args);
m_stack.push(make_real(sum));
}
break;
}
case 34: { // *
// much like +, above.
n_args = insn->cd.i;
int sz = m_stack.size ();
if (exact_top_n (&m_stack, n_args)) {
intptr_t product = 1;
for (int ix = sz - n_args; ix < sz; ++ix)
product *= m_stack.get (ix)->IntValue(); // exact_top_n says this is OK
m_stack.discard (n_args);
m_stack.push(make_int(product));
} else {
double product = 1.0;
for (int ix = sz - n_args; ix < sz; ++ix)
product *= m_stack.get (ix)->asReal ();
m_stack.discard(n_args);
m_stack.push(make_real(product));
}
break;
}
case 35: { // quotient
if (insn->cd.i != 2)
error ("wrong # args");
intptr_t d = m_stack.pop()->IntValue();
intptr_t n = m_stack.pop()->IntValue();
if (d == 0)
error ("/0");
m_stack.push (make_int (n/d));
break;
}
case 36: { // remainder
if (insn->cd.i != 2)
error ("wrong # args");
intptr_t d = m_stack.pop()->IntValue();
intptr_t n = m_stack.pop()->IntValue();
if (d == 0)
error ("/0");
m_stack.push (make_int (n%d));
break;
}
case 37: { // -
// get n; see if top n elements are all exact or not; add them
// accumulating in situ (to avoid consing an argument list),
// discard those elements and push the result.
n_args = insn->cd.i;
int sz = m_stack.size ();
if (exact_top_n (&m_stack, n_args)) {
if (n_args == 1) {
m_stack.push(make_int(-m_stack.pop()->IntValue()));
} else {
intptr_t difference = m_stack.get(sz-n_args)->IntValue();
for (int ix = sz - n_args + 1; ix < sz; ++ix)
difference -= m_stack.get (ix)->IntValue();
m_stack.discard (n_args);
m_stack.push(make_int(difference));
}
} else {
if (n_args == 1) {
m_stack.push(make_real(-m_stack.pop()->asReal()));
} else {
double difference = m_stack.get(sz-n_args)->asReal();
for (int ix = sz - n_args + 1; ix < sz; ++ix)
difference -= m_stack.get (ix)->asReal();
m_stack.discard(n_args);
m_stack.push(make_real(difference));
}
}
break;
}
case 38: // not
m_stack.push(m_stack.pop()->istrue()
? &Cell::Bool_F : &Cell::Bool_T);
break;
case 39: // null?
m_stack.push(m_stack.pop() == &Cell::Nil
? &Cell::Bool_T : &Cell::Bool_F);
break;
case 40: // eq?
m_stack.push(m_stack.pop()->eq(m_stack.pop())
? &Cell::Bool_T : &Cell::Bool_F);
break;
case 41: // pair?
m_stack.push(m_stack.pop()->ispair()
? &Cell::Bool_T : &Cell::Bool_F);
break;
case 42: // cons (watch out: order matters, and cons can provoke GC.)
r_tmp = m_stack.pop();
r_elt = m_stack.pop();
m_stack.push(cons(r_elt, r_tmp));
break;
case 43: { // gref. (quickened global ref; contains index of target binding)
m_stack.push(cdr(root_bindings->get(insn->cd.i)));
break;
}
case 44: // false
m_stack.push(&Cell::Bool_F);
break;
case 45: // true
m_stack.push(&Cell::Bool_T);
break;
case 46: // int
m_stack.push(make_int(insn->cd.i));
break;
case 47: // promise
restore_i(start);
r_tmp = make_compiled_procedure(r_cproc->cd.cv->get(0),
r_cproc->cd.cv->get(1),
r_envt,
start);
m_stack.push(make_compiled_promise(r_tmp));
break;
case 48: // gset.
Cell::setcdr(root_bindings->get(insn->cd.i), m_stack.pop());
break;
default:
error ("unimplemented opcode_");
}
++pc;
goto XEQ;
FINISH:
if (count_insns) {
for (int ix = 0; ix < n_vmops; ++ix)
printf ("%s:%d ", optab[ix].opcode->key, xcount [ix]);
printf ("\n");
}
if (m_stack.size() != initial_stackdepth) {
fprintf(stderr,"stack imbalance: %d (%d expected)\n", m_stack.size(),
initial_stackdepth);
}
return r_val;
}
// find_op: match the supplied opcode symbol in the vm_op table;
// return the index (or -1 if the opcode is not in the table).
int find_op (psymbol opsym)
{
for (int ix = 0; ix < n_vmops; ++ix)
if (optab[ix].opcode == opsym)
return ix;
return -1;
}
// Make compiled procedure (method and subr): store the
// current code segment, the environment, and program counter
// in an object.
static Cell* make_compiled_procedure (Context * ctx, Cell * arglist)
{
return ctx->make_compiled_procedure (car (arglist),
cadr (arglist),
nil,
0);
}
Cell * Context::make_compiled_procedure (Cell * insns,
Cell * literals,
Cell * envt,
int start)
{
Cell * c = gc_protect (alloc (Cell::Cproc));
cellvector * cv = cellvector::alloc(4);
c->cd.cv = cv;
c->flag (Cell::VREF, true);
cv->set (0, insns);
cv->set (1, literals);
cv->set (2, envt);
cv->set (3, make_int (start));
gc_unprotect ();
return c;
}
Cell* Context::make_compiled_promise(Cell* procedure) {
Cell * c = gc_protect(alloc(Cell::Cpromise));
cellvector* cv = cellvector::alloc(1);
c->cd.cv = cv;
c->flag(Cell::VREF, true);
cv->set(0, procedure);
gc_unprotect();
return c;
}
Cell* Context::force_compiled_promise(Cell* promise) {
promise->typecheck(Cell::Cpromise);
if (promise->flag(Cell::FORCED)) return promise->cd.cv->get(0);
Cell* val = execute(promise->cd.cv->get(0), nil);
// Did the promise become forced as a result of our evaluation?
// then that value is correct.
if (promise->flag(Cell::FORCED)) return promise->cd.cv->get(0);
promise->cd.cv->set(0, val);
promise->flag(Cell::FORCED, true);
return val;
}
// make_instruction: produce a packed machine instruction given
// an instruction in list form (e.g., '(consti 99) ).
static Cell* make_instruction (Context * ctx, Cell * arglist)
{
//return ctx->make_instruction (car (arglist));
return ctx->make_instruction (arglist);
}
Cell* Context::make_instruction (Cell * insn) {
psymbol op = car(insn)->SymbolValue();
int opcode = find_op(op);
if (opcode < 0)
error ("unknown opcode: ", op->key);
return make_instruction(opcode, cdr(insn));
}
Cell* Context::make_instruction(int opcode, Cell* operands)
{
unsigned int u1, u2;
psymbol y;
Cell * opnd = operands == nil ? nil : car(operands);
Cell * c = alloc (Cell::Insn);
c->ca.i |= (opcode & 0xff) << 24;
switch (optab[opcode].opnd_type)
{
case OP_INT:
c->cd.i = opnd->IntValue ();
break;
case OP_SYMBOL:
c->cd.y = opnd->SymbolValue ();
break;
case OP_SUBR: {
int count = cadr(operands)->IntValue ();
if (count < 0 || count > 255)
error ("count too large to store in instruction field");
c->ca.i |= count << 16;
y = opnd->SymbolValue();
// Store the symbol in the operand field. The evaluator
// will "quicken" the reference when the code is run.
c->cd.y = y;
break;
}
case OP_LEXADDR:
u1 = opnd->IntValue ();
u2 = cadr(operands)->IntValue ();
if (u1 > 65535 || u2 > 65535)
error ("lexical address too large");
c->cd.i = (u1 << 16) | u2;
break;
case OP_NONE:
break;
default:
error ("unhandled operand type");
}
return c;
}
static Cell* execute(Context* ctx, Cell* arglist) {
return ctx->execute (car (arglist), cdr(arglist));
}
static Cell* disassemble(Context* ctx, Cell* arglist) {
cellvector* cproc = car(arglist)->CProcValue();
cellvector* insns = cproc->get (0)->VectorValue ();
for (int ix = 0; ix < insns->size(); ++ix) {
ctx->print_insn(ix, insns->get(ix));
}
return unspecified;
}
static Cell* write_compiled_procedure(Context* ctx, Cell* arglist) {
return ctx->write_compiled_procedure(arglist);
}
// Context::load_compiled_procedure
// Turn a serialized compiled procedure into a "live" procedure, by
// reading the saved instructions and literals back into the Scheme
// heap.
// WARNING: This is expected to be called by the startup code with
// GC disabled.
Cell* Context::load_compiled_procedure(vm_cproc *cp) {
// We create a static argument list of two elements, which we reuse.
Cell* insns = load_instructions(cp);
Cell* literals = make_vector(cp->n_literals);
cellvector* litv = literals->VectorValue();
for (unsigned int ix = 0; ix < cp->n_literals; ++ix) {
sstring litstr;
litstr.append(cp->literals[ix]);
Cell* lit = read(litstr);
if (lit == NULL) error("undecipherable literal", cp->literals[ix]);
litv->set(ix, lit);
}
return make_compiled_procedure(insns, literals, nil, cp->entry);
}
Cell* Context::load_instructions(vm_cproc* cp) {
Cell* zero = make_int(0);
Cell* a1 = cons(zero, nil);
Cell* a0 = cons(zero, a1); // now a0 == '(0 0)
Cell* insns = make_vector(cp->n_insns);
cellvector* insv = insns->VectorValue();
for (unsigned int ix = 0; ix < cp->n_insns; ++ix) {
vm_insn* insn = cp->insns + ix;
int opcode = insn->opcode;
if (opcode > n_vmops) error("bad opcode in stored proc");
Cell::setcar(a0, zero);
Cell::setcar(a1, zero);
switch(optab[opcode].opnd_type) {
case OP_INT:
Cell::setcar(a0, make_int(reinterpret_cast<intptr_t>(insn->operand)));
break;
case OP_SYMBOL:
Cell::setcar(a0,
make_symbol(
intern(static_cast<const char*>(insn->operand))));
break;
case OP_LEXADDR: {
int la = reinterpret_cast<intptr_t>(insn->operand);
Cell::setcar(a0, make_int(la >> 16));
Cell::setcar(a1, make_int(la & 0xffff));
break;
}
case OP_SUBR:
Cell::setcar(a0,
make_symbol(
intern(static_cast<const char*>(insn->operand))));
Cell::setcar(a1, make_int(insn->count));
break;
case OP_NONE:
break;
}
insv->set(ix, make_instruction(opcode, a0));
}
return insns;
}
static void write_escaped_string(FILE* output, const char* str) {
char c;
fputc('"', output);
while ((c = *str++)) {
switch (c) {
case '\n':
fputc('\\', output);
fputc('n', output);
break;
case '"':
case '\\':
fputc('\\', output);
/* fall through */
default:
fputc(c, output);
}
}
fputc('"', output);
}
Cell* Context::write_compiled_procedure(Cell* arglist) {
cellvector* cproc = car(arglist)->CProcValue();
const char* name = cadr(arglist)->StringValue();
cellvector* insns = cproc->get(0)->VectorValue();
cellvector* literals = cproc->get(1)->VectorValue();
cellvector* root_bindings = car(root_envt)->VectorValue();
int entry = cproc->get(3)->IntValue();
FILE* output = current_output()->OportValue();
fprintf(output, "static vm_insn %s_insns[] = {\n", name);
for (int ix = 0; ix < insns->size(); ++ix) {
Cell* insn = insns->get(ix);
int opcode = INSN_OPCODE(insn);
// Horrible special cases: 'gref./gset.'. A "quickened global
// reference" is an index into a slot in the global environment.
// We can't write it out as is, since it's not likely that all
// global variables will have the same slot in the context into
// which this procedure will be loaded. Instead we write it out as
// an ordinary 'gref', so that it can be quickened in the
// environment in which it actually runs.
if (opcode == 43) { // XXX magic number
fprintf(output, " { %2d,0,", 3); // XXX magic number
write_escaped_string(output,
car(root_bindings->get(insn->cd.i))->SymbolValue()->key);
} else if (opcode == 48) {
fprintf(output, " { %2d,0,", 4); // XXX magic number
write_escaped_string(output,
car(root_bindings->get(insn->cd.i))->SymbolValue()->key);
} else { // not 'gref.'
vm_op* op = optab + opcode;
fprintf(output, " { %2d,", opcode); // XXX magic number
switch(op->opnd_type) {
case OP_NONE: fprintf(output, "0,0"); break;
case OP_INT: fprintf(output, "0,(void*)%" PRIdPTR, insn->cd.i); break;
case OP_SYMBOL: fprintf(output, "0,");
write_escaped_string(output, insn->cd.y->key); break;
case OP_SUBR:
// XXX write a comment
fprintf(output, "%" PRIdPTR ",", INSN_COUNT(insn));
if (insn->flag(Cell::QUICK))
write_escaped_string(output, insn->cd.f->name);
else
write_escaped_string(output, insn->cd.y->key);
break;
case OP_LEXADDR: fprintf(output, "0,(void*)%#" PRIxPTR, insn->cd.i); break;
}
}
fprintf(output, " },\n");
}
fprintf(output, "};\n\n");
if (literals->size() > 0) {
fprintf(output, "const char* %s_lit[] = {\n", name);
for (int ix = 0; ix < literals->size(); ++ix) {
sstring litstr;
fputs(" ", output);
literals->get(ix)->write(litstr);
write_escaped_string(output, litstr.str());
fputs(",\n", output);
}
fprintf(output, "};\n\n");
}
fprintf(output, "static vm_cproc %s = {\n %s_insns,\n %d,\n",
name, name, insns->size());
if (literals->size() > 0) {
fprintf(output, " %s_lit,\n %d,\n", name, literals->size());
} else {
fprintf(output, " 0,\n 0,\n");
}
fprintf(output, " %d,\n", entry);
fprintf(output, "};\n\n");
return unspecified;
}
// ================================
// PROVISIONING THE VIRTUAL MACHINE
//
class VmExtension : SchemeExtension {
public:
VmExtension () {
Register (this);
}
virtual void Install (Context * ctx, Cell * envt) {
static struct {
const char* name;
subr_f subr;
} bindings[] = {
{ "make-instruction", make_instruction },
{ "make-compiled-procedure", make_compiled_procedure },
{ "write-compiled-procedure", write_compiled_procedure },
{ "disassemble", disassemble },
{ "execute", execute },
};
static const unsigned int n_bindings = sizeof(bindings)/sizeof(*bindings);
for (unsigned int ix = 0; ix < n_bindings; ++ix) {
ctx->bind_subr(bindings[ix].name, bindings[ix].subr);
}
// Initialize the macro table.
ctx->set_var(envt, intern("__macro_table"), nil);
// Attach VM execution function to context, so the interpreter may
// invoke compiled procedures.
ctx->vm_execute = &Context::execute;
ctx->vm_eval = &Context::vm_evaluator;
}
};
static VmExtension vm_extension;
Reference in New Issue View Git Blame Copy Permalink