void register_apply( obj closure )
{
unsigned i;
obj call_ctx;
PUSH_PARTCONT(full_call_done,1);
SET_PARTCONT_REG(0,dynamic_state_reg);
call_ctx = alloc( SLOT(arg_count_reg + 1), vector_class );
gvec_write_init( call_ctx, SLOT(0), closure );
for (i=0; i<arg_count_reg; i++)
{
gvec_write_init( call_ctx, SLOT(i+1), reg_ref(i) );
}
dynamic_state_reg = cons( call_ctx, dynamic_state_reg );
if (bci_trace_flag > 0)
{
fprintf( stdout, "calling: " );
fprinto( stdout, gvec_read(literals_reg,SLOT(2)) );
fprintf( stdout, "\n" );
for (i=0; i<arg_count_reg; i++)
{
printf( " reg[%u] = ", i );
fprinto( stdout, reg_ref(i) );
printf( "\n" );
}
fflush(stdout);
}
}
obj collect_top( unsigned first_reg )
{
obj list = NIL_OBJ;
unsigned i;
if (first_reg < 10)
{
if (arg_count_reg > 10)
{
list = collect_top(10);
i = 10;
}
else
i = arg_count_reg;
while (i > first_reg)
list = cons( reg_ref(--i), list );
return list;
}
i = arg_count_reg;
while (i > first_reg)
{
unsigned r = --i;
list = cons( REG(r), list );
}
return list;
}
void *tcl_gateway( void )
{
char **argp, *(args[102]);
Tcl_CmdInfo *info;
Tcl_Interp *interp;
char temp[1000], *d;
int i, rc;
assert( arg_count_reg <= 100 );
info = (Tcl_CmdInfo *)PTR_TO_DATAPTR(LEXREF0(0));
interp = (Tcl_Interp *)OBJ_TO_RAW_PTR(LEXREF0(1));
d = temp;
argp = args;
*argp++ = (char *)string_text( LEXREF0(2) );
for (i=0; i<arg_count_reg; i++)
{
obj arg;
arg = reg_ref(i);
if (STRING_P(arg))
{
*argp++ = (char *)string_text(arg);
}
else if (OBJ_ISA_FIXNUM(arg))
{
*argp++ = d;
sprintf( d, "%d", fx2int(arg) );
d += strlen(d) + 1;
}
else if (SYMBOL_P(arg))
{
*argp++ = (char *)symbol_text(arg);
}
else
{
scheme_error( "tcl_gateway: ~s invalid", 1, arg );
}
}
*argp++ = NULL;
Tcl_ResetResult( interp );
rc = info->proc( info->clientData,
interp,
arg_count_reg + 1,
args );
if (rc)
{
REG0 = make_string( interp->result );
REG1 = int2fx( rc );
RETURN(2);
}
else
{
if (interp->result[0])
REG0 = make_string( interp->result );
else
REG0 = TRUE_OBJ;
RETURN1();
}
}
void run_scu_operation(machinecode *program, int *pc, int *convert, union bit *reg) {
switch(program[*pc].opcode) {
case 0: /* set reg */
reg_set(reg, program[*pc].dr, reg_ref(reg,program[*pc].sr2,convert), convert);
(*pc)++;
break;
case (0 + IMD_SIZE): /* set imd */
reg_set(reg, program[*pc].dr, program[*pc].imd, convert);
(*pc)++;
break;
case 1: /* + reg */
reg_set(reg, program[*pc].dr, do_plus(reg_ref(reg,program[*pc].sr1,convert),reg_ref(reg,program[*pc].sr2,convert)), convert);
(*pc)++;
break;
case (1 + IMD_SIZE): /* + imd */
reg_set(reg, program[*pc].dr, do_plus(reg_ref(reg,program[*pc].sr1,convert),program[*pc].imd), convert);
(*pc)++;
break;
case 2: /* - reg */
reg_set(reg, program[*pc].dr, do_minus(reg_ref(reg,program[*pc].sr1,convert),reg_ref(reg,program[*pc].sr2,convert)), convert);
(*pc)++;
break;
case (2 + IMD_SIZE): /* - imd */
reg_set(reg, program[*pc].dr, do_minus(reg_ref(reg,program[*pc].sr1,convert),program[*pc].imd), convert);
(*pc)++;
break;
case 3: /* xor reg */
reg_set(reg, program[*pc].dr, do_xor(reg_ref(reg,program[*pc].sr1,convert),reg_ref(reg,program[*pc].sr2,convert)), convert);
(*pc)++;
break;
case (3 + IMD_SIZE): /* xor imd */
reg_set(reg, program[*pc].dr, do_xor(reg_ref(reg,program[*pc].sr1,convert),program[*pc].imd), convert);
(*pc)++;
break;
case 4: /* or reg */
reg_set(reg, program[*pc].dr, do_or(reg_ref(reg,program[*pc].sr1,convert),reg_ref(reg,program[*pc].sr2,convert)), convert);
(*pc)++;
break;
case (4 + IMD_SIZE): /* or imd */
reg_set(reg, program[*pc].dr, do_or(reg_ref(reg,program[*pc].sr1,convert),program[*pc].imd), convert);
(*pc)++;
break;
case 5: /* and reg */
reg_set(reg, program[*pc].dr, do_and(reg_ref(reg,program[*pc].sr1,convert),reg_ref(reg,program[*pc].sr2,convert)), convert);
(*pc)++;
break;
case (5 + IMD_SIZE): /* adn imd */
reg_set(reg, program[*pc].dr, do_and(reg_ref(reg,program[*pc].sr1,convert),program[*pc].imd), convert);
(*pc)++;
break;
case 6: /* not reg */
reg_set(reg, program[*pc].dr, do_not(reg_ref(reg,program[*pc].sr2,convert)), convert);
(*pc)++;
break;
case (6 + IMD_SIZE): /* not imd */
reg_set(reg, program[*pc].dr, do_not(program[*pc].imd), convert);
(*pc)++;
break;
default:
fprintf(stderr, "%2x : unknown instruction\n", (program[*pc].info)+(program[*pc].opcode));
exit(EXIT_FAILURE);
}
}
static void rs_vmd_pass( FILE *f, int pass )
{
obj saved_cr;
unsigned i;
obj envts[20];
unsigned num_envts = 0;
fprintf( f, "--------- VM State ----------\n" );
fprintf( f, "Registers:\n" );
rs_vmd_prn( f, pass, "envt_reg", envt_reg );
if (OBJ_ISA_PTR_OF_CLASS( envt_reg, binding_envt_class )) {
envts[num_envts++] = envt_reg;
}
rs_vmd_prn( f, pass, "literals_reg", literals_reg );
rs_vmd_prn( f, pass, "dynamic_state_reg", dynamic_state_reg );
rs_vmd_prn( f, pass, "thread_state_reg", thread_state_reg );
fprintf( f, " arg_count_reg: %8u\n", arg_count_reg );
fprintf( f, " continuation_reg: %08lx\n", VAL(continuation_reg) );
for (i=0; i<arg_count_reg; i++) {
char tmp[20];
sprintf( tmp, "REG(%d)", i );
rs_vmd_prn( f, pass, tmp, reg_ref(i) );
}
fflush( f ); /* get all of that out of the process boundary */
/* now, try to dive into some more detail... */
fprintf( f, "Continuation Chain:\n" );
saved_cr = continuation_reg;
for (i=0; i<10; i++) {
unsigned n, j;
obj x;
fprintf( f, " (%u) will continue in #[FRAME %08lx]", i, VAL(continuation_reg) );
fflush( f );
/* 'n' is the number of slots above and beyond CONT_FIXED */
n = get_partcont_size( continuation_reg );
fprintf( f, " (%u slots)\n", n );
x = gvec_ref( continuation_reg, SLOT(0) );
rs_vmd_prn( f, pass, ".envt", x );
if (OBJ_ISA_PTR_OF_CLASS( x, binding_envt_class ) && (num_envts < 20)) {
envts[num_envts++] = x;
}
rs_vmd_prn( f, pass, ".literals", gvec_ref( continuation_reg, SLOT(1) ) );
rs_vmd_prn( f, pass, ".label", gvec_ref( continuation_reg, SLOT(2) ) );
rs_vmd_prn( f, pass, ".contn", gvec_ref( continuation_reg, SLOT(3) ) );
for (j=0; j<n; j++) {
char tmp[20];
sprintf( tmp, "slot[%u]", j );
rs_vmd_prn( f, pass, tmp, gvec_ref( continuation_reg, SLOT(j + CONT_FIXED) ) );
}
RESTORE_CONT_REG();
if (!OBJ_ISA_PTR( continuation_reg )) {
break;
}
}
fprintf( f, "Binding Environments:\n" );
for (i=0; i<num_envts; i++) {
rs_vmd_envts( f, pass, envts[i] );
}
continuation_reg = saved_cr;
}
void run_cmp_operation(machinecode *program, int *pc, int *convert, union bit *reg) {
switch(program[*pc].opcode) {
case 0: /* = reg */
reg_set(reg, program[*pc].dr, do_equal(reg_ref(reg,program[*pc].sr1,convert),reg_ref(reg,program[*pc].sr2,convert)), convert);
(*pc)++;
break;
case (0 + IMD_SIZE): /* = imd */
reg_set(reg, program[*pc].dr, do_equal(reg_ref(reg,program[*pc].sr1,convert),program[*pc].imd), convert);
(*pc)++;
break;
case 1: /* =. reg */
reg_set(reg, program[*pc].dr, do_equal_dot(reg_ref(reg,program[*pc].sr1,convert),reg_ref(reg,program[*pc].sr2,convert)), convert);
(*pc)++;
break;
case (1 + IMD_SIZE): /* =. imd */
reg_set(reg, program[*pc].dr, do_equal_dot(reg_ref(reg,program[*pc].sr1,convert),program[*pc].imd), convert);
(*pc)++;
break;
case 2: /* > reg */
reg_set(reg, program[*pc].dr, do_greater(reg_ref(reg,program[*pc].sr1,convert),reg_ref(reg,program[*pc].sr2,convert)), convert);
(*pc)++;
break;
case (2 + IMD_SIZE): /* > imd */
reg_set(reg, program[*pc].dr, do_greater(reg_ref(reg,program[*pc].sr1,convert),program[*pc].imd), convert);
(*pc)++;
break;
case 3: /* >. reg */
reg_set(reg, program[*pc].dr, do_greater_dot(reg_ref(reg,program[*pc].sr1,convert),reg_ref(reg,program[*pc].sr2,convert)), convert);
(*pc)++;
break;
case (3 + IMD_SIZE): /* >. imd */
reg_set(reg, program[*pc].dr, do_greater_dot(reg_ref(reg,program[*pc].sr1,convert),program[*pc].imd), convert);
(*pc)++;
break;
case 4: /* < reg */
reg_set(reg, program[*pc].dr, do_less(reg_ref(reg,program[*pc].sr1,convert),reg_ref(reg,program[*pc].sr2,convert)), convert);
(*pc)++;
break;
case (4 + IMD_SIZE): /* < imd */
reg_set(reg, program[*pc].dr, do_less(reg_ref(reg,program[*pc].sr1,convert),program[*pc].imd), convert);
(*pc)++;
break;
case 5: /* <. reg */
reg_set(reg, program[*pc].dr, do_less_dot(reg_ref(reg,program[*pc].sr1,convert),reg_ref(reg,program[*pc].sr2,convert)), convert);
(*pc)++;
break;
case (5 + IMD_SIZE): /* <. imd */
reg_set(reg, program[*pc].dr, do_less_dot(reg_ref(reg,program[*pc].sr1,convert),program[*pc].imd), convert);
(*pc)++;
break;
case 6: /* >= reg */
reg_set(reg, program[*pc].dr, do_greater_equal(reg_ref(reg,program[*pc].sr1,convert),reg_ref(reg,program[*pc].sr2,convert)), convert);
(*pc)++;
break;
case (6 + IMD_SIZE): /* >= imd */
reg_set(reg, program[*pc].dr, do_greater_equal(reg_ref(reg,program[*pc].sr1,convert),program[*pc].imd), convert);
(*pc)++;
break;
case 7: /* >=. reg */
reg_set(reg, program[*pc].dr, do_greater_equal_dot(reg_ref(reg,program[*pc].sr1,convert),reg_ref(reg,program[*pc].sr2,convert)), convert);
(*pc)++;
break;
case (7 + IMD_SIZE): /* >=. imd */
reg_set(reg, program[*pc].dr, do_greater_equal_dot(reg_ref(reg,program[*pc].sr1,convert),program[*pc].imd), convert);
(*pc)++;
break;
case 8: /* <= reg */
reg_set(reg, program[*pc].dr, do_less_equal(reg_ref(reg,program[*pc].sr1,convert),reg_ref(reg,program[*pc].sr2,convert)), convert);
(*pc)++;
break;
case (8 + IMD_SIZE): /* <= imd */
reg_set(reg, program[*pc].dr, do_less_equal(reg_ref(reg,program[*pc].sr1,convert),program[*pc].imd), convert);
(*pc)++;
break;
case 9: /* <=. reg */
reg_set(reg, program[*pc].dr, do_less_equal_dot(reg_ref(reg,program[*pc].sr1,convert),reg_ref(reg,program[*pc].sr2,convert)), convert);
(*pc)++;
break;
case (9 + IMD_SIZE): /* <=. imd */
reg_set(reg, program[*pc].dr, do_less_equal_dot(reg_ref(reg,program[*pc].sr1,convert),program[*pc].imd), convert);
(*pc)++;
break;
default:
fprintf(stderr, "%2x : unknown instruction\n", (program[*pc].info+program[*pc].opcode));
exit(EXIT_FAILURE);
}
}
