void scheme_start( word *globals )
{
cont_t f = 0;
word *stkp = (word*)globals[ G_STKP ];
int x;
if (already_running)
panic_abort( "Recursive call to scheme_start (FFI?)" );
already_running = 1;
/* Patch in bootstrap code if necessary */
if (procedure_ref( globals[ G_REG0 ], IDX_PROC_CODE ) == FALSE_CONST)
procedure_set( globals[ G_REG0 ], IDX_PROC_CODE, (word)twobit_start );
/* Return address for bottom-most frame */
stkp[ STK_RETADDR ] = (word)i386_dispatch_loop_return;
stkp[ STK_REG0 ] = 0;
/* The dispatch loop is a doubly-nested quasi-loop.
The outer loop uses setjmp/longjmp for control and is entered but
rarely; most of the time is spent in the inner loop. The job of
the outer loop is to provide the inner loop with the address of
the first block to execute.
The inner loop is implemented entirely in compiled code: we just
jump to the entry point, and any return is done through a longjmp
to the outer loop.
*/
/* Outer loop */
switch (x = setjmp( dispatch_jump_buffer )) {
case 0 :
case DISPATCH_CALL_R0 :
f = procedure_ref( globals[ G_REG0 ], IDX_PROC_CODE );
break;
case DISPATCH_EXIT:
already_running = 0;
return;
case DISPATCH_RETURN_FROM_S2S_CALL :
f = restore_context( globals );
break;
case DISPATCH_STKUFLOW :
f = refill_stack_cache( globals );
break;
case DISPATCH_SIGFPE :
handle_sigfpe( globals );
panic_exit( "handle_sigfpe() returned." );
default :
panic_exit( "Unexpected value %d from setjmp in scheme_start()", x );
}
/* Inner loop */
i386_scheme_jump(globals,f); /* Never returns */
}
void osdep_init( void )
{
char buf[MAX_PATH + 1];
char *end;
size_t l;
real_start.sec = 0;
real_start.usec = 0;
get_rtclock( &real_start );
if ( getenv( LARCENY_ROOT ) == NULL ) {
if ( GetModuleFileName(NULL, buf, MAX_PATH + 1) == 0 )
goto giveup;
if ( (end = strrchr(buf, '\\')) == NULL )
goto giveup;
*end = '\0';
if ( osdep_setenv(LARCENY_ROOT, buf, 1) )
panic_exit( "Couldn't set LARCENY_ROOT" );
}
return;
giveup:
return;
}
/* C_panic: print a message and die. */
void C_panic( char *fmt, ... )
{
va_list args;
char buf[ 128 ];
in_noninterruptible_syscall = 1;
va_start( args, fmt );
vsprintf( buf, fmt, args );
va_end( args );
panic_exit( "%s", buf );
in_noninterruptible_syscall = 0;
}
/* Single stepping. Takes a fixnum argument which is the constant vector
* index at which to find a string. G_REG0 must be valid.
*/
void C_singlestep( word cidx )
{
char buf[ 300 ];
int l;
word s;
word constvec;
in_noninterruptible_syscall = 1;
constvec = *( ptrof( globals[G_REG0] ) + 2 );
s = *( ptrof( constvec ) + VEC_HEADER_WORDS + nativeint(cidx) );
if (tagof( s ) != BVEC_TAG)
panic_exit( "Internal: Bad arg to C_singlestep().\n" );
l = string_length( s );
strncpy( buf, string_data( s ), min( l, sizeof( buf )-1 ) );
buf[ l ] = 0;
hardconsolemsg( "Step: %s", buf );
localdebugger();
in_noninterruptible_syscall = 0;
}
static void enqueue( gc_mmu_log_t *log,
gc_log_phase_t incoming,
unsigned elapsed_real,
unsigned elapsed_cpu )
{
int enq = log->buffer.end;
log->buffer.entries[enq].phase = incoming;
log->buffer.entries[enq].elapsed_real = elapsed_real;
log->buffer.entries[enq].elapsed_cpu = elapsed_cpu;
update_windows_incoming_event( log, incoming, elapsed_real, elapsed_cpu );
enq = (enq+1) % log->buffer.capacity;
if ( enq == log->buffer.first ) {
panic_exit( "Cannot enqueue event in MMU log of capacity %d entries "
"(disable MMU or increase its capacity).",
log->buffer.capacity );
}
log->buffer.end = enq;
update_windows_drop_outdated( log, incoming, elapsed_real, elapsed_cpu );
update_windows_recalc_minmax( log );
}
static void must_restore_frame( young_heap_t *heap )
{
if (!stk_restore_frame( DATA(heap)->globals ))
panic_exit( "nursery: restore_frame");
}
static void must_create_stack( young_heap_t *heap )
{
if (!stk_create( DATA(heap)->globals ))
panic_exit( "nursery: create_stack" );
}
void larceny_segment_code_address( word id, word number )
{
panic_exit( "Syscall `segment_code_address' not available in IAssassin Larceny." );
}
void scheme_start( word *globals )
{
cont_t f = 0;
word *stkp = (word*)globals[ G_STKP ];
int x;
jmp_buf *old_jump_buffer = dispatch_jump_buffer;
if (already_running)
annoyingmsg( "Recursive call to scheme_start (FFI?)" );
already_running = 1;
dispatch_jump_buffer = gclib_alloc_rts(sizeof(jmp_buf), 0);
if (dispatch_jump_buffer == NULL)
panic_abort("Couldn't allocate fresh jmp_buf");
#if 0
/* Patch in bootstrap code if necessary */
if (procedure_ref( globals[ G_REG0 ], IDX_PROC_CODE ) == FALSE_CONST)
procedure_set( globals[ G_REG0 ], IDX_PROC_CODE, (word)twobit_start );
#endif
/* Return address for bottom-most frame */
stkp[ STK_RETADDR ] = (word)i386_dispatch_loop_return;
stkp[ STK_REG0 ] = 0;
/* The dispatch loop is a doubly-nested quasi-loop.
The outer loop uses setjmp/longjmp for control and is entered but
rarely; most of the time is spent in the inner loop. The job of
the outer loop is to provide the inner loop with the address of
the first block to execute.
The inner loop is implemented entirely in compiled code: we just
jump to the entry point, and any return is done through a longjmp
to the outer loop.
*/
/* Outer loop */
switch (x = setjmp( *dispatch_jump_buffer )) {
case 0 :
case DISPATCH_CALL_R0 :
assert2( tagof( globals[ G_REG0 ]) == PROC_TAG );
f = procedure_ref( globals[ G_REG0 ], IDX_PROC_CODE );
f = (cont_t)(ptrof(f)+1); /* skip over bytevector header */
break;
case DISPATCH_EXIT:
already_running = 0;
gclib_free(dispatch_jump_buffer, sizeof(jmp_buf));
dispatch_jump_buffer = old_jump_buffer;
return;
case DISPATCH_RETURN_FROM_S2S_CALL :
panic_exit( "DISPATCH_RETURN_FROM_S2S_CALL shouldn't happen." );
break;
case DISPATCH_STKUFLOW :
f = refill_stack_cache( globals );
globals[ G_STKP ] += 4+4*STK_RETADDR; /* The '4*' compensates for layouts.cfg oversight */
break;
case DISPATCH_SIGFPE :
handle_sigfpe( globals );
panic_exit( "handle_sigfpe() returned." );
default :
panic_exit( "Unexpected value %d from setjmp in scheme_start()", x );
}
/* Inner loop */
i386_scheme_jump(globals,f); /* Never returns */
}
