mercury/bytecode/mb_exec.c

/*
** Copyright (C) 2000-2001 The University of Melbourne.
** This file may only be copied under the terms of the GNU Library General
** Public License - see the file COPYING.LIB in the Mercury distribution.
**
*/

/* Imports */
#include	"mercury_imp.h"
#include	"mercury_ho_call.h"

#include	"mb_exec.h"

#include	<assert.h>
#include	<stdio.h>
#include	<string.h>
#include	"mb_interface.h"
#include	"mb_mem.h"
#include	"mb_machine_show.h"
#include	"mb_module.h"

/* Exported definitions */
MB_Native_Addr	MB_machine_exec(MB_Bytecode_Addr new_ip,
				MB_Word *initial_stack);

/* Local declarations */

/* Set new stack vars to this help find bugs */
#define CLOBBERED	0xbadbad00

#define CLOBBERPICKUPS	0	/* clobber reg after pickup */
#define CLOBBERPLACES	0	/* clobber slot after place */
#define CLOBBERSTACK	1	/* reset new stack vars */

static MB_Bool	dispatch(MB_Byte bc_id, MB_Machine_State *ms);

static void instr_do_redo	(MB_Machine_State*ms, MB_Bytecode_Arg*bca);
static void instr_do_fail	(MB_Machine_State*ms, MB_Bytecode_Arg*bca);

static void instr_invalid		(MB_Machine_State *ms,
						MB_Bytecode_Arg *bca);
static void instr_enter_proc		(MB_Machine_State *ms,
						MB_Bytecode_Arg *bca);
static void instr_endof_proc		(MB_Machine_State *ms,
						MB_Bytecode_Arg *bca);
static void instr_enter_disjunction	(MB_Machine_State *ms,
						MB_Bytecode_Arg *bca);
static void instr_endof_disjunction	(MB_Machine_State *ms,
						MB_Bytecode_Arg *bca);
static void instr_enter_disjunct	(MB_Machine_State *ms,
						MB_Bytecode_Arg *bca);
static void instr_endof_disjunct	(MB_Machine_State *ms,
						MB_Bytecode_Arg *bca);
static void instr_enter_switch		(MB_Machine_State *ms,
						MB_Bytecode_Arg *bca);
static void instr_enter_switch_arm	(MB_Machine_State *ms,
						MB_Bytecode_Arg *bca);
static void instr_endof_switch_arm	(MB_Machine_State *ms,
						MB_Bytecode_Arg *bca);
static void instr_endof_switch		(MB_Machine_State *ms,
						MB_Bytecode_Arg *bca);
static void instr_enter_if		(MB_Machine_State *ms,
						MB_Bytecode_Arg *bca);
static void instr_enter_then		(MB_Machine_State *ms,
						MB_Bytecode_Arg *bca);
static void instr_endof_then		(MB_Machine_State *ms,
						MB_Bytecode_Arg *bca);
/* instr_enter_else is identical to enter_then */
static void instr_endof_if		(MB_Machine_State *ms,
						MB_Bytecode_Arg *bca);
static void instr_enter_negation	(MB_Machine_State *ms,
						MB_Bytecode_Arg *bca);
static void instr_endof_negation_goal	(MB_Machine_State *ms,
						MB_Bytecode_Arg *bca);
static void instr_endof_negation	(MB_Machine_State *ms,
						MB_Bytecode_Arg *bca);
static void instr_enter_commit		(MB_Machine_State *ms,
						MB_Bytecode_Arg *bca);
static void instr_endof_commit		(MB_Machine_State *ms,
						MB_Bytecode_Arg *bca);
static void instr_assign		(MB_Machine_State *ms,
						MB_Bytecode_Arg *bca);
static void instr_test			(MB_Machine_State *ms,
						MB_Bytecode_Arg *bca);
static void instr_construct		(MB_Machine_State *ms,
						MB_Bytecode_Arg *bca);
static void instr_deconstruct		(MB_Machine_State *ms,
						MB_Bytecode_Arg *bca);
static void instr_place			(MB_Machine_State *ms,
						MB_Bytecode_Arg *bca);
static void instr_pickup		(MB_Machine_State *ms,
						MB_Bytecode_Arg *bca);
static void instr_call			(MB_Machine_State *ms,
						MB_Bytecode_Arg *bca);
static void instr_higher_order_call	(MB_Machine_State *ms,
						MB_Bytecode_Arg *bca);
static void instr_builtin_binop		(MB_Machine_State *ms,
						MB_Bytecode_Arg *bca);
static void instr_builtin_bintest	(MB_Machine_State *ms,
						MB_Bytecode_Arg *bca);
static void instr_builtin_unop		(MB_Machine_State *ms,
						MB_Bytecode_Arg *bca);
static void instr_builtin_untest	(MB_Machine_State *ms,
						MB_Bytecode_Arg *bca);
static void instr_semidet_success	(MB_Machine_State *ms,
						MB_Bytecode_Arg *bca);
static void instr_semidet_success_check	(MB_Machine_State *ms,
						MB_Bytecode_Arg *bca);
static void instr_do_redo		(MB_Machine_State *ms,
						MB_Bytecode_Arg *bca);
static void instr_do_fail		(MB_Machine_State *ms,
						MB_Bytecode_Arg *bca);
static void instr_noop			(MB_Machine_State *ms,
						MB_Bytecode_Arg *bca);
static void instr_notdone		(MB_Machine_State *ms,
						MB_Bytecode_Arg *bca);

/* return true if a construction succeeds */
static MB_Word do_construct_cons(MB_Machine_State *ms, const MB_Cons_id *cid,
		MB_Word list_length, MB_Short *var_list);

/* return true if a deconstruction succeeds */
static MB_Bool do_deconstruct(MB_Machine_State *ms, const MB_Cons_id *cid,
		MB_Word var, MB_Word list_length, MB_Short *var_list);
static MB_Bool do_deconstruct_cons(MB_Machine_State *ms, const MB_Cons_id *cid,
		MB_Word val, MB_Word list_length, MB_Short *var_list);

/* Calls a native code procedure and sets up reentry variables */
static void	call_native_proc(MB_Machine_State *ms,
	       			MB_Native_Addr native_addr,
			       	MB_Bytecode_Addr return_ip);

typedef void (*MB_Instruction_Handler)	(MB_Machine_State *, MB_Bytecode_Arg *);

/* XXX ORDER: relies on the order of the definitions */
static MB_Instruction_Handler instruction_table[] = {
	instr_invalid,		/* enter_pred */
	instr_invalid,		/* endof_pred */
	instr_enter_proc,
	instr_endof_proc,
	instr_noop,		/* label */
	instr_enter_disjunction,
	instr_endof_disjunction,
	instr_enter_disjunct,
	instr_endof_disjunct,
	instr_enter_switch,
	instr_endof_switch,
	instr_enter_switch_arm,
	instr_endof_switch_arm,
	instr_enter_if,
	instr_enter_then,
	instr_endof_then,
	instr_endof_if,
	instr_enter_negation,
	instr_endof_negation,
	instr_enter_commit,
	instr_endof_commit,
	instr_assign,
	instr_test,
	instr_construct,
	instr_deconstruct,
	instr_notdone,		/* XXX complex construct */
	instr_notdone,		/* XXX complex deconstruct */
	instr_place,
	instr_pickup,
	instr_call,
	instr_higher_order_call,
	instr_builtin_binop,
	instr_builtin_unop,	/* XXX unop */
	instr_builtin_bintest,
	instr_builtin_untest,	/* XXX unop test */
	instr_semidet_success,
	instr_semidet_success_check,
	instr_do_redo,		/* fail */
	instr_noop,		/* context */
	instr_notdone,		/* not supported */
	instr_enter_then,	/* enter_else (identical to enter_then) */
	instr_endof_negation_goal
};

static void
instr_invalid(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
{
	MB_fatal("Invalid instruction encountered");
}


/* Enter/exit procedure */
static void
instr_enter_proc(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
{
	switch (bca->enter_proc.det) {
		case MB_DET_FAILURE:
		case MB_DET_SEMIDET:
		case MB_DET_CC_NONDET:
		case MB_DET_DET:
		case MB_DET_CC_MULTIDET: {
			MB_Word detframe_size = 
					bca->enter_proc.temp_count +
					bca->enter_proc.list_length +
					MB_DETFRAME_SIZE;

			/*
			** Save the initial stack frame if this function is
			** going to be the one that returns to native code
			*/
			if (MB_initialstackframe_get(ms) == NULL) {
				MB_initialstackframe_set(ms, MB_sp);
			}

			MB_incr_sp(detframe_size);

			/* save succip */
			MB_stackitem(MB_DETFRAME_SUCCIP) = (MB_Word) MB_succip;

			MB_ip_set(ms, MB_ip_get(ms) + 1);

			break;
		}
		case MB_DET_MULTIDET:
		case MB_DET_NONDET: {

			MB_Word *prevfr = MB_maxfr;
			MB_Word *succfr = MB_curfr;

			if (MB_initialstackframe_get(ms) == NULL) {
				MB_initialstackframe_set(ms, MB_maxfr);
			}

			MB_maxfr += MB_FRAME_NORMAL_SIZE
					+ bca->enter_proc.list_length
					+ bca->enter_proc.temp_count;

			MB_curfr = MB_maxfr;

			MB_fr_prevfr(MB_curfr) = prevfr;
			MB_fr_redoip(MB_curfr) = (MB_Word)
							MB_native_get_do_fail();
			MB_fr_redofr(MB_curfr) = (MB_Word) MB_maxfr;
			MB_fr_succip(MB_curfr) = (MB_Word) MB_succip;
			MB_fr_succfr(MB_curfr) = succfr;
			/*
			** bcretip is set just before a procedure call so that
			** bytecode_return_nondet knows where in the bytecode to
			** jump to. Set to NULL for now to catch errors.
			*/
			MB_fr_bcretip(MB_curfr) = (MB_Word) NULL;
			MB_fr_bcinitfr(MB_curfr) = (MB_Word)
						MB_initialstackframe_get(ms);

			MB_ip_set(ms, MB_ip_get(ms) + 1);
			
			break;
		}
		/* XXX Other options */
		default:
			MB_fatal("enter_proc det type not implemented");
	}

	/* set procedure detism info & variable stack pointer */
	MB_proc_var_init(ms);

	#if CLOBBERSTACK
	{
		MB_Word i;
		MB_Word count = bca->enter_proc.list_length +
					bca->enter_proc.temp_count;
		for (i = 0; i < count; i++) {
			MB_var_set(ms, i, CLOBBERED + i);
		}
	}
	#endif

	if (MB_model_semi(bca->enter_proc.det)) {
		/*
		** If a semidet procedure then mark our success slot as failure
		** until we know otherwise.
		*/
		MB_stackitem(MB_DETFRAME_SEMIDET_SUCCESS) = MB_SEMIDET_FAILURE;

		/* Also push a failure context in case fail is encountered */
		MB_frame_temp_push(ms, bca->enter_proc.end_label.addr);
	}
}

static void
instr_endof_proc(MB_Machine_State *ms, MB_Bytecode_Arg *endof_bca)
{
	/* get the current proc */
	MB_Bytecode_Arg *bca =
		MB_code_get_arg(endof_bca->endof_proc.proc_start);
	
	switch (bca->enter_proc.det) {
		case MB_DET_FAILURE:
		case MB_DET_CC_NONDET:
		case MB_DET_SEMIDET:
			/* put the success indicator into a register */
			MB_reg(MB_SEMIDET_SUCCESS_REG) =
				MB_stackitem(MB_DETFRAME_SEMIDET_SUCCESS);

			/* remove the failure context */
			MB_maxfr = MB_fr_prevfr(MB_maxfr);
		case MB_DET_CC_MULTIDET:
		case MB_DET_DET: {
			MB_Word detframe_size = 
					bca->enter_proc.temp_count +
					bca->enter_proc.list_length +
					MB_DETFRAME_SIZE;

			MB_succip = MB_stackitem(MB_DETFRAME_SUCCIP);

			/* deallocate stack variables */
			MB_decr_sp(detframe_size);

			/* Check whether we should return to native code */
			if (MB_sp == MB_initialstackframe_get(ms)) {
				MB_native_return_set(ms, MB_succip);
			} else {
				MB_ip_set(ms, MB_succip);
			}
			break;
		}

		case MB_DET_MULTIDET:
		case MB_DET_NONDET: {
			/* We don't deallocate the stack */
		
			MB_Word	*old_curfr = MB_curfr;
			/* Restore succip */
			MB_succip = MB_fr_succip(MB_curfr);

			/* Restore curfr */
			MB_curfr = MB_fr_succfr(MB_curfr);

			/* Check whether we should return to native code */
			if (MB_fr_prevfr(old_curfr) ==
					MB_initialstackframe_get(ms))
			{
				MB_native_return_set(ms, MB_succip);
			} else {
				MB_ip_set(ms, MB_succip);
			}

			break;
		}
		/* XXX other options */
		default:
			MB_fatal("endof_proc det type not implemented");
	}
	
	MB_proc_var_init(ms);
}

static void
instr_enter_disjunction(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
{
	/* push a new temp frame */
	MB_frame_temp_push(ms, MB_CODE_INVALID_ADR);
	instr_noop(ms, NULL);
}

static void
instr_enter_disjunct(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
{
	/*
	** set the redo point of the topmost frame (pushed in
	** enter_disjunction) to the disjunct after the current one
	**
	** if this is the last disjunct, then remove the top frame instead
	*/
	if (bca->enter_disjunct.next_label.addr == MB_CODE_INVALID_ADR) {
		/* remove the top frame */
		/* XXX TESTING */
		MB_maxfr = MB_fr_prevfr(MB_maxfr);
	} else {
		/* set a new redoip */

		/*
		** We know it is a frame from bytecode, but was it a temp nondet
		** frame from a det or nondet proc?
		*/

		assert(MB_FRAME_TEMP_DET_SIZE != MB_FRAME_TEMP_NONDET_SIZE);

		if (MB_frame_size(MB_maxfr) == MB_FRAME_TEMP_DET_SIZE) {
			MB_fr_temp_det_bcredoip(MB_maxfr) 
				= (MB_Word) bca->enter_disjunct.next_label.addr;
		} else {
			MB_fr_temp_nondet_bcredoip(MB_maxfr) 
				= (MB_Word) bca->enter_disjunct.next_label.addr;
		}
	}
	instr_noop(ms, NULL);
}

static void
instr_endof_disjunct(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
{
	/*
	** a simple jump to the end of the disjunction
	** if we are coming from a nonlast disjunct then we will
	** be leaving one or more nondet stack frames so we can backtrack
	** into the disjunction if we fail later on
	*/
	MB_ip_set(ms, bca->endof_disjunct.end_label.addr);
}

static void
instr_endof_disjunction(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
{
	/*
	** do nothing
	*/
	instr_noop(ms, NULL);
}

static void
instr_enter_switch(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
{
	instr_noop(ms, NULL);
}

static void
instr_enter_switch_arm(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
{
	/* Check if this deconstruct is going to succeed */
	if (do_deconstruct(ms, &bca->enter_switch_arm.cons_id,
			bca->enter_switch_arm.var, 0, 0))
	{
		/*
		** If it does succeed, then step into the switch
		*/
		instr_noop(ms, NULL);

	} else {
		/*
		** If it fails, go to the next switch arm
		*/
		MB_ip_set(ms, bca->enter_switch_arm.next_label.addr);
	}
}

static void
instr_endof_switch_arm(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
{
	/* This switch arm has succeeded, now go to the end of the switch */
	MB_ip_set(ms, bca->endof_switch_arm.end_label.addr);
}

static void
instr_endof_switch(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
{
	/*
	** If we get here, no switch arm matched, so trigger a redo
	*/
	instr_do_redo(ms, NULL);
}

static void
instr_enter_if(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
{
	/*
	** push a failure context and save the frame address in a
	** temp stack slot
	*/
	MB_frame_temp_push(ms, bca->enter_if.else_label.addr);
	MB_var_set(ms, bca->enter_if.frame_ptr_tmp, (MB_Word) MB_maxfr);

	instr_noop(ms, NULL);
}

/* enter_else is identical to enter_then */
/*
instr_enter_else()
*/
static void
instr_enter_then(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
{
	MB_Word *tempfr = (MB_Word *)
				MB_var_get(ms, bca->enter_then.frame_ptr_tmp);

	/* If the frame is on top, can we pop it */
	if (MB_maxfr == tempfr) {
		MB_maxfr = MB_fr_prevfr(MB_maxfr);
	} else {
		/* otherwise replace redoip with do_fail, effectively
		 * discarding it when the stack gets unwound */
		MB_fr_redoip(tempfr) = (MB_Word) MB_native_get_do_fail();
	}
	
	instr_noop(ms, NULL);
}

static void
instr_endof_then(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
{
	/* Jump to the end of the construct */
	MB_ip_set(ms, bca->endof_then.follow_label.addr);
}

static void
instr_endof_if(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
{
	/* Do nothing */
	instr_noop(ms, NULL);
}

static void
instr_enter_negation(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
{
	/* 
	** Push a fail context: If the negation fails we want it
	** to drop through to the end of the negation and succeed
	*/
	MB_var_set(ms, bca->enter_negation.frame_ptr_tmp, (MB_Word) MB_maxfr);
	MB_frame_temp_push(ms, bca->enter_negation.end_label.addr);

	instr_noop(ms, NULL);
}

static void
instr_endof_negation_goal(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
{
	/*
	** The negation has succeeded. Now we want to indicate failure.
	** Rewind the stack back to before the negation and issue a redo
	*/

	MB_maxfr = MB_var_get(ms, bca->endof_negation_goal.frame_ptr_tmp);

	instr_do_redo(ms, NULL);
}

static void
instr_endof_negation(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
{
	/*
	** The negation failed.
	** Remove the temp frame which will be at the top and continue
	*/
	MB_maxfr = MB_fr_prevfr(MB_maxfr);
	
	instr_noop(ms, NULL);
}

static void
instr_enter_commit(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
{
	/* push a new stack frame & save its location in a temp stack slot */
	MB_frame_temp_push_do_fail(ms);
	MB_var_set(ms, bca->enter_commit.frame_ptr_tmp, (MB_Word) MB_maxfr);

	instr_noop(ms, NULL);	
}

static void
instr_endof_commit(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
{
	/* Unwind the stack back to where it was before the commit */
	MB_maxfr = MB_var_get(ms, bca->endof_commit.frame_ptr_tmp);

	instr_noop(ms, NULL);	
}

static void
instr_assign(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
{
	/* copy variable from one slot to another */
	MB_var_set(ms, bca->assign.to_var,
			MB_var_get(ms, bca->assign.from_var));

	instr_noop(ms, NULL);	
}

static void
instr_test(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
{
	int result;

	/* test the equality of two variable slots */
	switch (bca->test.id) {
		case MB_TESTID_INT:
		case MB_TESTID_CHAR:
		case MB_TESTID_ENUM:
			result =
			       	MB_var_get(ms, bca->test.var1)
			       	== MB_var_get(ms, bca->test.var2);
			break;
		case MB_TESTID_STRING:
			result = !strcmp(MB_var_get(ms, bca->test.var1),
					MB_var_get(ms, bca->test.var2));
			break;
		case MB_TESTID_FLOAT:
			MB_fatal("Float testing not supported");
		default:
			MB_fatal("Unexpected test type");
	}

	if (result) {		
		instr_noop(ms, NULL);
	} else {
		instr_do_redo(ms, NULL);
	}
}

static MB_Word
do_construct_cons(MB_Machine_State *ms, const MB_Cons_id *cid,
		MB_Word list_length, MB_Short *var_list)
{
	const MB_Tag	*cons_tag = &cid->opt.cons.tag;
	MB_Word		*val = MB_mkword(
				MB_mktag(cons_tag->opt.pair.primary),
				MB_mkbody((MB_Word) NULL));

	/* the final value we will put in the reg */

	assert(cid->id == MB_CONSID_CONS);
	
	/* 
	** XXX: If list_length can be anything, then what is the use of
	** the arity field for functors??
	*/
	/* assert(list_length != 0); */

	switch (cons_tag->id) {
		case MB_TAG_SIMPLE: 	/* only need a primary tag */
		case MB_TAG_COMPLICATED:/* need primary + remote 2ndary tag */
		{
			/*
			** The code for these two is virtually identical except
			** that if it is tag_complicated we need one extra heap
			** slot for the remote secondary tag
			*/
			MB_Word	extra = (cons_tag->id == MB_TAG_COMPLICATED)
					? 1 : 0;
			MB_Word *heap_data;

			if (list_length + extra != 0) {
				MB_Unsigned	i;
			
				/* allocate heap memory */
				heap_data = (MB_Word *) MB_GC_NEW_ARRAY(
						MB_Word, list_length + extra);

				/* ensure tag bits aren't used */
				assert(MB_tag((MB_Word) heap_data) == 0);

				/* copy variables to allocated heap block */
				for (i = 0; i < list_length; i++) {
					heap_data[i + extra] =
						MB_var_get(ms, var_list[i]);
				}
			} else {
				heap_data = NULL;
			}

			/*
			** copy the secondary tag if we need to
			** and combine the pointer & tag
			*/
			if (cons_tag->id == MB_TAG_COMPLICATED_CONSTANT) {
				heap_data[0] = cons_tag->opt.pair.secondary;
				val = MB_mkword(
					MB_mktag(cons_tag->opt.pair.primary),
					MB_body((MB_Word) heap_data,
							MB_mktag(0)));
			} else {
				val = MB_mkword(
					MB_mktag(cons_tag->opt.primary),
					MB_body((MB_Word) heap_data,
							MB_mktag(0)));
			}
			
			break;
		}
			
		case MB_TAG_COMPLICATED_CONSTANT:
			/* primary + local secondary tag */
			assert(list_length == 0);
			val = MB_mkword(
				MB_mktag(cons_tag->opt.pair.primary),
				MB_mkbody(cons_tag->opt.pair.secondary));

			break;
			
		case MB_TAG_ENUM:
			/* Simple tag with no body */
			assert(list_length == 0);
			val = MB_mkword(MB_mktag(cons_tag->opt.enum_tag),
					MB_mkbody(0));
			break;

		case MB_TAG_NONE:
			assert(list_length == 1);
			val = (MB_Word *) MB_var_get(ms, var_list[0]);
			break;
			MB_fatal("tag_none not done");
		default:
			MB_fatal("Unknown tag type in construct");
	}
	return (MB_Word) val;
}

static void
instr_construct(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
{
	MB_Word val;
	/* construct a variable into a slot */
	switch (bca->construct.consid.id) {
		case MB_CONSID_INT_CONST:
			assert(bca->construct.list_length == 0);
			val = bca->construct.consid.opt.int_const;
			break;

		case MB_CONSID_STRING_CONST:
			assert(bca->construct.list_length == 0);
			val = (MB_Word) bca->construct.consid.opt.string_const;
			break;

		case MB_CONSID_CONS:
			val = do_construct_cons(ms,
				&bca->construct.consid,
				bca->construct.list_length,
				bca->construct.var_list);
			break;

		case MB_CONSID_FLOAT_CONST:
			MB_fatal("Construct float not implemented");
			
		case MB_CONSID_PRED_CONST: {
			/* XXX Closure layouts not done */

			int i;
			MB_Word		num_hidden_args;
			MR_Closure	*closure;
			MB_Short	*var_list;
			MB_Cons_id	*consid = &(bca->construct.consid);

			/*MB_util_error("Closure layouts not implemented");*/

			if (consid->opt.pred_const.native_addr == NULL) {
				consid->opt.pred_const.native_addr =
					MB_code_find_proc_native(
						consid->opt.pred_const.
								module_name,
						consid->opt.pred_const.
								pred_name,
						consid->opt.pred_const.mode_num,
						consid->opt.pred_const.arity,
						consid->opt.pred_const.is_func
					);

				if (consid->opt.pred_const.native_addr == NULL){
					MB_util_error("%s %s__%s/%d (%d)",
						consid->opt.pred_const.is_func
							? "func" : "pred",
						consid->opt.pred_const.
								module_name,
						consid->opt.pred_const.
								pred_name,
						consid->opt.pred_const.arity,
						consid->opt.pred_const.mode_num
						);
					MB_fatal("Unable to find closure code");
				}
			}

			/* Create a closure */
			num_hidden_args = bca->construct.list_length;
			var_list = bca->construct.var_list;

			/* Fill in the closure */

			closure = (MR_Closure *) MB_GC_malloc(
				offsetof(MR_Closure, MR_closure_hidden_args_0)
					+ sizeof(MR_Word) * num_hidden_args);
			closure->MR_closure_layout = NULL;
			closure->MR_closure_code =
				consid->opt.pred_const.native_addr;
			closure->MR_closure_num_hidden_args = num_hidden_args;

			/* Copy the hidden arguments */
			for (i = 0; i < num_hidden_args; i++) {
				closure->MR_closure_hidden_args(i+1) =
					MB_var_get(ms, var_list[i]);
			}

			val = (MB_Word) closure;
			break;
		}
			
		case MB_CONSID_CODE_ADDR_CONST:
			MB_fatal("Construct code_addr not implemented");

		case MB_CONSID_BASE_TYPE_INFO_CONST: {

			MB_Cons_id	*consid = &(bca->construct.consid);

			if (consid->opt.base_type_info_const.type_info == NULL) {
				consid->opt.base_type_info_const.type_info =
					MB_type_find_ctor_info_guaranteed(
						consid->opt.base_type_info_const
							.module_name,
						consid->opt.base_type_info_const
							.type_name,
						consid->opt.base_type_info_const
							.type_arity);
			}

			val = (MB_Word) consid->opt.base_type_info_const
								.type_info;
			break;
		}

		case MB_CONSID_CHAR_CONST:
			val = (MB_Word) bca->construct.consid.opt.char_const.ch;
			break;

		default:
			MB_fatal("Unknown constructor id");
	}
	MB_var_set(ms, bca->construct.to_var, val);
	instr_noop(ms, NULL);
}

/*
** returns true if the deconstruction succeeds
** if a int/string/char const, checks for equality and triggers a redo if it
** fails.
** if a functor then deconstructs arguments into variable slots
*/
static MB_Bool
do_deconstruct(MB_Machine_State *ms, const MB_Cons_id *cid, MB_Word var, 
		MB_Word list_length, MB_Short *var_list)
{
	MB_Word var_val = MB_var_get(ms, var);
	
	/* XXX not all deconstructions done */
	switch (cid->id) {
		case MB_CONSID_INT_CONST:
			return (var_val == cid->opt.int_const);

		case MB_CONSID_STRING_CONST:
			return (!MB_str_cmp((char *)var_val,
				cid->opt.string_const));

		case MB_CONSID_CONS: {
			return do_deconstruct_cons(ms, cid, var_val,
					list_length, var_list);
		}

		case MB_CONSID_CHAR_CONST:
			return (var_val == (MB_Word) cid->opt.char_const.ch);

		default:
			MB_fatal("Deconstruct type not implemented");
	}

	assert(FALSE);
	return FALSE;
}

/* returns true if val is equivalent to a construction given by cid */
static MB_Bool
do_deconstruct_cons(MB_Machine_State *ms, const MB_Cons_id *cid,
		MB_Word val, MB_Word list_length, MB_Short *var_list)
{
	const MB_Tag *cons_tag = &cid->opt.cons.tag;

	assert(cid->id == MB_CONSID_CONS);

	/*
	** We should either check all variables (eg: deconstruct instruction)
	** or none of them (eg: switch_arm instruction)
	*/
	assert((cid->opt.cons.arity == list_length) || (list_length == 0));

	switch (cons_tag->id) {
		case MB_TAG_SIMPLE: 	/* only need a primary tag */
		case MB_TAG_COMPLICATED:/* need primary + remote 2ndary tag */
		{
			/*
			** The code for these two is virtually identical except
			** that if it is complicated we need one extra heap
			** slot for the remote secondary tag
			*/
			MB_Word	extra = (cons_tag->id == MB_TAG_COMPLICATED)
				? 1 : 0;
			MB_Word *heap_data = (MB_Word *) MB_strip_tag(val);
			MB_Word i;

			/* check that tags are identical */
			if (cons_tag->id == MB_TAG_COMPLICATED) {
				if ((MB_tag(val) != cons_tag->opt.pair.primary)
					|| (heap_data[0] !=
						cons_tag->opt.pair.secondary))
				{
					return FALSE;
				}
			} else {
				if (MB_tag(val) != cons_tag->opt.primary) {
					return FALSE;
				}
			}
			

			/* Deconstruct into variable slots */
			for (i = 0; i < list_length; i++) {
				MB_var_set(ms, var_list[i],
						heap_data[i + extra]);
			}

			break;
		}
			
		case MB_TAG_COMPLICATED_CONSTANT:
			/* primary + local secondary tag */
			assert(list_length == 0);
			if (val != (MB_Word) MB_mkword(
				MB_mktag(cons_tag->opt.pair.primary),
				MB_mkbody(cons_tag->opt.pair.secondary)))
			{
				return FALSE;
			}

			break;
			
		case MB_TAG_ENUM:
			assert(list_length == 0);
			if (val != (MB_Word)
				MB_mkword(MB_mktag(cons_tag->opt.enum_tag),
				MB_mkbody(0)))
			{
				return FALSE;
			}
			break;

		case MB_TAG_NONE:
			MB_fatal("tag_none not done");

		default:
			MB_fatal("Unknown deconstruct tag");
	}

	return TRUE;
}


static void
instr_deconstruct(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
{
	/* test the equality of a variable in a slot with a given value */
	if (!do_deconstruct(ms, &bca->deconstruct.consid,
				bca->deconstruct.from_var,
				bca->deconstruct.list_length,
				bca->deconstruct.var_list))
	{
		instr_do_redo(ms, NULL);
	} else {
		instr_noop(ms, NULL);
	}
}

static void
instr_place(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
{
	/* copy value from var slot to reg */
	MB_reg(bca->place_arg.to_reg) =
		MB_var_get(ms, bca->place_arg.from_var);

	#if CLOBBERPLACES
		/* XXX for debugging only */
		MB_var_set(ms, bca->place_arg.from_var, CLOBBERED);
	#endif

	/* go to the next instruction */
	instr_noop(ms, NULL);
}

static void
instr_pickup(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
{
	/* copy value from reg to var slot */
	MB_var_set(ms, bca->pickup_arg.to_var,
		MB_reg(bca->pickup_arg.from_reg));

	#if CLOBBERPICKUPS
		/* XXX for debugging only */
		MB_reg_set(ms, bca->pickup_arg.from_reg, CLOBBERED);
	#endif

	/* go to the next instruction */
	instr_noop(ms, NULL);
}

/* Calls a native code procedure and sets up reentry variables */
static void
call_native_proc(MB_Machine_State *ms, MB_Native_Addr native_addr,
	       				MB_Bytecode_Addr return_ip)
{
	if (MB_proc_is_det(ms)) {
		/*
		** Call native code from det function
		*/

		/* Push a interface det stack frame */
		MB_incr_sp(MB_DETFRAME_INTERFACE_SIZE);

		/* Set success ip to reentry stub */
		MB_succip = MB_native_get_return_det();

		/* Save initial stack frame pointer */
		MB_stackitem(MB_DETFRAME_INTERFACE_BCINITFR)
			= (MB_Word) MB_initialstackframe_get(ms);

		/* Save bytecode reentry point */
		MB_stackitem(MB_DETFRAME_INTERFACE_BCRETIP)
			= (MB_Word) return_ip;

	} else {
		/* 
		** Call native code from nondet function
		*/

		/* Set success ip to reentry point */
		MB_succip = MB_native_get_return_nondet();

		/* Save bytecode reentry point */
		MB_fr_bcretip(MB_curfr) = (MB_Word) return_ip;
	}

	/* return to native code at address new_addr */
	MB_native_return_set(ms, native_addr);
}

static void
instr_call(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
{
	/* Call another procedure */
	
	MB_Bytecode_Addr next_ip = MB_ip_get(ms) + 1;

	/* Call bytecode */
	if (!bca->call.addr.is_native) {
		MB_Bytecode_Addr new_addr = bca->call.addr.addr.bc;
		if (new_addr == MB_CODE_INVALID_ADR) {
			MB_util_error("Attempt to call unknown bytecode"
					" %s %s__%s/%d mode %d",
					bca->call.is_func ? "func" : "pred",
					bca->call.module_name,
					bca->call.pred_name,
					(int) bca->call.arity,
					(int) bca->call.mode_num);
			MB_fatal("");
		} else {
			if (MB_ip_normal(new_addr)) {
				/* set the return address to the next instr */
				MB_succip = next_ip;
				/* set the new execution point */
				MB_ip_set(ms, new_addr);
			} else {
				MB_fatal("Unexpected call address"
					" (special address not implemented?)");
			}
		}

	/* Call native code */
	} else {

		MB_Native_Addr new_addr = bca->call.addr.addr.native;
		
		/* Make sure the address has been looked up */
		if (new_addr == NULL) {
			new_addr = MB_code_find_proc_native(
					bca->call.module_name,
					bca->call.pred_name,
					bca->call.mode_num,
					bca->call.arity,
					bca->call.is_func);
			if (new_addr == NULL) {
				MB_util_error(
					"Warning: proc ref in bytecode"
					" to unknown %s %s__%s/%d mode %d",
					bca->call.is_func ? "func" : "pred",
					bca->call.module_name,
					bca->call.pred_name,
					(int) bca->call.arity,
					(int) bca->call.mode_num);
				MB_fatal("Are you sure the module"
					" was compiled with trace"
					" information enabled?");
			}

			/* XXX: Write to constant data */
			bca->call.addr.addr.native = new_addr;
		}

		call_native_proc(ms, new_addr, next_ip);
	}
}

/*
** Why does the call need to know the number of output arguments ???
**
** XXX: If semidet, do I need to make space for the extra argument or has
** the mercury compiler already done that ???
*/
static void
instr_higher_order_call(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
{
	/* We are doing the call */
	MR_Closure *closure = (MR_Closure *)
		MB_var_get(ms, bca->higher_order_call.pred_var);

	/*
	** Shift the input arguments to the right so we can insert the
	** arguments inside the closure
	*/
	if (bca->higher_order_call.in_var_count != 0) {
		signed int i = closure->MR_closure_num_hidden_args;
		signed int j = i + bca->higher_order_call.in_var_count;
		for (; i >= 1; i--, j--) {
			MB_reg(j) = MB_reg(i);
		}
	}

	/*
	** Now insert the hidden arguments
	*/
	if (closure->MR_closure_num_hidden_args) {
		signed int i;
		MB_Word num_hidden_args =
			closure->MR_closure_num_hidden_args;

		for (i = 1; i <= num_hidden_args; i++) {
			MB_reg(i) = closure->MR_closure_hidden_args(i);
		}
	}
	
	/*
	** Do the actual call
	*/

	call_native_proc(ms, closure->MR_closure_code, MB_ip_get(ms) + 1);

}
/*----------------------------------------------------------------------------*/

static MB_Word binop_add	(MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
static MB_Word binop_sub	(MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
static MB_Word binop_mul	(MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
static MB_Word binop_div	(MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
static MB_Word binop_mod	(MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
static MB_Word binop_lshift	(MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
static MB_Word binop_rshift	(MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
static MB_Word binop_and	(MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
static MB_Word binop_or		(MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
static MB_Word binop_xor	(MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
static MB_Word binop_logand	(MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
static MB_Word binop_logor	(MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
static MB_Word binop_eq		(MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
static MB_Word binop_ne		(MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
static MB_Word binop_lt		(MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
static MB_Word binop_gt		(MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
static MB_Word binop_le		(MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
static MB_Word binop_ge		(MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
static MB_Word binop_bad	(MB_Machine_State*ms,const MB_Bytecode_Arg*bca);


typedef MB_Word (*MB_Instruction_Binop)	(MB_Machine_State *,
						const MB_Bytecode_Arg *);
/*
** XXX ORDER Currently we depend on the order of elements in the table.
*/
static MB_Instruction_Binop binop_table[] = {
	binop_add,
	binop_sub,
	binop_mul,
	binop_div,
	binop_mod,
	binop_lshift,
	binop_rshift,	/* XXX signed */
	binop_and,
	binop_or,
	binop_xor,
	binop_logand,
	binop_logor,
	binop_eq,
	binop_ne,
	binop_bad,	/* array_index */
	binop_bad,	/* str_eq */
	binop_bad,	/* str_ne */
	binop_bad,	/* str_lt */
	binop_bad,	/* str_gt */
	binop_bad,	/* str_le */
	binop_bad,	/* str_ge */
	binop_lt,
	binop_gt,
	binop_le,
	binop_ge,
	binop_bad,	/* float_plus */
	binop_bad,	/* float_minus */
	binop_bad,	/* float_times */
	binop_bad,	/* float_divide */
	binop_bad,	/* float_eq */
	binop_bad,	/* float_ne */
	binop_bad,	/* float_lt */
	binop_bad,	/* float_gt */
	binop_bad,	/* float_le */
	binop_bad,	/* float_ge */
	binop_bad	/* body */
};

#define SIMPLEBINOP(name, op)	\
	static MB_Word \
	binop_##name(MB_Machine_State *ms, const MB_Bytecode_Arg *bca) \
	{ \
		assert(bca->builtin_binop.arg1.id == MB_ARG_VAR); \
		assert(bca->builtin_binop.arg2.id == MB_ARG_VAR); \
		return (MB_Integer)(MB_var_get(ms, \
					bca->builtin_binop.arg1.opt.var)) \
			op (MB_Integer)(MB_var_get(ms, \
					bca->builtin_binop.arg2.opt.var)); \
	}

SIMPLEBINOP(add,	+)
SIMPLEBINOP(sub,	-)
SIMPLEBINOP(mul,	*)
SIMPLEBINOP(div,	/)
SIMPLEBINOP(mod,	%)
SIMPLEBINOP(lshift,	<<)
SIMPLEBINOP(rshift,	>>)
SIMPLEBINOP(and,	&)
SIMPLEBINOP(or,		|)
SIMPLEBINOP(xor,	^)
SIMPLEBINOP(logand,	&&)
SIMPLEBINOP(logor,	||)
SIMPLEBINOP(eq,		==)
SIMPLEBINOP(ne,		!=)
SIMPLEBINOP(lt,		<)
SIMPLEBINOP(gt,		>)
SIMPLEBINOP(le,		<=)
SIMPLEBINOP(ge,		>=)


static MB_Word
binop_bad(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
{
	MB_fatal("Unsupported binop\n");
	return 0;
}



static void
instr_builtin_binop(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
{
	MB_Byte binop = bca->builtin_binop.binop;
	if (binop < (sizeof(binop_table)/sizeof(binop_table[0]))) {
		MB_var_set(ms,
			bca->builtin_binop.to_var,
			binop_table[bca->builtin_binop.binop](ms, bca));

		instr_noop(ms, NULL);
	} else {
		MB_fatal("Invalid binop");
	}
}

static void
instr_builtin_bintest(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
{
	MB_Byte binop = bca->builtin_binop.binop;
	if (binop < (sizeof(binop_table)/sizeof(binop_table[0]))) {
		if (binop_table[bca->builtin_binop.binop](ms, bca)) {
			/* If successful, just go to the next instr */
			instr_noop(ms, NULL);
		} else {
			/* otherwise follow the failure context */
			/*instr_do_fail(ms, NULL);*/
			instr_do_redo(ms, NULL);
		}
	} else {
		MB_fatal("Invalid bintest");
	}
}
/*----------------------------------------------------------------------------*/
static MB_Word unop_bad		(MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
static MB_Word unop_bitwise_complement
				(MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
static MB_Word unop_not		(MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
/*
** XXX ORDER Currently we depend on the order of elements in the table
*/
static MB_Word (*unop_table[])(MB_Machine_State *ms,
				const MB_Bytecode_Arg *bca) =
{
	unop_bad,		/* mktag */
	unop_bad,		/* tag */
	unop_bad, 		/* unmktag */
	unop_bad, 		/* mkbody */
	unop_bad, 		/* unmkbody */
	unop_bad,		/* strip_tag  */
	unop_bad,		/* hash_string */
	unop_bitwise_complement,
	unop_not
};

#define SIMPLEUNOP(name, op)	\
	static MB_Word \
	unop_##name(MB_Machine_State *ms, const MB_Bytecode_Arg *bca) \
	{ \
		return op MB_var_get(ms, bca->builtin_unop.arg.opt.var); \
	}

SIMPLEUNOP(bitwise_complement,		~)
SIMPLEUNOP(not,				!)

static MB_Word
unop_bad(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
{
	MB_fatal("Unsupported unop\n");
	return 0;
}

static void
instr_builtin_unop(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
{
	MB_Byte unop = bca->builtin_unop.unop;
	
	if (unop < (sizeof(unop_table)/sizeof(unop_table[0]))) {

		MB_var_set(ms, bca->builtin_unop.to_var,
		       unop_table[bca->builtin_unop.unop](ms, bca));

		instr_noop(ms, NULL);
	} else {
		MB_fatal("Invalid unop");
	}
}


static void
instr_builtin_untest(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
{
	MB_fatal("builtin_untest not done");
}

/*----------------------------------------------------------------------------*/
static void
instr_semidet_success(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
{
	MB_stackitem(MB_DETFRAME_SEMIDET_SUCCESS) = MB_SEMIDET_SUCCESS;

	instr_noop(ms, NULL);
}

static void
instr_semidet_success_check(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
{
	if (MB_reg(MB_SEMIDET_SUCCESS_REG) != MB_SEMIDET_SUCCESS) {
		instr_do_redo(ms, NULL);
	} else {
		instr_noop(ms, NULL);
	}
}

static void
instr_do_redo(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
{
	/*
	** XXX: redo to bytecode could be sped up by going directly to the
	** right location instead of jumping back into native code first
	*/

	/* return to native code at address new_addr */
	MB_native_return_set(ms, MB_native_get_do_redo());
}

static void
instr_do_fail(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
{
	/*
	** XXX: fail to bytecode could be sped up by going directly to the
	** right location instead of jumping back into native code first
	*/

	/* return to native code at address new_addr */
	MB_native_return_set(ms, MB_native_get_do_fail());
}

static void
instr_noop(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
{
	/* increment instruction pointer */
	MB_ip_set(ms, MB_ip_get(ms) + 1);
}

static void
instr_notdone(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
{
	MB_fatal("Instruction type not (yet) completed");

	/* invalid instruction */
	instr_noop(ms, NULL);
}

/*
** Execute the current instruction. Returns false if instruction could
** not be executed
*/
static MB_Bool
dispatch(MB_Byte bc_id, MB_Machine_State *ms)
{
	MB_Bytecode_Addr ip = MB_ip_get(ms);
	
	if (bc_id < sizeof(instruction_table) / sizeof(instruction_table[0])) {
		instruction_table[bc_id](ms, MB_code_get_arg(ip));
		return TRUE;
	}
	
	return FALSE;
}

/*----------------------------------------------------------------------------*/
/*
** XXX: This is debugging code *only*. It won't work in threads, and
** is rather fragile. Don't push it too hard, and it will be kind to you.
*/

#define DODEBUG		1

#include "mb_disasm.h"

static void
MB_machine_debug(MB_Machine_State* ms) {


	static MB_Bytecode_Addr stopat =
	#if DODEBUG
		NULL;
	#else
		(MB_Bytecode_Addr) MB_CODE_INVALID_ADR;
	#endif
	static int line_len = 80;

	static MB_Word count = 0;
	static MB_Word stopcount = 0;
	char buffer[60];
	MB_Bytecode_Addr cur_ip = MB_ip_get(ms);

	count++;

	if (count == stopcount) {
		stopat = cur_ip;
	}

	if (stopat != NULL && stopat != cur_ip) return;

	if (cur_ip == MB_CODE_NATIVE_RETURN) {
		stopat = NULL;
		return;
	}

	MB_show_state(ms, stderr);

	MB_SAY("exec count %d", count);

Reread:
	fgets(buffer, sizeof(buffer), stdin);

	switch (buffer[0]) {
		case 0:
		case '\n':
		case 's': /* step */
			stopat = NULL;
			break;
		case 'c': /* instruction count */
			if (sscanf(buffer, "c %d", &stopcount)
				== 1)
			{
				stopat = MB_CODE_INVALID_ADR;
			}
			break;
		case 'd': /* code dump */
			MB_listing(ms, stderr,
				(MB_Bytecode_Addr) NULL,
				(MB_Bytecode_Addr) ((MB_Word)
						    (((char *) NULL - 1)) / 3),
				line_len);
			goto Reread;
		case '-':
			line_len *= 3;
			line_len /= 4;
			goto Reread;
		case '+':
			line_len *= 4;
			line_len /= 3;
			goto Reread;
		case 'l': { /* code listing */
			MB_Bytecode_Addr start;	
			MB_Bytecode_Addr end;	
			switch (sscanf(buffer, "l %p %p", &start, &end)) {
				case EOF:
				case 0:
					start = MB_ip_get(ms);
				case 1:
					start -= 12;
					end = start + 48;
					break;
				case 2:
					break;
			}
			MB_listing(ms, stderr, start, end,
					line_len);
			goto Reread;
		}
		case 'S': /* machine state */
			MB_show_state(ms, stderr);
			goto Reread;
		case 'n': /* next */
			stopat = cur_ip + 1;
			break;
		case 'r': /* run */
			stopat = MB_CODE_INVALID_ADR;
			break;
		case 'e': /* run to reentry */
			stopat = MB_CODE_NATIVE_RETURN;
			break;
		case 'R': /* to return */
			do {
				cur_ip++;
			} while (MB_code_get_id(cur_ip) != MB_BC_endof_proc);
			stopat = cur_ip;
			break;
		case 'x':
			exit(0);
		case '?':
			MB_SAY(
			"s    - step\n"
			"n    - next (step over)\n"
			"r    - run to end\n"
			"c $1 - run to Count $1\n"
			"e    - run to reEntry\n"
			"R    - run to immediate return\n"
			"x    - exit"
			);
			goto Reread;
		case 'v': /* view [data] */
			switch (buffer[1]) {
			case 's': {
				char *strbuf = NULL;
				sscanf(buffer, "vs %p", &strbuf);
				MB_SAY("String at %p: %s", strbuf, strbuf);
				break;
			}
			case 'l': {
				MB_Word list_ptr;
				MB_Word tag;
				sscanf(buffer, "vl %p", &list_ptr);
				MB_SAY("List at %p: [", list_ptr);

				tag = MB_tag(list_ptr);
				while (tag != 0) {
					MB_SAY("\t%08x",
						MB_field(tag, list_ptr, 0));
					list_ptr = MB_field(tag, list_ptr, 1);

					tag = MB_tag(list_ptr);
				}
				MB_SAY("]\n");
				break;
			}
			default:
				MB_SAY("Unknown data type");
			}
			goto Reread;
		default:
			MB_SAY("Unknown command");
			goto Reread;
	}
	MB_SAY("Will stop at %p", stopat);
}
/*----------------------------------------------------------------------------*/
#include "mb_machine_def.h"	/* reqd to instantiate MB_Machine_State */
MB_Native_Addr
MB_machine_exec(MB_Bytecode_Addr new_ip, MB_Word *initial_stack)
{
	/* Create Machine State */
	MB_Machine_State ms;
	ms.ip = new_ip;
	ms.initial_stack = initial_stack;
	MB_proc_var_init(&ms);

	do {
		MB_Bytecode_Addr ip; 

		MB_machine_debug(&ms);

		ip = MB_ip_get(&ms);
		if (MB_ip_normal(ip)) {

			MB_Byte bc_id = MB_code_get_id(ip);


			if (!dispatch(bc_id, &ms)) {
				switch (bc_id) {
					case MB_BC_debug_trap:
						return 0;
				}
				MB_util_error("Attempt to execute"
					" invalid instruction\n");
				instr_noop(&ms, NULL);
				return 0;
			}
		} else {
			switch ((MB_Word) ip) {
				case (MB_Word) MB_CODE_DO_FAIL:
					instr_do_fail(&ms, NULL);
					break;

				case (MB_Word) MB_CODE_DO_REDO:
					instr_do_redo(&ms, NULL);
					break;

				case (MB_Word) MB_CODE_NATIVE_RETURN:
					return MB_native_return_get(&ms);
				default:
					MB_util_error("At address %p:", ip);
					MB_fatal("Attempt to execute invalid"
						" address\n");
			}
		}
	} while (1);

	assert(FALSE);
	return NULL;
}