/* Allocates memory */
string* factor_vm::reallot_string(string* str_, cell capacity) {
data_root<string> str(str_, this);
if (reallot_string_in_place_p(str.untagged(), capacity)) {
str->length = tag_fixnum(capacity);
if (to_boolean(str->aux)) {
byte_array* aux = untag<byte_array>(str->aux);
aux->capacity = tag_fixnum(capacity * 2);
}
return str.untagged();
} else {
cell to_copy = string_capacity(str.untagged());
if (capacity < to_copy)
to_copy = capacity;
data_root<string> new_str(allot_string_internal(capacity), this);
memcpy(new_str->data(), str->data(), to_copy);
if (to_boolean(str->aux)) {
byte_array* new_aux = allot_uninitialized_array<byte_array>(capacity * 2);
new_str->aux = tag<byte_array>(new_aux);
write_barrier(&new_str->aux);
byte_array* aux = untag<byte_array>(str->aux);
memcpy(new_aux->data<uint16_t>(), aux->data<uint16_t>(),
to_copy * sizeof(uint16_t));
}
fill_string(new_str.untagged(), to_copy, capacity, '\0');
return new_str.untagged();
}
}
void operator()(instruction_operand op)
{
switch(op.rel_type())
{
case RT_XT:
{
code_block *compiled = op.load_code_block();
cell owner = compiled->owner;
if(to_boolean(owner)) op.store_value(parent->compute_xt_address(owner));
break;
}
case RT_XT_PIC:
{
code_block *compiled = op.load_code_block();
cell owner = parent->code_block_owner(compiled);
if(to_boolean(owner)) op.store_value(parent->compute_xt_pic_address(owner));
break;
}
case RT_XT_PIC_TAIL:
{
code_block *compiled = op.load_code_block();
cell owner = parent->code_block_owner(compiled);
if(to_boolean(owner)) op.store_value(parent->compute_xt_pic_tail_address(owner));
break;
}
default:
break;
}
}
cell factor_vm::lookup_tuple_method(cell obj, cell methods)
{
tuple_layout *layout = untag<tuple_layout>(untag<tuple>(obj)->layout);
array *echelons = untag<array>(methods);
fixnum echelon = std::min(untag_fixnum(layout->echelon),(fixnum)array_capacity(echelons) - 1);
while(echelon >= 0)
{
cell echelon_methods = array_nth(echelons,echelon);
if(tagged<object>(echelon_methods).type_p(WORD_TYPE))
return echelon_methods;
else if(to_boolean(echelon_methods))
{
cell klass = nth_superclass(layout,echelon);
cell hashcode = untag_fixnum(nth_hashcode(layout,echelon));
cell result = search_lookup_hash(echelon_methods,klass,hashcode);
if(to_boolean(result))
return result;
}
echelon--;
}
critical_error("Cannot find tuple method",methods);
return false_object;
}
/**
* Updates the available state of the robot code
*/
void CFG_SetRobotCode (const int code)
{
if (robot_code != to_boolean (code)) {
robot_code = to_boolean (code);
create_robot_event (DS_ROBOT_CODE_CHANGED);
create_robot_event (DS_STATUS_STRING_CHANGED);
}
}
/**
* Updates the robot's \a enabled state
*/
void CFG_SetRobotEnabled (const int enabled)
{
if (robot_enabled != to_boolean (enabled)) {
robot_enabled = to_boolean (enabled) && !CFG_GetEmergencyStopped();
create_robot_event (DS_ROBOT_ENABLED_CHANGED);
create_robot_event (DS_STATUS_STRING_CHANGED);
}
}
/**
* Updates the emergency \a stopped state of the robot.
*/
void CFG_SetEmergencyStopped (const int stopped)
{
if (emergency_stopped != to_boolean (stopped)) {
emergency_stopped = to_boolean (stopped);
create_robot_event (DS_ROBOT_ESTOP_CHANGED);
create_robot_event (DS_STATUS_STRING_CHANGED);
}
}
void factor_vm::primitive_modify_code_heap()
{
bool reset_inline_caches = to_boolean(ctx->pop());
bool update_existing_words = to_boolean(ctx->pop());
data_root<array> alist(ctx->pop(),this);
cell count = array_capacity(alist.untagged());
if(count == 0)
return;
for(cell i = 0; i < count; i++)
{
data_root<array> pair(array_nth(alist.untagged(),i),this);
data_root<word> word(array_nth(pair.untagged(),0),this);
data_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 parameters = 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(
code_block_optimized,
code,
labels,
word.value(),
relocation,
parameters,
literals);
word->code = compiled;
}
break;
default:
critical_error("Expected a quotation or an array",data.value());
break;
}
update_word_entry_point(word.untagged());
}
if(update_existing_words)
update_code_heap_words(reset_inline_caches);
else
initialize_code_blocks();
}
/**
* Updates the state of the robot communications.
*/
void CFG_SetRobotCommunications (const int communications)
{
if (robot_communications != to_boolean (communications)) {
robot_communications = to_boolean (communications);
create_robot_event (DS_ROBOT_COMMS_CHANGED);
create_robot_event (DS_STATUS_STRING_CHANGED);
DS_ResetRobotPackets();
}
}
/* Compile a word definition with the non-optimizing compiler. Allocates memory */
void factor_vm::jit_compile_word(cell word_, cell def_, bool relocate)
{
gc_root<word> word(word_,this);
gc_root<quotation> def(def_,this);
jit_compile(def.value(),relocate);
word->code = def->code;
if(to_boolean(word->pic_def)) jit_compile(word->pic_def,relocate);
if(to_boolean(word->pic_tail_def)) jit_compile(word->pic_tail_def,relocate);
}
/**
* Updates the state of the FMS communications.
*/
void CFG_SetFMSCommunications (const int communications)
{
if (fms_communications != to_boolean (communications)) {
fms_communications = to_boolean (communications);
DS_Event event;
event.fms.type = DS_FMS_COMMS_CHANGED;
event.fms.connected = fms_communications;
DS_AddEvent (&event);
DS_ResetFMSPackets();
}
}
/**
* Updates the state of the radio communications.
*/
void CFG_SetRadioCommunications (const int communications)
{
if (radio_communications != to_boolean (communications)) {
radio_communications = to_boolean (communications);
DS_Event event;
event.radio.type = DS_RADIO_COMMS_CHANGED;
event.radio.connected = fms_communications;
DS_AddEvent (&event);
DS_ResetRadioPackets();
}
}
static obj_t *
lang_if(obj_t **frame, obj_t **tailp)
{
obj_t *expr = *frame_ref(frame, 0);
obj_t *pred, *todo, *otherwise;
*tailp = tail_token;
pred = pair_car(expr);
todo = pair_cadr(expr);
otherwise = pair_cddr(expr);
if (nullp(otherwise)) {
otherwise = unspec_wrap();
}
else if (!nullp(pair_cdr(otherwise))) {
fatal_error("if -- too many arguments", frame);
}
else {
otherwise = pair_car(otherwise);
}
{
// start to evaluate the predicate.
obj_t **pred_frame = frame_extend(
frame, 1, FR_CONTINUE_ENV | FR_SAVE_PREV);
*frame_ref(pred_frame, 0) = pred;
pred = eval_frame(pred_frame);
}
if (to_boolean(pred)) {
return todo;
}
else {
return otherwise;
}
}
void factor_vm::primitive_dll_validp() {
cell library = ctx->peek();
if (to_boolean(library))
ctx->replace(tag_boolean(untag_check<dll>(library)->handle != NULL));
else
ctx->replace(true_object);
}
void factor_vm::fixup_data(cell data_offset, cell code_offset) {
startup_fixup fixup(data_offset, code_offset);
slot_visitor<startup_fixup> visitor(this, fixup);
visitor.visit_all_roots();
auto start_object_updater = [&](object *obj, cell size) {
data->tenured->starts.record_object_start_offset(obj);
visitor.visit_slots(obj);
switch (obj->type()) {
case ALIEN_TYPE: {
alien* ptr = (alien*)obj;
if (to_boolean(ptr->base))
ptr->update_address();
else
ptr->expired = special_objects[OBJ_CANONICAL_TRUE];
break;
}
case DLL_TYPE: {
ffi_dlopen((dll*)obj);
break;
}
default: {
visitor.visit_object_code_block(obj);
break;
}
}
};
data->tenured->iterate(start_object_updater, fixup);
}
void factor_vm::set_string_nth_slow(string *str_, cell index, cell ch)
{
data_root<string> str(str_,this);
byte_array *aux;
str->data()[index] = ((ch & 0x7f) | 0x80);
if(to_boolean(str->aux))
aux = untag<byte_array>(str->aux);
else
{
/* We don't need to pre-initialize the
byte array with any data, since we
only ever read from the aux vector
if the most significant bit of a
character is set. Initially all of
the bits are clear. */
aux = allot_uninitialized_array<byte_array>(untag_fixnum(str->length) * sizeof(u16));
str->aux = tag<byte_array>(aux);
write_barrier(&str->aux);
}
aux->data<u16>()[index] = (u16)((ch >> 7) ^ 1);
}
/* Compile a word definition with the non-optimizing compiler. Allocates memory */
void factor_vm::jit_compile_word(cell word_, cell def_, bool relocating)
{
data_root<word> word(word_,this);
data_root<quotation> def(def_,this);
/* Refuse to compile this word more than once, because quot_compiled_p()
depends on the identity of its code block */
if(word->code && word.value() == special_objects[LAZY_JIT_COMPILE_WORD])
return;
code_block *compiled = jit_compile_quot(word.value(),def.value(),relocating);
word->code = compiled;
if(to_boolean(word->pic_def)) jit_compile_quot(word->pic_def,relocating);
if(to_boolean(word->pic_tail_def)) jit_compile_quot(word->pic_tail_def,relocating);
}
void factor_vm::primitive_dll_validp() {
cell library = ctx->peek();
if (to_boolean(library))
ctx->replace(tag_boolean(untag_check<dll>(library)->handle != NULL));
else
ctx->replace(special_objects[OBJ_CANONICAL_TRUE]);
}
void factor_vm::init_factor(vm_parameters *p)
{
/* Kilobytes */
p->datastack_size = align_page(p->datastack_size << 10);
p->retainstack_size = align_page(p->retainstack_size << 10);
p->callstack_size = align_page(p->callstack_size << 10);
p->callback_size = align_page(p->callback_size << 10);
/* Megabytes */
p->young_size <<= 20;
p->aging_size <<= 20;
p->tenured_size <<= 20;
p->code_size <<= 20;
/* Disable GC during init as a sanity check */
gc_off = true;
/* OS-specific initialization */
early_init();
const vm_char *executable_path = vm_executable_path();
if(executable_path)
p->executable_path = executable_path;
if(p->image_path == NULL)
p->image_path = default_image_path();
srand((unsigned int)nano_count());
init_ffi();
init_contexts(p->datastack_size,p->retainstack_size,p->callstack_size);
init_callbacks(p->callback_size);
load_image(p);
init_c_io();
init_inline_caching((int)p->max_pic_size);
if(p->signals)
init_signals();
if(p->console)
open_console();
init_profiler();
special_objects[OBJ_CPU] = allot_alien(false_object,(cell)FACTOR_CPU_STRING);
special_objects[OBJ_OS] = allot_alien(false_object,(cell)FACTOR_OS_STRING);
special_objects[OBJ_CELL_SIZE] = tag_fixnum(sizeof(cell));
special_objects[OBJ_EXECUTABLE] = allot_alien(false_object,(cell)p->executable_path);
special_objects[OBJ_ARGS] = false_object;
special_objects[OBJ_EMBEDDED] = false_object;
special_objects[OBJ_VM_COMPILER] = allot_alien(false_object,(cell)FACTOR_COMPILER_VERSION);
/* We can GC now */
gc_off = false;
if(!to_boolean(special_objects[OBJ_STAGE2]))
prepare_boot_image();
}
/* References to undefined symbols are patched up to call this function on
image load. It finds the symbol and library, and throws an error. */
void factor_vm::undefined_symbol()
{
void *frame = ctx->callstack_top;
void *return_address = frame_return_address(frame);
code_block *compiled = code->code_block_for_address((cell)return_address);
find_symbol_at_address_visitor visitor(this, (cell)return_address);
compiled->each_instruction_operand(visitor);
if (!to_boolean(visitor.symbol))
critical_error("Can't find RT_DLSYM at return address", (cell)return_address);
else
general_error(ERROR_UNDEFINED_SYMBOL,visitor.symbol,visitor.library);
}
/* Allocates memory */
void factor_vm::general_error(vm_error_type error, cell arg1_, cell arg2_) {
data_root<object> arg1(arg1_, this);
data_root<object> arg2(arg2_, this);
faulting_p = true;
/* If we had an underflow or overflow, data or retain stack
pointers might be out of bounds, so fix them before allocating
anything */
ctx->fix_stacks();
/* If error was thrown during heap scan, we re-enable the GC */
gc_off = false;
/* If the error handler is set, we rewind any C stack frames and
pass the error to user-space. */
if (!current_gc && to_boolean(special_objects[ERROR_HANDLER_QUOT])) {
#ifdef FACTOR_DEBUG
/* Doing a GC here triggers all kinds of funny errors */
primitive_compact_gc();
#endif
/* Now its safe to allocate and GC */
cell error_object =
allot_array_4(tag_fixnum(KERNEL_ERROR), tag_fixnum(error),
arg1.value(), arg2.value());
ctx->push(error_object);
/* Clear the data roots since arg1 and arg2's destructors won't be
called. */
data_roots.clear();
/* The unwind-native-frames subprimitive will clear faulting_p
if it was successfully reached. */
unwind_native_frames(special_objects[ERROR_HANDLER_QUOT],
ctx->callstack_top);
} /* Error was thrown in early startup before error handler is set, so just
crash. */
else {
std::cout << "You have triggered a bug in Factor. Please report.\n";
std::cout << "error: " << error << std::endl;
std::cout << "arg 1: ";
print_obj(std::cout, arg1.value());
std::cout << std::endl;
std::cout << "arg 2: ";
print_obj(std::cout, arg2.value());
std::cout << std::endl;
factorbug();
abort();
}
}
/* References to undefined symbols are patched up to call this function on
image load. It finds the symbol and library, and throws an error. */
void factor_vm::undefined_symbol()
{
stack_frame *frame = innermost_stack_frame(ctx->callstack_bottom,
ctx->callstack_top);
code_block *compiled = frame_code(frame);
cell return_address = (cell)FRAME_RETURN_ADDRESS(frame, this);
find_symbol_at_address_visitor visitor(this, return_address);
compiled->each_instruction_operand(visitor);
if (!to_boolean(visitor.symbol))
critical_error("Can't find RT_DLSYM at return address", return_address);
else
general_error(ERROR_UNDEFINED_SYMBOL,visitor.symbol,visitor.library);
}
void *factor_vm::xt_pic(word *w, cell tagged_quot)
{
if(!to_boolean(tagged_quot) || max_pic_size == 0)
return w->xt;
else
{
quotation *quot = untag<quotation>(tagged_quot);
if(quot->code)
return quot->xt;
else
return w->xt;
}
}
cell factor_vm::compute_entry_point_pic_address(word *w, cell tagged_quot)
{
if(!to_boolean(tagged_quot) || max_pic_size == 0)
return (cell)w->entry_point;
else
{
quotation *quot = untag<quotation>(tagged_quot);
if(quot_compiled_p(quot))
return (cell)quot->entry_point;
else
return (cell)w->entry_point;
}
}
cell factor_vm::compute_xt_pic_address(word *w, cell tagged_quot)
{
if(!to_boolean(tagged_quot) || max_pic_size == 0)
return (cell)w->xt;
else
{
quotation *quot = untag<quotation>(tagged_quot);
if(quot->code)
return (cell)quot->xt;
else
return (cell)w->xt;
}
}
void operator()(instruction_operand op)
{
switch(op.rel_type())
{
case RT_ENTRY_POINT:
{
code_block *compiled = op.load_code_block();
cell owner = compiled->owner;
if(to_boolean(owner))
op.store_value(parent->compute_entry_point_address(owner));
break;
}
case RT_ENTRY_POINT_PIC:
{
code_block *compiled = op.load_code_block();
if(reset_inline_caches || !compiled->pic_p())
{
cell owner = parent->code_block_owner(compiled);
if(to_boolean(owner))
op.store_value(parent->compute_entry_point_pic_address(owner));
}
break;
}
case RT_ENTRY_POINT_PIC_TAIL:
{
code_block *compiled = op.load_code_block();
if(reset_inline_caches || !compiled->pic_p())
{
cell owner = parent->code_block_owner(compiled);
if(to_boolean(owner))
op.store_value(parent->compute_entry_point_pic_tail_address(owner));
}
break;
}
default:
break;
}
}
/* Might GC */
code_block *factor_vm::add_code_block(code_block_type type, cell code_, cell labels_,
cell owner_, cell relocation_, cell parameters_, cell literals_,
cell frame_size_untagged)
{
data_root<byte_array> code(code_,this);
data_root<object> labels(labels_,this);
data_root<object> owner(owner_,this);
data_root<byte_array> relocation(relocation_,this);
data_root<array> parameters(parameters_,this);
data_root<array> literals(literals_,this);
cell code_length = array_capacity(code.untagged());
code_block *compiled = allot_code_block(code_length,type);
compiled->owner = owner.value();
/* slight space optimization */
if(relocation.type() == BYTE_ARRAY_TYPE && array_capacity(relocation.untagged()) == 0)
compiled->relocation = false_object;
else
compiled->relocation = relocation.value();
if(parameters.type() == ARRAY_TYPE && array_capacity(parameters.untagged()) == 0)
compiled->parameters = false_object;
else
compiled->parameters = parameters.value();
/* code */
memcpy(compiled + 1,code.untagged() + 1,code_length);
/* fixup labels */
if(to_boolean(labels.value()))
fixup_labels(labels.as<array>().untagged(),compiled);
compiled->set_stack_frame_size(frame_size_untagged);
/* Once we are ready, fill in literal and word references in this code
block's instruction operands. In most cases this is done right after this
method returns, except when compiling words with the non-optimizing
compiler at the beginning of bootstrap */
this->code->uninitialized_blocks.insert(std::make_pair(compiled,literals.value()));
this->code->all_blocks.insert((cell)compiled);
/* next time we do a minor GC, we have to trace this code block, since
the fields of the code_block struct might point into nursery or aging */
this->code->write_barrier(compiled);
return compiled;
}
template <typename Iterator> void each_instruction_operand(Iterator& iter) {
if (!to_boolean(relocation))
return;
byte_array* rels = untag<byte_array>(relocation);
cell index = 0;
cell length = untag_fixnum(rels->capacity) / sizeof(relocation_entry);
for (cell i = 0; i < length; i++) {
relocation_entry rel = rels->data<relocation_entry>()[i];
iter(instruction_operand(rel, this, index));
index += rel.number_of_parameters();
}
}
cell factor_vm::compute_relocation(relocation_entry rel, cell index, code_block *compiled)
{
array *literals = (to_boolean(compiled->literals)
? untag<array>(compiled->literals) : NULL);
cell offset = relocation_offset_of(rel) + (cell)compiled->xt();
#define ARG array_nth(literals,index)
switch(relocation_type_of(rel))
{
case RT_PRIMITIVE:
return (cell)primitives[untag_fixnum(ARG)];
case RT_DLSYM:
return (cell)get_rel_symbol(literals,index);
case RT_IMMEDIATE:
return ARG;
case RT_XT:
return (cell)object_xt(ARG);
case RT_XT_PIC:
return (cell)word_xt_pic(untag<word>(ARG));
case RT_XT_PIC_TAIL:
return (cell)word_xt_pic_tail(untag<word>(ARG));
case RT_HERE:
{
fixnum arg = untag_fixnum(ARG);
return (arg >= 0 ? offset + arg : (cell)(compiled + 1) - arg);
}
case RT_THIS:
return (cell)(compiled + 1);
case RT_CONTEXT:
return (cell)&ctx;
case RT_UNTAGGED:
return untag_fixnum(ARG);
case RT_MEGAMORPHIC_CACHE_HITS:
return (cell)&megamorphic_cache_hits;
case RT_VM:
return (cell)this + untag_fixnum(ARG);
case RT_CARDS_OFFSET:
return cards_offset;
case RT_DECKS_OFFSET:
return decks_offset;
default:
critical_error("Bad rel type",rel);
return 0; /* Can't happen */
}
#undef ARG
}
void factor_vm::forward_object_xts()
{
begin_scan();
cell obj;
while(to_boolean(obj = next_object()))
{
switch(tagged<object>(obj).type())
{
case WORD_TYPE:
{
word *w = untag<word>(obj);
if(w->code)
w->code = code->forward_code_block(w->code);
if(w->profiling)
w->profiling = code->forward_code_block(w->profiling);
update_word_xt(obj);
}
break;
case QUOTATION_TYPE:
{
quotation *quot = untag<quotation>(obj);
if(quot->code)
{
quot->code = code->forward_code_block(quot->code);
set_quot_xt(quot,quot->code);
}
}
break;
case CALLSTACK_TYPE:
{
callstack *stack = untag<callstack>(obj);
callframe_forwarder forwarder(this);
iterate_callstack_object(stack,forwarder);
}
break;
default:
break;
}
}
end_scan();
}
void factor_vm::store_external_address(instruction_operand op)
{
code_block *compiled = op.compiled;
array *parameters = (to_boolean(compiled->parameters) ? untag<array>(compiled->parameters) : NULL);
cell index = op.index;
switch(op.rel_type())
{
case RT_DLSYM:
op.store_value(compute_dlsym_address(parameters,index));
break;
case RT_THIS:
op.store_value((cell)compiled->entry_point());
break;
case RT_MEGAMORPHIC_CACHE_HITS:
op.store_value((cell)&dispatch_stats.megamorphic_cache_hits);
break;
case RT_VM:
op.store_value(compute_vm_address(array_nth(parameters,index)));
break;
case RT_CARDS_OFFSET:
op.store_value(cards_offset);
break;
case RT_DECKS_OFFSET:
op.store_value(decks_offset);
break;
#ifdef WINDOWS
case RT_EXCEPTION_HANDLER:
op.store_value((cell)&factor::exception_handler);
break;
#endif
#ifdef FACTOR_PPC
case RT_DLSYM_TOC:
op.store_value(compute_dlsym_toc_address(parameters,index));
break;
#endif
case RT_INLINE_CACHE_MISS:
op.store_value((cell)&factor::inline_cache_miss);
break;
case RT_SAFEPOINT:
op.store_value((cell)code->safepoint_page);
break;
default:
critical_error("Bad rel type in store_external_address()",op.rel_type());
break;
}
}
