/*
All extended commands are handled here. This is a really long
switch statement. It could be made shorter by making the contents function
calls but (outside of a good optimizer) this would incur additional overhead.
We want to be as fast as possible.
If you are reading this, but haven't looked at uForth scripts, you are
missing a lot of context. This is just a bunch of utility calls that will
make more sense when browsed within the context of a calling script!
*/
uforth_stat c_ext_handle_cmds(CELL n) {
CELL r1, r2,r3; /* NOTE: THESE ARE 16 bit values! */
char *str1;
switch (n) {
case UF_INTERP: /* recursively call the uforth interpreter */
r1 = dpop();
str1 = uforth_count_str(r1,&r1);
str1[r1] = '\0';
dpush(uforth_interpret(str1));
break;
case UF_SUBSTR: /* return a substring of the uForth string */
r1 = dpop(); /* addr */
r2 = dpop(); /* length */
r3 = dpop(); /* start */
str1 = uforth_count_str(r1,&r1);
if (r1 < r2) r2 = r1;
PAD_STRLEN = r2;
memcpy(PAD_STR, str1 + r3, r2);
dpush(RAM_START_IDX+PAD_ADDR);
break;
case UF_NUM_TO_STR: /* 32bit to string */
{
char num[12];
i32toa(dpop32(),num,uforth_uram->base);
PAD_STRLEN=strlen(num);
memcpy(PAD_STR, num, PAD_SIZE);
dpush(RAM_START_IDX+PAD_ADDR);
}
break;
default:
return E_ABORT;
}
return OK;
}
uforth_stat c_handle(void) {
DCELL r2, r1 = dpop();
char *str;
FILE *fp;
static char buf[80*2];
switch(r1) {
case UF_EMIT: /* emit */
txc(dpop()&0xff);
break;
case UF_KEY: /* key */
dpush((CELL)rxc());
break;
case UF_TYPE: /* type */
r1 = dpop();
r2 = dpop();
if (r2 >= RAM_START_IDX) {
str = (char*)&uforth_ram[r2-RAM_START_IDX];
} else {
str = (char*)&(uforth_dict[r2]);
}
txs(str,r1);
break;
case UF_SAVE_IMAGE: /* save image */
{
uforth_next_word();
strncpy(buf, uforth_iram->currword, uforth_iram->currwordlen);
buf[uforth_iram->currwordlen] = '\0';
printf("Saving dictionary into %s\n", buf);
fp = fopen(buf, "w+");
fwrite(dict, (dict_here())*sizeof(CELL) ,1,fp);
fclose(fp);
}
break;
case UF_INCLUDE: /* include */
{
uforth_next_word();
strncpy(buf,uforth_iram->currword, uforth_iram->currwordlen);
buf[uforth_iram->currwordlen] = '\0';
printf(" Loading %s\n",buf);
fp = fopen(buf, "r");
if (fp != NULL) {
interpret_from(fp);
fclose(fp);
} else {
printf("File not found: %s\n", buf);
}
}
break;
default:
return c_ext_handle_cmds(r1);
}
return OK;
}
/* The cache_entries parameter is either f (on cold call site) or an array (on cache miss).
Called from assembly with the actual return address */
void *factor_vm::inline_cache_miss(cell return_address)
{
check_code_pointer(return_address);
/* Since each PIC is only referenced from a single call site,
if the old call target was a PIC, we can deallocate it immediately,
instead of leaving dead PICs around until the next GC. */
deallocate_inline_cache(return_address);
gc_root<array> cache_entries(dpop(),this);
fixnum index = untag_fixnum(dpop());
gc_root<array> methods(dpop(),this);
gc_root<word> generic_word(dpop(),this);
gc_root<object> object(((cell *)ds)[-index],this);
void *xt;
cell pic_size = inline_cache_size(cache_entries.value());
update_pic_transitions(pic_size);
if(pic_size >= max_pic_size)
xt = megamorphic_call_stub(generic_word.value());
else
{
cell klass = object_class(object.value());
cell method = lookup_method(object.value(),methods.value());
gc_root<array> new_cache_entries(add_inline_cache_entry(
cache_entries.value(),
klass,
method),this);
xt = compile_inline_cache(index,
generic_word.value(),
methods.value(),
new_cache_entries.value(),
tail_call_site_p(return_address))->xt();
}
/* Install the new stub. */
set_call_target(return_address,xt);
#ifdef PIC_DEBUG
printf("Updated %s call site 0x%lx with 0x%lx\n",
tail_call_site_p(return_address) ? "tail" : "non-tail",
return_address,
(cell)xt);
#endif
return xt;
}
void factor_vm::primitive_set_innermost_stack_frame_quot()
{
gc_root<callstack> callstack(dpop(),this);
gc_root<quotation> quot(dpop(),this);
callstack.untag_check(this);
quot.untag_check(this);
jit_compile(quot.value(),true);
stack_frame *inner = innermost_stack_frame_quot(callstack.untagged());
cell offset = (char *)FRAME_RETURN_ADDRESS(inner,this) - (char *)inner->xt;
inner->xt = quot->xt;
FRAME_RETURN_ADDRESS(inner,this) = (char *)quot->xt + offset;
}
/**************************************************************************
* NAME: execution_without_variables *
* RET : the dump item we should send to EiffelStudio *
*------------------------------------------------------------------------*
* Dump the call stack - locals and arguments excluded *
* *
* Get the next execution vector from the top of `a_stack'. Whenever a *
* vector associated with a melted routine is reached, we also send *
* the arguments (and possibly the locals in ST_FULL mode). This is why *
* we keep an internal state about the status of the last vector. *
**************************************************************************/
rt_private struct dump *get_next_execution_vector(void)
{
EIF_GET_CONTEXT
struct ex_vect *top; /* Exception vector */
static struct ex_vect copy; /* copy of the exception vector */
static struct dump dumped; /* Item returned */
struct dcall *dc; /* Debugger's calling context */
/* We either finished dealing with previous vector, or it was simply
* not associated with a feature. So go on and grab next one, unless
* the end of the stack has been reached.
*/
if (eif_stack.st_cur->sk_arena == eif_stack.st_top) {
/* Reached end of chunck, go to previous chunck if any */
if (eif_stack.st_cur->sk_prev == NULL) {
return NULL; /* no previous chunck ==> end of stack */
}
/* There is a previous chunck, switch to it */
eif_stack.st_cur = eif_stack.st_cur->sk_prev;
eif_stack.st_top = eif_stack.st_cur->sk_end;
eif_stack.st_end = eif_stack.st_cur->sk_end;
}
top = extop (&eif_stack); /* Let's do it the right way -- Didier */
expop (&eif_stack);
if ( !(
( top->ex_type == EX_CALL
|| top->ex_type == EX_RETY
|| top->ex_type == EX_RESC
)
&& top->exu.exur.exur_id != NULL
) ) {
return (struct dump *) EIF_IGNORE; /* This vector should not be sent */
}
/* Build up the dumped structure for the current vector. If this
* vector is associated with a melted feature, the next call to this routine
* will dump the arguments and possibluy the local variables.
*/
dc = safe_dtop(); /* Returns null pointer if empty */
if (dc != NULL && (dc->dc_exec == top)) { /* We've reached a melted feature */
init_var_dump(dc); /* Make this feature "active" */
dumped.dmp_type = DMP_MELTED; /* Structure contains melted feature */
dpop();
} else {
dumped.dmp_type = DMP_VECT; /* Structure contains frozen feature */
}
copy = *top;
dumped.dmp_vect = © /* static variable -- Didier */
if (dumped.dmp_vect->ex_type) {
dumped.dmp_vect->exu.exur.exur_dtype = Dtype(dumped.dmp_vect->exu.exur.exur_id);
}
return &dumped; /* Pointer to static data */
}
void factor_vm::primitive_resize_array()
{
data_root<array> a(dpop(),this);
a.untag_check(this);
cell capacity = unbox_array_size();
dpush(tag<array>(reallot_array(a.untagged(),capacity)));
}
void primitive_fwrite(void)
{
FILE *file = unbox_alien();
F_BYTE_ARRAY *text = untag_byte_array(dpop());
F_FIXNUM length = array_capacity(text);
char *string = (char *)(text + 1);
if(length == 0)
return;
for(;;)
{
size_t written = fwrite(string,1,length,file);
if(written == length)
break;
else
{
if(feof(file))
break;
else
io_error();
/* Still here? EINTR */
length -= written;
string += written;
}
}
}
void factor_vm::primitive_load_locals()
{
fixnum count = untag_fixnum(dpop());
memcpy((cell *)(rs + sizeof(cell)),(cell *)(ds - sizeof(cell) * (count - 1)),sizeof(cell) * count);
ds -= sizeof(cell) * count;
rs += sizeof(cell) * count;
}
inline void factorvm::vmprim_dll_validp()
{
cell library = dpop();
if(library == F)
dpush(T);
else
dpush(untag_check<dll>(library)->dll == NULL ? F : T);
}
void factor_vm::primitive_array()
{
data_root<object> fill(dpop(),this);
cell capacity = unbox_array_size();
array *new_array = allot_uninitialized_array<array>(capacity);
memset_cell(new_array->data(),fill.value(),capacity * sizeof(cell));
dpush(tag<array>(new_array));
}
void factor_vm::primitive_callback()
{
tagged<word> w(dpop());
w.untag_check(this);
callback *stub = callbacks->add(w->code);
box_alien(stub + 1);
}
/* push a new tuple on the stack, filling its slots from the stack */
inline void factorvm::vmprim_tuple_boa()
{
gc_root<tuple_layout> layout(dpop(),this);
gc_root<tuple> t(allot_tuple(layout.value()),this);
cell size = untag_fixnum(layout.untagged()->size) * sizeof(cell);
memcpy(t->data(),(cell *)(ds - (size - sizeof(cell))),size);
ds -= size;
dpush(t.value());
}
/* open a native library and push a handle */
inline void factorvm::vmprim_dlopen()
{
gc_root<byte_array> path(dpop(),this);
path.untag_check(this);
gc_root<dll> library(allot<dll>(sizeof(dll)),this);
library->path = path.value();
ffi_dlopen(library.untagged());
dpush(library.value());
}
void factor_vm::primitive_save_image()
{
/* do a full GC to push everything into tenured space */
gc();
gc_root<byte_array> path(dpop(),this);
path.untag_check(this);
save_image((vm_char *)(path.untagged() + 1));
}
inline void factorvm::vmprim_tuple()
{
gc_root<tuple_layout> layout(dpop(),this);
tuple *t = allot_tuple(layout.value());
fixnum i;
for(i = tuple_size(layout.untagged()) - 1; i >= 0; i--)
t->data()[i] = F;
dpush(tag<tuple>(t));
}
void
dremove( /* delete all definitions of name */
char *name
)
{
EPNODE *ep;
while ((ep = dpop(name)) != NULL)
epfree(ep);
}
void factor_vm::primitive_callstack_to_array()
{
gc_root<callstack> callstack(dpop(),this);
stack_frame_accumulator accum(this);
iterate_callstack_object(callstack.untagged(),accum);
accum.frames.trim();
dpush(accum.frames.elements.value());
}
/* look up a symbol in a native library */
inline void factorvm::vmprim_dlsym()
{
gc_root<object> library(dpop(),this);
gc_root<byte_array> name(dpop(),this);
name.untag_check(this);
symbol_char *sym = name->data<symbol_char>();
if(library.value() == F)
box_alien(ffi_dlsym(NULL,sym));
else
{
dll *d = untag_check<dll>(library.value());
if(d->dll == NULL)
dpush(F);
else
box_alien(ffi_dlsym(d,sym));
}
}
void factor_vm::primitive_set_callstack()
{
callstack *stack = untag_check<callstack>(dpop());
set_callstack(stack_chain->callstack_bottom,
stack->top(),
untag_fixnum(stack->length),
memcpy);
/* We cannot return here ... */
critical_error("Bug in set_callstack()",0);
}
void factor_vm::primitive_modify_code_heap()
{
gc_root<array> alist(dpop(),this);
cell count = array_capacity(alist.untagged());
if(count == 0)
return;
cell i;
for(i = 0; i < count; i++)
{
gc_root<array> pair(array_nth(alist.untagged(),i),this);
gc_root<word> word(array_nth(pair.untagged(),0),this);
gc_root<object> data(array_nth(pair.untagged(),1),this);
switch(data.type())
{
case QUOTATION_TYPE:
jit_compile_word(word.value(),data.value(),false);
break;
case ARRAY_TYPE:
{
array *compiled_data = data.as<array>().untagged();
cell owner = array_nth(compiled_data,0);
cell literals = array_nth(compiled_data,1);
cell relocation = array_nth(compiled_data,2);
cell labels = array_nth(compiled_data,3);
cell code = array_nth(compiled_data,4);
code_block *compiled = add_code_block(
WORD_TYPE,
code,
labels,
owner,
relocation,
literals);
word->code = compiled;
}
break;
default:
critical_error("Expected a quotation or an array",data.value());
break;
}
update_word_xt(word.value());
}
update_code_heap_words();
}
/* make an alien pointing at an offset of another alien */
inline void factorvm::vmprim_displaced_alien()
{
cell alien = dpop();
cell displacement = to_cell(dpop());
if(alien == F && displacement == 0)
dpush(F);
else
{
switch(tagged<object>(alien).type())
{
case BYTE_ARRAY_TYPE:
case ALIEN_TYPE:
case F_TYPE:
dpush(allot_alien(alien,displacement));
break;
default:
type_error(ALIEN_TYPE,alien);
break;
}
}
}
/* Used to implement call( */
void factor_vm::primitive_check_datastack()
{
fixnum out = to_fixnum(dpop());
fixnum in = to_fixnum(dpop());
fixnum height = out - in;
array *saved_datastack = untag_check<array>(dpop());
fixnum saved_height = array_capacity(saved_datastack);
fixnum current_height = (ds - ds_bot + sizeof(cell)) / sizeof(cell);
if(current_height - height != saved_height)
dpush(false_object);
else
{
fixnum i;
for(i = 0; i < saved_height - in; i++)
{
if(((cell *)ds_bot)[i] != array_nth(saved_datastack,i))
{
dpush(false_object);
return;
}
}
dpush(true_object);
}
}
static void if_from_stack( tic_bool_param_t pfield )
{
bool alr_ign = *pfield.bool_ptr;
bool cond = FALSE;
if ( ! alr_ign )
{
long num = dpop();
if (num != 0)
{
cond = TRUE;
}
}
conditionally_tokenize( cond, alr_ign );
}
void
dclear( /* delete variable definitions of name */
char *name
)
{
EPNODE *ep;
while ((ep = dpop(name)) != NULL) {
if (ep->type == ':') {
dpush(name, ep); /* don't clear constants */
return;
}
epfree(ep);
}
}
inline cell factor_vm::unbox_array_size()
{
cell obj = dpeek();
if(TAG(obj) == FIXNUM_TYPE)
{
fixnum n = untag_fixnum(obj);
if(n >= 0 && n < (fixnum)array_size_max)
{
dpop();
return n;
}
}
return unbox_array_size_slow();
}
void primitive_fputc(void)
{
FILE *file = unbox_alien();
F_FIXNUM ch = to_fixnum(dpop());
for(;;)
{
if(fputc(ch,file) == EOF)
{
io_error();
/* Still here? EINTR */
}
else
break;
}
}
void factor_vm::primitive_save_image_and_exit()
{
/* We unbox this before doing anything else. This is the only point
where we might throw an error, so we have to throw an error here since
later steps destroy the current image. */
gc_root<byte_array> path(dpop(),this);
path.untag_check(this);
/* strip out userenv data which is set on startup anyway */
for(cell i = 0; i < USER_ENV; i++)
{
if(!save_env_p(i)) userenv[i] = F;
}
/* do a full GC + code heap compaction */
compact_code_heap();
/* Save the image */
if(save_image((vm_char *)(path.untagged() + 1)))
exit(0);
else
exit(1);
}
void factor_vm::primitive_lookup_method()
{
cell methods = dpop();
cell obj = dpop();
dpush(lookup_method(obj,methods));
}
void primitive_call_clear(void)
{
throw_impl(dpop(),stack_chain->callstack_bottom);
}
/* pop an object representing a C pointer */
void *unbox_alien(void)
{
return alien_offset(dpop());
}
