#include "master.hpp"
-namespace factor
-{
+namespace factor {
-context::context(cell ds_size, cell rs_size) :
- callstack_top(NULL),
- callstack_bottom(NULL),
- datastack(0),
- retainstack(0),
- datastack_region(new segment(ds_size,false)),
- retainstack_region(new segment(rs_size,false)),
- catchstack_save(0),
- current_callback_save(0),
- next(NULL)
-{
- reset_datastack();
- reset_retainstack();
+context::context(cell ds_size, cell rs_size, cell cs_size)
+ : callstack_top(0),
+ callstack_bottom(0),
+ datastack(0),
+ retainstack(0),
+ callstack_save(0),
+ datastack_seg(new segment(ds_size, false)),
+ retainstack_seg(new segment(rs_size, false)),
+ callstack_seg(new segment(cs_size, false)) {
+ reset();
}
-context *factor_vm::alloc_context()
-{
- context *new_context;
+void context::reset_datastack() {
+ datastack = datastack_seg->start - sizeof(cell);
+ fill_stack_seg(datastack, datastack_seg, 0x11111111);
+}
+
+void context::reset_retainstack() {
+ retainstack = retainstack_seg->start - sizeof(cell);
+ fill_stack_seg(retainstack, retainstack_seg, 0x22222222);
+}
+
+void context::reset_callstack() {
+ callstack_top = callstack_bottom = CALLSTACK_BOTTOM(this);
+}
+
+void context::reset_context_objects() {
+ memset_cell(context_objects, false_object,
+ context_object_count * sizeof(cell));
+}
+
+void context::fill_stack_seg(cell top_ptr, segment* seg, cell pattern) {
+#ifdef FACTOR_DEBUG
+ cell clear_start = top_ptr + sizeof(cell);
+ cell clear_size = seg->end - clear_start;
+ memset_cell((void*)clear_start, pattern, clear_size);
+#else
+ (void)top_ptr;
+ (void)seg;
+ (void)pattern;
+#endif
+}
+
+vm_error_type context::address_to_error(cell addr) {
+ if (datastack_seg->underflow_p(addr))
+ return ERROR_DATASTACK_UNDERFLOW;
+ if (datastack_seg->overflow_p(addr))
+ return ERROR_DATASTACK_OVERFLOW;
+ if (retainstack_seg->underflow_p(addr))
+ return ERROR_RETAINSTACK_UNDERFLOW;
+ if (retainstack_seg->overflow_p(addr))
+ return ERROR_RETAINSTACK_OVERFLOW;
+ // These are flipped because the callstack grows downwards.
+ if (callstack_seg->underflow_p(addr))
+ return ERROR_CALLSTACK_OVERFLOW;
+ if (callstack_seg->overflow_p(addr))
+ return ERROR_CALLSTACK_UNDERFLOW;
+ return ERROR_MEMORY;
+}
+
+void context::reset() {
+ reset_datastack();
+ reset_retainstack();
+ reset_callstack();
+ reset_context_objects();
+}
+
+void context::fix_stacks() {
+ if (datastack + sizeof(cell) < datastack_seg->start ||
+ datastack + stack_reserved >= datastack_seg->end)
+ reset_datastack();
+
+ if (retainstack + sizeof(cell) < retainstack_seg->start ||
+ retainstack + stack_reserved >= retainstack_seg->end)
+ reset_retainstack();
+}
+
+context::~context() {
+ delete datastack_seg;
+ delete retainstack_seg;
+ delete callstack_seg;
+}
+
+context* factor_vm::new_context() {
+ context* new_context;
+
+ if (unused_contexts.empty()) {
+ new_context = new context(datastack_size, retainstack_size, callstack_size);
+ } else {
+ new_context = unused_contexts.back();
+ unused_contexts.pop_back();
+ }
+
+ new_context->reset();
+
+ active_contexts.insert(new_context);
+
+ return new_context;
+}
+
+// Allocates memory
+void factor_vm::init_context(context* ctx) {
+ ctx->context_objects[OBJ_CONTEXT] = allot_alien((cell)ctx);
+}
+
+// Allocates memory (init_context(), but not parent->new_context()
+VM_C_API context* new_context(factor_vm* parent) {
+ context* new_context = parent->new_context();
+ parent->init_context(new_context);
+ return new_context;
+}
+
+void factor_vm::delete_context() {
+ unused_contexts.push_back(ctx);
+ active_contexts.erase(ctx);
+
+ while (unused_contexts.size() > 10) {
+ context* stale_context = unused_contexts.front();
+ unused_contexts.pop_front();
+ delete stale_context;
+ }
+}
- if(unused_contexts)
- {
- new_context = unused_contexts;
- unused_contexts = unused_contexts->next;
- }
- else
- new_context = new context(ds_size,rs_size);
+VM_C_API void delete_context(factor_vm* parent) {
+ parent->delete_context();
+}
+
+// Allocates memory (init_context())
+VM_C_API void reset_context(factor_vm* parent) {
+
+ // The function is used by (start-context-and-delete) which expects
+ // the top two datastack items to be preserved after the context has
+ // been resetted.
+
+ context* ctx = parent->ctx;
+ cell arg1 = ctx->pop();
+ cell arg2 = ctx->pop();
+ ctx->reset();
+ ctx->push(arg2);
+ ctx->push(arg1);
+ parent->init_context(ctx);
+}
+
+// Allocates memory
+cell factor_vm::begin_callback(cell quot_) {
+ data_root<object> quot(quot_, this);
+
+ ctx->reset();
+ spare_ctx = new_context();
+ callback_ids.push_back(callback_id++);
+
+ init_context(ctx);
- return new_context;
+ return quot.value();
}
-void factor_vm::dealloc_context(context *old_context)
-{
- old_context->next = unused_contexts;
- unused_contexts = old_context;
+// Allocates memory
+cell begin_callback(factor_vm* parent, cell quot) {
+ return parent->begin_callback(quot);
}
-/* called on entry into a compiled callback */
-void factor_vm::nest_stacks()
-{
- context *new_ctx = alloc_context();
+void factor_vm::end_callback() {
+ callback_ids.pop_back();
+ delete_context();
+}
+
+void end_callback(factor_vm* parent) { parent->end_callback(); }
+
+void factor_vm::primitive_current_callback() {
+ ctx->push(tag_fixnum(callback_ids.back()));
+}
- new_ctx->callstack_bottom = (stack_frame *)-1;
- new_ctx->callstack_top = (stack_frame *)-1;
+void factor_vm::primitive_context_object() {
+ fixnum n = untag_fixnum(ctx->peek());
+ ctx->replace(ctx->context_objects[n]);
+}
+
+void factor_vm::primitive_set_context_object() {
+ fixnum n = untag_fixnum(ctx->pop());
+ cell value = ctx->pop();
+ ctx->context_objects[n] = value;
+}
- /* save per-callback special_objects */
- new_ctx->current_callback_save = special_objects[OBJ_CURRENT_CALLBACK];
- new_ctx->catchstack_save = special_objects[OBJ_CATCHSTACK];
+void factor_vm::primitive_context_object_for() {
+ context* other_ctx = (context*)pinned_alien_offset(ctx->pop());
+ fixnum n = untag_fixnum(ctx->peek());
+ ctx->replace(other_ctx->context_objects[n]);
+}
+
+// Allocates memory
+cell factor_vm::stack_to_array(cell bottom, cell top, vm_error_type error) {
+ fixnum depth = (fixnum)(top - bottom + sizeof(cell));
+
+ if (depth < 0) {
+ general_error(error, false_object, false_object);
+ }
+ array* a = allot_uninitialized_array<array>(depth / sizeof(cell));
+ memcpy(a + 1, (void*)bottom, depth);
+ return tag<array>(a);
+}
+
+// Allocates memory
+cell factor_vm::datastack_to_array(context* ctx) {
+ return stack_to_array(ctx->datastack_seg->start,
+ ctx->datastack,
+ ERROR_DATASTACK_UNDERFLOW);
+}
+
+// Allocates memory
+void factor_vm::primitive_datastack_for() {
+ data_root<alien> alien_ctx(ctx->pop(), this);
+ context* other_ctx = (context*)pinned_alien_offset(alien_ctx.value());
+ cell array = datastack_to_array(other_ctx);
+ ctx->push(array);
+}
+
+// Allocates memory
+cell factor_vm::retainstack_to_array(context* ctx) {
+ return stack_to_array(ctx->retainstack_seg->start,
+ ctx->retainstack,
+ ERROR_RETAINSTACK_UNDERFLOW);
+}
+
+// Allocates memory
+void factor_vm::primitive_retainstack_for() {
+ context* other_ctx = (context*)pinned_alien_offset(ctx->peek());
+ ctx->replace(retainstack_to_array(other_ctx));
+}
+
+// returns pointer to top of stack
+static cell array_to_stack(array* array, cell bottom) {
+ cell depth = array_capacity(array) * sizeof(cell);
+ memcpy((void*)bottom, array + 1, depth);
+ return bottom + depth - sizeof(cell);
+}
+
+void factor_vm::primitive_set_datastack() {
+ array* arr = untag_check<array>(ctx->pop());
+ ctx->datastack = array_to_stack(arr, ctx->datastack_seg->start);
+}
- new_ctx->reset_datastack();
- new_ctx->reset_retainstack();
-
- new_ctx->next = ctx;
- ctx = new_ctx;
-}
-
-void nest_stacks(factor_vm *parent)
-{
- return parent->nest_stacks();
-}
-
-/* called when leaving a compiled callback */
-void factor_vm::unnest_stacks()
-{
- /* restore per-callback special_objects */
- special_objects[OBJ_CURRENT_CALLBACK] = ctx->current_callback_save;
- special_objects[OBJ_CATCHSTACK] = ctx->catchstack_save;
-
- context *old_ctx = ctx;
- ctx = old_ctx->next;
- dealloc_context(old_ctx);
-}
-
-void unnest_stacks(factor_vm *parent)
-{
- return parent->unnest_stacks();
-}
-
-/* called on startup */
-void factor_vm::init_stacks(cell ds_size_, cell rs_size_)
-{
- ds_size = ds_size_;
- rs_size = rs_size_;
- ctx = NULL;
- unused_contexts = NULL;
-}
-
-bool factor_vm::stack_to_array(cell bottom, cell top)
-{
- fixnum depth = (fixnum)(top - bottom + sizeof(cell));
-
- if(depth < 0)
- return false;
- else
- {
- array *a = allot_uninitialized_array<array>(depth / sizeof(cell));
- memcpy(a + 1,(void*)bottom,depth);
- ctx->push(tag<array>(a));
- return true;
- }
-}
-
-void factor_vm::primitive_datastack()
-{
- if(!stack_to_array(ctx->datastack_region->start,ctx->datastack))
- general_error(ERROR_DS_UNDERFLOW,false_object,false_object,NULL);
-}
-
-void factor_vm::primitive_retainstack()
-{
- if(!stack_to_array(ctx->retainstack_region->start,ctx->retainstack))
- general_error(ERROR_RS_UNDERFLOW,false_object,false_object,NULL);
+void factor_vm::primitive_set_retainstack() {
+ array* arr = untag_check<array>(ctx->pop());
+ ctx->retainstack = array_to_stack(arr, ctx->retainstack_seg->start);
}
-/* returns pointer to top of stack */
-cell factor_vm::array_to_stack(array *array, cell bottom)
-{
- cell depth = array_capacity(array) * sizeof(cell);
- memcpy((void*)bottom,array + 1,depth);
- return bottom + depth - sizeof(cell);
-}
-
-void factor_vm::primitive_set_datastack()
-{
- ctx->datastack = array_to_stack(untag_check<array>(ctx->pop()),ctx->datastack_region->start);
+// Used to implement call(
+void factor_vm::primitive_check_datastack() {
+ fixnum out = to_fixnum(ctx->pop());
+ fixnum in = to_fixnum(ctx->pop());
+ fixnum height = out - in;
+ array* saved_datastack = untag_check<array>(ctx->pop());
+ fixnum saved_height = array_capacity(saved_datastack);
+ fixnum current_height =
+ (ctx->datastack - ctx->datastack_seg->start + sizeof(cell)) /
+ sizeof(cell);
+ if (current_height - height != saved_height)
+ ctx->push(false_object);
+ else {
+ cell* ds_bot = (cell*)ctx->datastack_seg->start;
+ for (fixnum i = 0; i < saved_height - in; i++) {
+ if (ds_bot[i] != array_nth(saved_datastack, i)) {
+ ctx->push(false_object);
+ return;
+ }
+ }
+ ctx->push(special_objects[OBJ_CANONICAL_TRUE]);
+ }
}
-void factor_vm::primitive_set_retainstack()
-{
- ctx->retainstack = array_to_stack(untag_check<array>(ctx->pop()),ctx->retainstack_region->start);
-}
-
-/* Used to implement call( */
-void factor_vm::primitive_check_datastack()
-{
- fixnum out = to_fixnum(ctx->pop());
- fixnum in = to_fixnum(ctx->pop());
- fixnum height = out - in;
- array *saved_datastack = untag_check<array>(ctx->pop());
- fixnum saved_height = array_capacity(saved_datastack);
- fixnum current_height = (ctx->datastack - ctx->datastack_region->start + sizeof(cell)) / sizeof(cell);
- if(current_height - height != saved_height)
- ctx->push(false_object);
- else
- {
- cell *ds_bot = (cell *)ctx->datastack_region->start;
- for(fixnum i = 0; i < saved_height - in; i++)
- {
- if(ds_bot[i] != array_nth(saved_datastack,i))
- {
- ctx->push(false_object);
- return;
- }
- }
- ctx->push(true_object);
- }
-}
-
-void factor_vm::primitive_load_locals()
-{
- fixnum count = untag_fixnum(ctx->pop());
- memcpy((cell *)(ctx->retainstack + sizeof(cell)),
- (cell *)(ctx->datastack - sizeof(cell) * (count - 1)),
- sizeof(cell) * count);
- ctx->datastack -= sizeof(cell) * count;
- ctx->retainstack += sizeof(cell) * count;
+void factor_vm::primitive_load_locals() {
+ fixnum count = untag_fixnum(ctx->pop());
+ memcpy((cell*)(ctx->retainstack + sizeof(cell)),
+ (cell*)(ctx->datastack - sizeof(cell) * (count - 1)),
+ sizeof(cell) * count);
+ ctx->datastack -= sizeof(cell) * count;
+ ctx->retainstack += sizeof(cell) * count;
}
}
projects / factor.git / blobdiff