/* Simulation of new write barrier */
void C_simulate_new_barrier( void )
{
word *genv;
word lhs;
word rhs;
unsigned gl, gr;
word **ssbtopv, **ssblimv;
int isvec = 0;
genv = (word*)globals[ G_GENV ];
lhs = globals[ G_RESULT ];
rhs = globals[ G_ARGREG2 ];
wb_total_assignments++;
if (tagof(lhs) == VEC_TAG || tagof(lhs) == PROC_TAG) {
isvec = 1;
wb_array_assignments++;
if (genv[pageof(lhs)] == 0) {
wb_lhs_young_or_remembered++;
return;
}
else if (gc_isremembered( the_gc(globals), lhs )) {
wb_lhs_young_or_remembered++;
return;
}
else if (!isptr( rhs )) {
wb_rhs_constant++;
return;
}
}
else if (!isptr(rhs))
return;
record_trans:
gl = genv[pageof(lhs)];
gr = genv[pageof(rhs)];
if (gl <= gr) {
if (isvec) wb_cross_gen_check++; /* not old->young */
return;
}
if (isvec)
wb_trans_recorded++;
ssbtopv = (word**)globals[G_SSBTOPV];
ssblimv = (word**)globals[G_SSBLIMV];
*ssbtopv[gl] = lhs;
ssbtopv[gl] += 1;
if (ssbtopv[gl] == ssblimv[gl]) C_wb_compact( gl );
}
static ffi_type*
scheme_to_ffi_type_cast(ikptr nptr){
if (tagof(nptr) == vector_tag) {
return scheme_to_ffi_record_type_cast(nptr);
} else if (is_fixnum(nptr)) {
long n = unfix(nptr);
switch (n & 0xF) {
case 1: return &ffi_type_void;
case 2: return &ffi_type_uint8;
case 3: return &ffi_type_sint8;
case 4: return &ffi_type_uint16;
case 5: return &ffi_type_sint16;
case 6: return &ffi_type_uint32;
case 7: return &ffi_type_sint32;
case 8: return (sizeof(long)==4)?&ffi_type_uint32:&ffi_type_uint64;
case 9: return (sizeof(long)==4)?&ffi_type_sint32:&ffi_type_sint64;
case 10: return &ffi_type_uint64;
case 11: return &ffi_type_sint64;
case 12: return &ffi_type_float;
case 13: return &ffi_type_double;
case 14: return &ffi_type_pointer;
default:
fprintf(stderr, "INVALID ARG %ld", n);
exit(-1);
}
} else {
fprintf(stderr, "INVALID ARG %ld", nptr);
exit(-1);
}
}
static
void
ik_sigset(sigset_t* s, ikptr sigcodes){
while(tagof(sigcodes) == pair_tag){
sigaddset(s, ik_signal_code_to_num(ref(sigcodes, off_car)));
sigcodes = ref(sigcodes, off_cdr);
}
}
/* NOTE: A copy of this code exists in Sparc/memory.s; if you change
* anything here, check that code as well.
*/
int stk_restore_frame( word *globals )
{
word *stktop, *hframe, *p;
word retoffs, proc, codeaddr, codeptr, header;
unsigned size;
assert2(globals[ G_STKP ] == globals[ G_STKBOT ]);
hframe = ptrof( globals[ G_CONT ] );
size = roundup8( sizefield( *hframe ) + 4 ); /* bytes to copy */
stktop = (word*)globals[ G_STKP ];
stktop -= size / 4;
if (stktop < (word*)globals[ G_ETOP ]) {
supremely_annoyingmsg( "Failed to create stack." );
return 0;
}
globals[ G_STKP ] = (word)stktop;
globals[ G_STKUFLOW ] += 1;
#if 0
annoyingmsg("Restore: %d", size);
#endif
/* copy the frame onto the stack */
p = stktop;
while (size) {
*p++ = *hframe++;
*p++ = *hframe++;
size -= 8;
}
/* Follow continuation chain. */
globals[ G_CONT ] = *(stktop+STK_DYNLINK);
header = *(stktop+HC_HEADER);
retoffs = *(stktop+HC_RETOFFSET);
proc = *(stktop+HC_PROC);
/* convert the header back to a fixnum */
*(stktop+STK_CONTSIZE) = sizefield(header);
/* convert the return address */
if (proc != 0) {
codeptr = *(ptrof( proc )+PROC_CODEPTR);
if (tagof( codeptr ) == BVEC_TAG) {
codeaddr = (word)ptrof( codeptr );
*(stktop+STK_RETADDR) = (codeaddr+4)+retoffs;
} else {
*(stktop+STK_RETADDR) = retoffs;
}
} else {
*(stktop+STK_RETADDR) = retoffs;
}
return 1;
}
static int
list_length(ikptr x){
int n = 0;
while(tagof(x) == pair_tag){
n++;
x = ref(x, off_cdr);
}
return n;
}
void larceny_call( word proc, int argc, word *argv, word *result )
{
int i, fresh_stack;
word *p;
/* Allocate and setup a stack frame */
if ((globals[ G_STKP ]-SCE_BUFFER)-FRAMESIZE < globals[ G_ETOP ]) {
hardconsolemsg( "Callback failed -- stack overflow." );
/* Fixme: need to indicate error */
/* Fixme: in general, we must recover from this problem! */
*result = UNDEFINED_CONST;
return;
}
fresh_stack = globals[ G_STKP ] == globals[ G_STKBOT ];
globals[ G_STKP ] -= FRAMESIZE;
p = (word*)globals[ G_STKP ];
p[STK_CONTSIZE] = 5*sizeof(word); /* size in bytes */
p[STK_RETADDR] = 0; /* return address -- set by scheme_start() */
if (fresh_stack)
p[STK_DYNLINK] = globals[ G_CONT ]; /* dynamic link */
else
p[STK_DYNLINK] = 0; /* random */
p[STK_PROC] = 0; /* procedure pointer (fixed) */
p[4] = globals[ G_REG0 ];
p[5] = globals[ G_RETADDR ];
/* Setup arguments in registers -- this gcprotects them */
globals[ G_REG0 ] = proc;
for ( i=0 ; i < argc ; i++ ) /* FIXME: guard against argc > #regs */
globals[ G_REG1+i ] = argv[i];
globals[ G_RESULT ] = fixnum(argc);
/* Check the type and invoke the procedure */
if (tagof( globals[ G_REG0 ] ) != PROC_TAG) {
hardconsolemsg( "Callback failed -- not a procedure." );
/* Fixme: need to indicate error */
*result = UNDEFINED_CONST;
return;
}
scheme_start( globals );
*result = globals[ G_RESULT ];
/* Pop the frame */
p = (word*)globals[ G_STKP ];
globals[ G_REG0 ] = p[4];
globals[ G_RETADDR ] = p[5];
globals[ G_STKP ] += FRAMESIZE;
}
/* Returns TRUE iff untagged_w was already in ebmp */
bool extbmp_add_elem( extbmp_t *ebmp, word untagged_w )
{ /* ebmp := ebmp U { untagged_w } */
leaf_t *leaf;
word first, lim;
word entry_word;
bool retval;
unsigned int bit_idx, word_idx, bit_in_word;
assert( tagof(untagged_w) == 0 );
first = 0xFFFFFFF;
lim = 0x0;
find_or_alloc_leaf( ebmp, untagged_w, &leaf, &first );
lim = leaf_wordaddr_lim( ebmp, first );
assert( first <= untagged_w );
assert( untagged_w < lim );
bit_idx = (untagged_w - first) >> BIT_IDX_SHIFT;
word_idx = bit_idx >> BIT_IDX_TO_WORDADDR;
bit_in_word = 1 << (bit_idx & BIT_IN_WORD_MASK);
#if 0
if ( ! (bit_in_word & leaf->bitmap[ word_idx ] ))
consolemsg(" extbmp_add_elem new elem: 0x%08x (%d) mhdr:0x%08x",
untagged_w, gen_of(untagged_w), *(ptrof(untagged_w)) );
#endif
entry_word = leaf->bitmap[ word_idx ];
retval = entry_word & bit_in_word;
entry_word |= bit_in_word;
leaf->bitmap[ word_idx ] = entry_word;
assert2( extbmp_is_member(ebmp, untagged_w ));
{
int gno;
gno = gen_of( untagged_w );
assert( gno != 0 );
if (leaf->gno == 0) {
/* mixed leaf; do nothing */
} else if (leaf->gno < 0) {
insert_leaf_in_list( ebmp, leaf, gno );
} else if (leaf->gno != gno) {
move_leaf_to_mixed_list( ebmp, leaf, gno );
}
}
return retval;
}
static void assert2_basic_invs( msgc_context_t *context, word src, word obj )
{
#ifndef NDEBUG2
word TMP = obj;
if (isptr(TMP)) {
gc_check_remset_invs( context->gc, src, obj );
assert2( (context)->lowest_heap_address <= ptrof(TMP) );
assert2( ptrof(TMP) < (context)->highest_heap_address );
if (! gc_is_address_mapped( context->gc, ptrof(TMP), FALSE )) {
assert2(gc_is_address_mapped( context->gc, ptrof(TMP), TRUE ));
}
if (tagof(TMP) == PAIR_TAG) {
/* no header on pairs... */
} else if (tagof(TMP) == VEC_TAG) {
assert2(ishdr(*ptrof(TMP)));
assert2(header(*ptrof(TMP)) == header(VEC_HDR));
} else if (tagof(TMP) == PROC_TAG) {
assert2(ishdr(*ptrof(TMP)));
assert2(header(*ptrof(TMP)) == header(PROC_HDR));
}
}
#endif
}
ikptr
ik_system(ikptr str){
if(tagof(str) == bytevector_tag){
int r = system((char*)(long)(str+off_bytevector_data));
if(r >= 0) {
return fix(r);
} else {
return ik_errno_to_code();
}
} else {
fprintf(stderr, "bug in ik_system\n");
exit(-1);
}
}
ikptr
ikrt_delete_file(ikptr filename){
char* str;
if(tagof(filename) == bytevector_tag){
str = (char*)(long)(filename + off_bytevector_data);
} else {
fprintf(stderr, "bug in ikrt_delete_file\n");
exit(-1);
}
int err = unlink(str);
if(err == 0){
return true_object;
}
return ik_errno_to_code();
}
static void assert2_tag_hdr_consistency( msgc_context_t *context, word w )
{
#ifndef NDEBUG2
switch (tagof(w)) {
case VEC_TAG:
if (!(ishdr(*ptrof(w)) && header(*ptrof(w)) == header(VEC_HDR) )) {
consolemsg("VEC w: 0x%08x *ptrof(w): 0x%08x ishdr: %s header(*ptrof(w)): %x", w, *ptrof(w), ishdr(*ptrof(w))?"TRUE":"FALSE", header(*ptrof(w)));
}
assert( ishdr(*ptrof(w)) && header(*ptrof(w)) == header(VEC_HDR) );
break;
case PROC_TAG:
if (!( ishdr(*ptrof(w)) && header(*ptrof(w)) == header(PROC_HDR) )) {
consolemsg("PROC w: 0x%08x *ptrof(w): 0x%08x ishdr: %s header(*ptrof(w)): %x", w, *ptrof(w), ishdr(*ptrof(w))?"TRUE":"FALSE", header(*ptrof(w)));
}
assert( ishdr(*ptrof(w)) && header(*ptrof(w)) == header(PROC_HDR) );
break;
}
#endif
}
/* 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 int push_constituents( msgc_context_t *context, word w )
{
int i, n;
switch (tagof(w)) {
case PAIR_TAG :
PUSH( context, pair_cdr( w ) ); /* Do the CDR last */
PUSH( context, pair_car( w ) ); /* Do the CAR first */
return 2;
case VEC_TAG :
case PROC_TAG :
n = bytes2words( sizefield(*ptrof(w)) );
if (n > LARGE_OBJECT_LIMIT)
LOS_PUSH( context, 0, w ); /* Treat large objects specially */
else
for ( i=0 ; i < n ; i++ )
PUSH( context, vector_ref( w, i ) );
return n+1;
default :
return 0;
}
}
static void
scheme_to_ffi_value_cast(ffi_type* t, ikptr nptr, ikptr p, void* r) {
if (tagof(nptr) == vector_tag) {
scheme_to_ffi_record_value_cast(t, nptr, p, r);
} else if (is_fixnum(nptr)) {
long n = unfix(nptr);
switch (n & 0xF) {
case 1: { return; }
case 2: // ffi_type_uint8;
case 3:
{ *((char*)r) = extract_num(p); return; }
case 4: // ffi_type_uint16;
case 5:
{ *((short*)r) = extract_num(p); return; }
case 6: // ffi_type_uint32;
case 7:
{ *((int*)r) = extract_num(p); return; }
case 8: // ffi_type_uint64;
case 9:
{ *((long*)r) = extract_num(p); return; }
case 10:
case 11:
{ *((long long*)r) = extract_num_longlong(p); return; }
case 12: //return &ffi_type_float;
{ *((float*)r) = flonum_data(p); return; }
case 13: //return &ffi_type_double;
{ *((double*)r) = flonum_data(p); return; }
case 14: //return &ffi_type_pointer;
{ *((void**)r) = (void*)ref(p, off_pointer_data); return; }
default:
fprintf(stderr, "INVALID ARG %ld", n);
exit(-1);
}
} else {
fprintf(stderr, "INVALID TYPE 0x%016lx\n", nptr);
exit(-1);
}
}
static int push_constituents( msgc_context_t *context, word w )
{
int i, n;
switch (tagof(w)) {
case PAIR_TAG :
return push_pair_constiuents( context, w );
case VEC_TAG :
case PROC_TAG :
assert2_tag_hdr_consistency( context, w );
n = bytes2words( sizefield(*ptrof(w)) );
if (n > LARGE_OBJECT_LIMIT)
LOS_PUSH( context, 0, w ); /* Treat large objects specially */
else {
assert2_object_contents_mapped( context, w, n );
for ( i=0 ; i < n ; i++ ) {
PUSH( context, vector_ref( w, i ), w, i+1 );
}
}
return n+1;
default :
return 0;
}
}
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 */
}
void stk_flush( word *globals )
{
word *stktop, *stkbot, *first, *prev;
word retaddr, codeaddr, codeptr, proc, size;
unsigned framecount;
assert2( tagof( globals[ G_REG0 ]) == PROC_TAG );
stktop = (word*)globals[ G_STKP ];
stkbot = (word*)globals[ G_STKBOT ];
stack_state.words_flushed += (stkbot-stktop);
first = prev = 0;
framecount = 0;
while (stktop < stkbot) {
size = *(stktop+STK_CONTSIZE);
retaddr = *(stktop+STK_RETADDR);
/* convert header to vector header */
assert2( size % 4 == 0 ); /* size must be words, a fixnum */
assert2( (s_word)size >= 12 ); /* 3-word minimum, and nonnegative */
*(stktop+HC_HEADER) = mkheader( size, VEC_HDR );
/* convert return address */
proc = *(stktop+STK_REG0);
if (proc != 0) {
assert2( tagof( proc ) == PROC_TAG );
codeptr = *(ptrof( proc )+PROC_CODEPTR);
if (tagof( codeptr ) == BVEC_TAG) {
codeaddr = (word)ptrof( codeptr );
*(stktop+HC_RETOFFSET) = retaddr-(codeaddr+4);
} else {
*(stktop+HC_RETOFFSET) = retaddr;
}
} else {
*(stktop+HC_RETOFFSET) = retaddr;
}
/* chain things together */
if (first == 0)
first = stktop;
else
*(prev+HC_DYNLINK) = (word)tagptr( stktop, VEC_TAG );
prev = stktop;
framecount++;
size = roundup8( size+4 );
stktop += size / 4;
#if 0
annoyingmsg("Flush: %d", size );
#endif
}
if (prev != 0)
*(prev+HC_DYNLINK) = globals[ G_CONT ];
if (first != 0)
globals[ G_CONT ] = (word)tagptr( first, VEC_TAG );
globals[ G_STKBOT ] = globals[ G_STKP ];
stack_state.frames_flushed += framecount;
}
