--- /dev/null
+namespace factor
+{
+
+// I've had to copy inline implementations here to make dependencies work. Hopefully this can be better factored
+// once the rest of the reentrant changes are done. -PD
+
+//tagged.hpp
+
+template <typename TYPE>
+struct tagged
+{
+ cell value_;
+
+ cell value() const { return value_; }
+ TYPE *untagged() const { return (TYPE *)(UNTAG(value_)); }
+
+ cell type() const {
+ cell tag = TAG(value_);
+ if(tag == OBJECT_TYPE)
+ return untagged()->h.hi_tag();
+ else
+ return tag;
+ }
+
+ bool type_p(cell type_) const { return type() == type_; }
+
+ TYPE *untag_check() const {
+ if(TYPE::type_number != TYPE_COUNT && !type_p(TYPE::type_number))
+ type_error(TYPE::type_number,value_);
+ return untagged();
+ }
+
+ explicit tagged(cell tagged) : value_(tagged) {
+#ifdef FACTOR_DEBUG
+ untag_check();
+#endif
+ }
+
+ explicit tagged(TYPE *untagged) : value_(factor::tag(untagged)) {
+#ifdef FACTOR_DEBUG
+ untag_check();
+#endif
+ }
+
+ TYPE *operator->() const { return untagged(); }
+ cell *operator&() const { return &value_; }
+
+ const tagged<TYPE>& operator=(const TYPE *x) { value_ = tag(x); return *this; }
+ const tagged<TYPE>& operator=(const cell &x) { value_ = x; return *this; }
+
+ bool operator==(const tagged<TYPE> &x) { return value_ == x.value_; }
+ bool operator!=(const tagged<TYPE> &x) { return value_ != x.value_; }
+
+ template<typename X> tagged<X> as() { return tagged<X>(value_); }
+};
+
+template <typename TYPE> TYPE *factorvm::untag_check(cell value)
+{
+ return tagged<TYPE>(value).untag_check();
+}
+
+template <typename TYPE> TYPE *untag_check(cell value)
+{
+ return vm->untag_check<TYPE>(value);
+}
+
+template <typename TYPE> TYPE *factorvm::untag(cell value)
+{
+ return tagged<TYPE>(value).untagged();
+}
+
+template <typename TYPE> TYPE *untag(cell value)
+{
+ return vm->untag<TYPE>(value);
+}
+
+
+
+// write_barrier.hpp
+
+inline card *factorvm::addr_to_card(cell a)
+{
+ return (card*)(((cell)(a) >> card_bits) + cards_offset);
+}
+
+inline card *addr_to_card(cell a)
+{
+ return vm->addr_to_card(a);
+}
+
+inline cell factorvm::card_to_addr(card *c)
+{
+ return ((cell)c - cards_offset) << card_bits;
+}
+
+inline cell card_to_addr(card *c)
+{
+ return vm->card_to_addr(c);
+}
+
+inline cell factorvm::card_offset(card *c)
+{
+ return *(c - (cell)data->cards + (cell)data->allot_markers);
+}
+
+inline cell card_offset(card *c)
+{
+ return vm->card_offset(c);
+}
+
+inline card_deck *factorvm::addr_to_deck(cell a)
+{
+ return (card_deck *)(((cell)a >> deck_bits) + decks_offset);
+}
+
+inline card_deck *addr_to_deck(cell a)
+{
+ return vm->addr_to_deck(a);
+}
+
+inline cell factorvm::deck_to_addr(card_deck *c)
+{
+ return ((cell)c - decks_offset) << deck_bits;
+}
+
+inline cell deck_to_addr(card_deck *c)
+{
+ return vm->deck_to_addr(c);
+}
+
+inline card *factorvm::deck_to_card(card_deck *d)
+{
+ return (card *)((((cell)d - decks_offset) << (deck_bits - card_bits)) + cards_offset);
+}
+
+inline card *deck_to_card(card_deck *d)
+{
+ return vm->deck_to_card(d);
+}
+
+inline card *factorvm::addr_to_allot_marker(object *a)
+{
+ return (card *)(((cell)a >> card_bits) + allot_markers_offset);
+}
+
+inline card *addr_to_allot_marker(object *a)
+{
+ return vm->addr_to_allot_marker(a);
+}
+
+/* the write barrier must be called any time we are potentially storing a
+pointer from an older generation to a younger one */
+inline void factorvm::write_barrier(object *obj)
+{
+ *addr_to_card((cell)obj) = card_mark_mask;
+ *addr_to_deck((cell)obj) = card_mark_mask;
+}
+
+inline void write_barrier(object *obj)
+{
+ return vm->write_barrier(obj);
+}
+
+/* we need to remember the first object allocated in the card */
+inline void factorvm::allot_barrier(object *address)
+{
+ card *ptr = addr_to_allot_marker(address);
+ if(*ptr == invalid_allot_marker)
+ *ptr = ((cell)address & addr_card_mask);
+}
+
+inline void allot_barrier(object *address)
+{
+ return vm->allot_barrier(address);
+}
+
+
+//data_gc.hpp
+inline bool factorvm::collecting_accumulation_gen_p()
+{
+ return ((data->have_aging_p()
+ && collecting_gen == data->aging()
+ && !collecting_aging_again)
+ || collecting_gen == data->tenured());
+}
+
+inline bool collecting_accumulation_gen_p()
+{
+ return vm->collecting_accumulation_gen_p();
+}
+
+inline object *factorvm::allot_zone(zone *z, cell a)
+{
+ cell h = z->here;
+ z->here = h + align8(a);
+ object *obj = (object *)h;
+ allot_barrier(obj);
+ return obj;
+}
+
+inline object *allot_zone(zone *z, cell a)
+{
+ return vm->allot_zone(z,a);
+}
+
+/*
+ * It is up to the caller to fill in the object's fields in a meaningful
+ * fashion!
+ */
+inline object *factorvm::allot_object(header header, cell size)
+{
+#ifdef GC_DEBUG
+ if(!gc_off)
+ gc();
+#endif
+
+ object *obj;
+
+ if(nursery.size - allot_buffer_zone > size)
+ {
+ /* If there is insufficient room, collect the nursery */
+ if(nursery.here + allot_buffer_zone + size > nursery.end)
+ garbage_collection(data->nursery(),false,0);
+
+ cell h = nursery.here;
+ nursery.here = h + align8(size);
+ obj = (object *)h;
+ }
+ /* If the object is bigger than the nursery, allocate it in
+ tenured space */
+ else
+ {
+ zone *tenured = &data->generations[data->tenured()];
+
+ /* If tenured space does not have enough room, collect */
+ if(tenured->here + size > tenured->end)
+ {
+ gc();
+ tenured = &data->generations[data->tenured()];
+ }
+
+ /* If it still won't fit, grow the heap */
+ if(tenured->here + size > tenured->end)
+ {
+ garbage_collection(data->tenured(),true,size);
+ tenured = &data->generations[data->tenured()];
+ }
+
+ obj = allot_zone(tenured,size);
+
+ /* Allows initialization code to store old->new pointers
+ without hitting the write barrier in the common case of
+ a nursery allocation */
+ write_barrier(obj);
+ }
+
+ obj->h = header;
+ return obj;
+}
+
+inline object *allot_object(header header, cell size)
+{
+ return vm->allot_object(header,size);
+}
+
+template<typename TYPE> TYPE *factorvm::allot(cell size)
+{
+ return (TYPE *)allot_object(header(TYPE::type_number),size);
+}
+
+template<typename TYPE> TYPE *allot(cell size)
+{
+ return vm->allot<TYPE>(size);
+}
+
+inline void factorvm::check_data_pointer(object *pointer)
+{
+#ifdef FACTOR_DEBUG
+ if(!growing_data_heap)
+ {
+ assert((cell)pointer >= data->seg->start
+ && (cell)pointer < data->seg->end);
+ }
+#endif
+}
+
+inline void check_data_pointer(object *pointer)
+{
+ return vm->check_data_pointer(pointer);
+}
+
+inline void factorvm::check_tagged_pointer(cell tagged)
+{
+#ifdef FACTOR_DEBUG
+ if(!immediate_p(tagged))
+ {
+ object *obj = untag<object>(tagged);
+ check_data_pointer(obj);
+ obj->h.hi_tag();
+ }
+#endif
+}
+
+inline void check_tagged_pointer(cell tagged)
+{
+ return vm->check_tagged_pointer(tagged);
+}
+
+//local_roots.hpp
+template <typename TYPE>
+struct gc_root : public tagged<TYPE>
+{
+ factorvm *myvm;
+
+ void push() { check_tagged_pointer(tagged<TYPE>::value()); myvm->gc_locals.push_back((cell)this); }
+
+ //explicit gc_root(cell value_, factorvm *vm) : myvm(vm),tagged<TYPE>(value_) { push(); }
+ explicit gc_root(cell value_,factorvm *vm) : tagged<TYPE>(value_),myvm(vm) { push(); }
+ explicit gc_root(TYPE *value_, factorvm *vm) : tagged<TYPE>(value_),myvm(vm) { push(); }
+
+ const gc_root<TYPE>& operator=(const TYPE *x) { tagged<TYPE>::operator=(x); return *this; }
+ const gc_root<TYPE>& operator=(const cell &x) { tagged<TYPE>::operator=(x); return *this; }
+
+ ~gc_root() {
+#ifdef FACTOR_DEBUG
+ assert(myvm->gc_locals.back() == (cell)this);
+#endif
+ myvm->gc_locals.pop_back();
+ }
+};
+
+/* A similar hack for the bignum implementation */
+struct gc_bignum
+{
+ bignum **addr;
+ factorvm *myvm;
+ gc_bignum(bignum **addr_, factorvm *vm) : addr(addr_), myvm(vm) {
+ if(*addr_)
+ check_data_pointer(*addr_);
+ myvm->gc_bignums.push_back((cell)addr);
+ }
+
+ ~gc_bignum() {
+#ifdef FACTOR_DEBUG
+ assert(myvm->gc_bignums.back() == (cell)addr);
+#endif
+ myvm->gc_bignums.pop_back();
+ }
+};
+
+#define GC_BIGNUM(x,vm) gc_bignum x##__gc_root(&x,vm)
+
+//generic_arrays.hpp
+template <typename TYPE> TYPE *factorvm::allot_array_internal(cell capacity)
+{
+ TYPE *array = allot<TYPE>(array_size<TYPE>(capacity));
+ array->capacity = tag_fixnum(capacity);
+ return array;
+}
+
+template <typename TYPE> TYPE *allot_array_internal(cell capacity)
+{
+ return vm->allot_array_internal<TYPE>(capacity);
+}
+
+template <typename TYPE> bool factorvm::reallot_array_in_place_p(TYPE *array, cell capacity)
+{
+ return in_zone(&nursery,array) && capacity <= array_capacity(array);
+}
+
+template <typename TYPE> bool reallot_array_in_place_p(TYPE *array, cell capacity)
+{
+ return vm->reallot_array_in_place_p<TYPE>(array,capacity);
+}
+
+template <typename TYPE> TYPE *factorvm::reallot_array(TYPE *array_, cell capacity)
+{
+ gc_root<TYPE> array(array_,this);
+
+ if(reallot_array_in_place_p(array.untagged(),capacity))
+ {
+ array->capacity = tag_fixnum(capacity);
+ return array.untagged();
+ }
+ else
+ {
+ cell to_copy = array_capacity(array.untagged());
+ if(capacity < to_copy)
+ to_copy = capacity;
+
+ TYPE *new_array = allot_array_internal<TYPE>(capacity);
+
+ memcpy(new_array + 1,array.untagged() + 1,to_copy * TYPE::element_size);
+ memset((char *)(new_array + 1) + to_copy * TYPE::element_size,
+ 0,(capacity - to_copy) * TYPE::element_size);
+
+ return new_array;
+ }
+}
+
+//arrays.hpp
+inline void factorvm::set_array_nth(array *array, cell slot, cell value)
+{
+#ifdef FACTOR_DEBUG
+ assert(slot < array_capacity(array));
+ assert(array->h.hi_tag() == ARRAY_TYPE);
+ check_tagged_pointer(value);
+#endif
+ array->data()[slot] = value;
+ write_barrier(array);
+}
+
+inline void set_array_nth(array *array, cell slot, cell value)
+{
+ return vm->set_array_nth(array,slot,value);
+}
+
+struct growable_array {
+ cell count;
+ gc_root<array> elements;
+
+ growable_array(factorvm *myvm, cell capacity = 10) : count(0), elements(allot_array(capacity,F),myvm) {}
+
+ void add(cell elt);
+ void trim();
+};
+
+//byte_arrays.hpp
+struct growable_byte_array {
+ cell count;
+ gc_root<byte_array> elements;
+
+ growable_byte_array(factorvm *vm,cell capacity = 40) : count(0), elements(allot_byte_array(capacity),vm) { }
+
+ void append_bytes(void *elts, cell len);
+ void append_byte_array(cell elts);
+
+ void trim();
+};
+
+//math.hpp
+inline cell factorvm::allot_integer(fixnum x)
+{
+ if(x < fixnum_min || x > fixnum_max)
+ return tag<bignum>(fixnum_to_bignum(x));
+ else
+ return tag_fixnum(x);
+}
+
+inline cell allot_integer(fixnum x)
+{
+ return vm->allot_integer(x);
+}
+
+inline cell factorvm::allot_cell(cell x)
+{
+ if(x > (cell)fixnum_max)
+ return tag<bignum>(cell_to_bignum(x));
+ else
+ return tag_fixnum(x);
+}
+
+inline cell allot_cell(cell x)
+{
+ return vm->allot_cell(x);
+}
+
+inline cell factorvm::allot_float(double n)
+{
+ boxed_float *flo = allot<boxed_float>(sizeof(boxed_float));
+ flo->n = n;
+ return tag(flo);
+}
+
+inline cell allot_float(double n)
+{
+ return vm->allot_float(n);
+}
+
+inline bignum *factorvm::float_to_bignum(cell tagged)
+{
+ return double_to_bignum(untag_float(tagged));
+}
+
+inline bignum *float_to_bignum(cell tagged)
+{
+ return vm->float_to_bignum(tagged);
+}
+
+inline double factorvm::bignum_to_float(cell tagged)
+{
+ return bignum_to_double(untag<bignum>(tagged));
+}
+
+inline double bignum_to_float(cell tagged)
+{
+ return vm->bignum_to_float(tagged);
+}
+
+inline double factorvm::untag_float(cell tagged)
+{
+ return untag<boxed_float>(tagged)->n;
+}
+
+inline double untag_float(cell tagged)
+{
+ return vm->untag_float(tagged);
+}
+
+inline double factorvm::untag_float_check(cell tagged)
+{
+ return untag_check<boxed_float>(tagged)->n;
+}
+
+inline double untag_float_check(cell tagged)
+{
+ return vm->untag_float_check(tagged);
+}
+
+inline fixnum factorvm::float_to_fixnum(cell tagged)
+{
+ return (fixnum)untag_float(tagged);
+}
+
+inline static fixnum float_to_fixnum(cell tagged)
+{
+ return vm->float_to_fixnum(tagged);
+}
+
+inline double factorvm::fixnum_to_float(cell tagged)
+{
+ return (double)untag_fixnum(tagged);
+}
+
+inline double fixnum_to_float(cell tagged)
+{
+ return vm->fixnum_to_float(tagged);
+}
+
+
+//callstack.hpp
+/* This is a little tricky. The iterator may allocate memory, so we
+keep the callstack in a GC root and use relative offsets */
+template<typename TYPE> void factorvm::iterate_callstack_object(callstack *stack_, TYPE &iterator)
+{
+ gc_root<callstack> stack(stack_,vm);
+ fixnum frame_offset = untag_fixnum(stack->length) - sizeof(stack_frame);
+
+ while(frame_offset >= 0)
+ {
+ stack_frame *frame = stack->frame_at(frame_offset);
+ frame_offset -= frame->size;
+ iterator(frame,this);
+ }
+}
+
+template<typename TYPE> void iterate_callstack_object(callstack *stack_, TYPE &iterator)
+{
+ return vm->iterate_callstack_object(stack_,iterator);
+}
+
+//booleans.hpp
+inline cell factorvm::tag_boolean(cell untagged)
+{
+ return (untagged ? T : F);
+}
+
+inline cell tag_boolean(cell untagged)
+{
+ return vm->tag_boolean(untagged);
+}
+
+// callstack.hpp
+template<typename TYPE> void factorvm::iterate_callstack(cell top, cell bottom, TYPE &iterator)
+{
+ stack_frame *frame = (stack_frame *)bottom - 1;
+
+ while((cell)frame >= top)
+ {
+ iterator(frame,this);
+ frame = frame_successor(frame);
+ }
+}
+
+template<typename TYPE> void iterate_callstack(cell top, cell bottom, TYPE &iterator)
+{
+ return vm->iterate_callstack(top,bottom,iterator);
+}
+
+
+// data_heap.hpp
+/* Every object has a regular representation in the runtime, which makes GC
+much simpler. Every slot of the object until binary_payload_start is a pointer
+to some other object. */
+struct factorvm;
+inline void factorvm::do_slots(cell obj, void (* iter)(cell *,factorvm*))
+{
+ cell scan = obj;
+ cell payload_start = binary_payload_start((object *)obj);
+ cell end = obj + payload_start;
+
+ scan += sizeof(cell);
+
+ while(scan < end)
+ {
+ iter((cell *)scan,this);
+ scan += sizeof(cell);
+ }
+}
+
+inline void do_slots(cell obj, void (* iter)(cell *,factorvm*))
+{
+ return vm->do_slots(obj,iter);
+}
+
+}
extern factorvm *vm;
-//tagged.hpp
-
-template <typename TYPE>
-struct tagged
-{
- cell value_;
-
- cell value() const { return value_; }
- TYPE *untagged() const { return (TYPE *)(UNTAG(value_)); }
-
- cell type() const {
- cell tag = TAG(value_);
- if(tag == OBJECT_TYPE)
- return untagged()->h.hi_tag();
- else
- return tag;
- }
-
- bool type_p(cell type_) const { return type() == type_; }
-
- TYPE *untag_check() const {
- if(TYPE::type_number != TYPE_COUNT && !type_p(TYPE::type_number))
- type_error(TYPE::type_number,value_);
- return untagged();
- }
-
- explicit tagged(cell tagged) : value_(tagged) {
-#ifdef FACTOR_DEBUG
- untag_check();
-#endif
- }
-
- explicit tagged(TYPE *untagged) : value_(factor::tag(untagged)) {
-#ifdef FACTOR_DEBUG
- untag_check();
-#endif
- }
-
- TYPE *operator->() const { return untagged(); }
- cell *operator&() const { return &value_; }
-
- const tagged<TYPE>& operator=(const TYPE *x) { value_ = tag(x); return *this; }
- const tagged<TYPE>& operator=(const cell &x) { value_ = x; return *this; }
-
- bool operator==(const tagged<TYPE> &x) { return value_ == x.value_; }
- bool operator!=(const tagged<TYPE> &x) { return value_ != x.value_; }
-
- template<typename X> tagged<X> as() { return tagged<X>(value_); }
-};
-
-template <typename TYPE> TYPE *factorvm::untag_check(cell value)
-{
- return tagged<TYPE>(value).untag_check();
-}
-
-template <typename TYPE> TYPE *untag_check(cell value)
-{
- return vm->untag_check<TYPE>(value);
-}
-
-template <typename TYPE> TYPE *factorvm::untag(cell value)
-{
- return tagged<TYPE>(value).untagged();
-}
-
-template <typename TYPE> TYPE *untag(cell value)
-{
- return vm->untag<TYPE>(value);
-}
-
-
-
-// write_barrier.hpp
-
-inline card *factorvm::addr_to_card(cell a)
-{
- return (card*)(((cell)(a) >> card_bits) + cards_offset);
-}
-
-inline card *addr_to_card(cell a)
-{
- return vm->addr_to_card(a);
-}
-
-inline cell factorvm::card_to_addr(card *c)
-{
- return ((cell)c - cards_offset) << card_bits;
-}
-
-inline cell card_to_addr(card *c)
-{
- return vm->card_to_addr(c);
-}
-
-inline cell factorvm::card_offset(card *c)
-{
- return *(c - (cell)data->cards + (cell)data->allot_markers);
-}
-
-inline cell card_offset(card *c)
-{
- return vm->card_offset(c);
-}
-
-inline card_deck *factorvm::addr_to_deck(cell a)
-{
- return (card_deck *)(((cell)a >> deck_bits) + decks_offset);
-}
-
-inline card_deck *addr_to_deck(cell a)
-{
- return vm->addr_to_deck(a);
-}
-
-inline cell factorvm::deck_to_addr(card_deck *c)
-{
- return ((cell)c - decks_offset) << deck_bits;
-}
-
-inline cell deck_to_addr(card_deck *c)
-{
- return vm->deck_to_addr(c);
-}
-
-inline card *factorvm::deck_to_card(card_deck *d)
-{
- return (card *)((((cell)d - decks_offset) << (deck_bits - card_bits)) + cards_offset);
-}
-
-inline card *deck_to_card(card_deck *d)
-{
- return vm->deck_to_card(d);
-}
-
-inline card *factorvm::addr_to_allot_marker(object *a)
-{
- return (card *)(((cell)a >> card_bits) + allot_markers_offset);
-}
-
-inline card *addr_to_allot_marker(object *a)
-{
- return vm->addr_to_allot_marker(a);
-}
-
-/* the write barrier must be called any time we are potentially storing a
-pointer from an older generation to a younger one */
-inline void factorvm::write_barrier(object *obj)
-{
- *addr_to_card((cell)obj) = card_mark_mask;
- *addr_to_deck((cell)obj) = card_mark_mask;
-}
-
-inline void write_barrier(object *obj)
-{
- return vm->write_barrier(obj);
-}
-
-/* we need to remember the first object allocated in the card */
-inline void factorvm::allot_barrier(object *address)
-{
- card *ptr = addr_to_allot_marker(address);
- if(*ptr == invalid_allot_marker)
- *ptr = ((cell)address & addr_card_mask);
-}
-
-inline void allot_barrier(object *address)
-{
- return vm->allot_barrier(address);
-}
-
-
-//data_gc.hpp
-inline bool factorvm::collecting_accumulation_gen_p()
-{
- return ((data->have_aging_p()
- && collecting_gen == data->aging()
- && !collecting_aging_again)
- || collecting_gen == data->tenured());
-}
-
-inline bool collecting_accumulation_gen_p()
-{
- return vm->collecting_accumulation_gen_p();
-}
-
-inline object *factorvm::allot_zone(zone *z, cell a)
-{
- cell h = z->here;
- z->here = h + align8(a);
- object *obj = (object *)h;
- allot_barrier(obj);
- return obj;
-}
-
-inline object *allot_zone(zone *z, cell a)
-{
- return vm->allot_zone(z,a);
-}
-
-/*
- * It is up to the caller to fill in the object's fields in a meaningful
- * fashion!
- */
-inline object *factorvm::allot_object(header header, cell size)
-{
-#ifdef GC_DEBUG
- if(!gc_off)
- gc();
-#endif
-
- object *obj;
-
- if(nursery.size - allot_buffer_zone > size)
- {
- /* If there is insufficient room, collect the nursery */
- if(nursery.here + allot_buffer_zone + size > nursery.end)
- garbage_collection(data->nursery(),false,0);
-
- cell h = nursery.here;
- nursery.here = h + align8(size);
- obj = (object *)h;
- }
- /* If the object is bigger than the nursery, allocate it in
- tenured space */
- else
- {
- zone *tenured = &data->generations[data->tenured()];
-
- /* If tenured space does not have enough room, collect */
- if(tenured->here + size > tenured->end)
- {
- gc();
- tenured = &data->generations[data->tenured()];
- }
-
- /* If it still won't fit, grow the heap */
- if(tenured->here + size > tenured->end)
- {
- garbage_collection(data->tenured(),true,size);
- tenured = &data->generations[data->tenured()];
- }
-
- obj = allot_zone(tenured,size);
-
- /* Allows initialization code to store old->new pointers
- without hitting the write barrier in the common case of
- a nursery allocation */
- write_barrier(obj);
- }
-
- obj->h = header;
- return obj;
-}
-
-inline object *allot_object(header header, cell size)
-{
- return vm->allot_object(header,size);
-}
-
-template<typename TYPE> TYPE *factorvm::allot(cell size)
-{
- return (TYPE *)allot_object(header(TYPE::type_number),size);
-}
-
-template<typename TYPE> TYPE *allot(cell size)
-{
- return vm->allot<TYPE>(size);
-}
-
-inline void factorvm::check_data_pointer(object *pointer)
-{
-#ifdef FACTOR_DEBUG
- if(!growing_data_heap)
- {
- assert((cell)pointer >= data->seg->start
- && (cell)pointer < data->seg->end);
- }
-#endif
-}
-
-inline void check_data_pointer(object *pointer)
-{
- return vm->check_data_pointer(pointer);
-}
-
-inline void factorvm::check_tagged_pointer(cell tagged)
-{
-#ifdef FACTOR_DEBUG
- if(!immediate_p(tagged))
- {
- object *obj = untag<object>(tagged);
- check_data_pointer(obj);
- obj->h.hi_tag();
- }
-#endif
-}
-
-inline void check_tagged_pointer(cell tagged)
-{
- return vm->check_tagged_pointer(tagged);
-}
-
-//local_roots.hpp
-template <typename TYPE>
-struct gc_root : public tagged<TYPE>
-{
- factorvm *myvm;
-
- void push() { check_tagged_pointer(tagged<TYPE>::value()); myvm->gc_locals.push_back((cell)this); }
-
- //explicit gc_root(cell value_, factorvm *vm) : myvm(vm),tagged<TYPE>(value_) { push(); }
- explicit gc_root(cell value_,factorvm *vm) : tagged<TYPE>(value_),myvm(vm) { push(); }
- explicit gc_root(TYPE *value_, factorvm *vm) : tagged<TYPE>(value_),myvm(vm) { push(); }
-
- const gc_root<TYPE>& operator=(const TYPE *x) { tagged<TYPE>::operator=(x); return *this; }
- const gc_root<TYPE>& operator=(const cell &x) { tagged<TYPE>::operator=(x); return *this; }
-
- ~gc_root() {
-#ifdef FACTOR_DEBUG
- assert(myvm->gc_locals.back() == (cell)this);
-#endif
- myvm->gc_locals.pop_back();
- }
-};
-
-/* A similar hack for the bignum implementation */
-struct gc_bignum
-{
- bignum **addr;
- factorvm *myvm;
- gc_bignum(bignum **addr_, factorvm *vm) : addr(addr_), myvm(vm) {
- if(*addr_)
- check_data_pointer(*addr_);
- myvm->gc_bignums.push_back((cell)addr);
- }
-
- ~gc_bignum() {
-#ifdef FACTOR_DEBUG
- assert(myvm->gc_bignums.back() == (cell)addr);
-#endif
- myvm->gc_bignums.pop_back();
- }
-};
-
-#define GC_BIGNUM(x,vm) gc_bignum x##__gc_root(&x,vm)
-
-//generic_arrays.hpp
-template <typename TYPE> TYPE *factorvm::allot_array_internal(cell capacity)
-{
- TYPE *array = allot<TYPE>(array_size<TYPE>(capacity));
- array->capacity = tag_fixnum(capacity);
- return array;
-}
-
-template <typename TYPE> TYPE *allot_array_internal(cell capacity)
-{
- return vm->allot_array_internal<TYPE>(capacity);
-}
-
-template <typename TYPE> bool factorvm::reallot_array_in_place_p(TYPE *array, cell capacity)
-{
- return in_zone(&nursery,array) && capacity <= array_capacity(array);
-}
-
-template <typename TYPE> bool reallot_array_in_place_p(TYPE *array, cell capacity)
-{
- return vm->reallot_array_in_place_p<TYPE>(array,capacity);
-}
-
-template <typename TYPE> TYPE *factorvm::reallot_array(TYPE *array_, cell capacity)
-{
- gc_root<TYPE> array(array_,this);
-
- if(reallot_array_in_place_p(array.untagged(),capacity))
- {
- array->capacity = tag_fixnum(capacity);
- return array.untagged();
- }
- else
- {
- cell to_copy = array_capacity(array.untagged());
- if(capacity < to_copy)
- to_copy = capacity;
-
- TYPE *new_array = allot_array_internal<TYPE>(capacity);
-
- memcpy(new_array + 1,array.untagged() + 1,to_copy * TYPE::element_size);
- memset((char *)(new_array + 1) + to_copy * TYPE::element_size,
- 0,(capacity - to_copy) * TYPE::element_size);
-
- return new_array;
- }
-}
-
-//arrays.hpp
-inline void factorvm::set_array_nth(array *array, cell slot, cell value)
-{
-#ifdef FACTOR_DEBUG
- assert(slot < array_capacity(array));
- assert(array->h.hi_tag() == ARRAY_TYPE);
- check_tagged_pointer(value);
-#endif
- array->data()[slot] = value;
- write_barrier(array);
-}
-
-inline void set_array_nth(array *array, cell slot, cell value)
-{
- return vm->set_array_nth(array,slot,value);
-}
-
-struct growable_array {
- cell count;
- gc_root<array> elements;
-
- growable_array(factorvm *myvm, cell capacity = 10) : count(0), elements(allot_array(capacity,F),myvm) {}
-
- void add(cell elt);
- void trim();
-};
-
-//byte_arrays.hpp
-struct growable_byte_array {
- cell count;
- gc_root<byte_array> elements;
-
- growable_byte_array(factorvm *vm,cell capacity = 40) : count(0), elements(allot_byte_array(capacity),vm) { }
-
- void append_bytes(void *elts, cell len);
- void append_byte_array(cell elts);
-
- void trim();
-};
-
-//math.hpp
-inline cell factorvm::allot_integer(fixnum x)
-{
- if(x < fixnum_min || x > fixnum_max)
- return tag<bignum>(fixnum_to_bignum(x));
- else
- return tag_fixnum(x);
-}
-
-inline cell allot_integer(fixnum x)
-{
- return vm->allot_integer(x);
-}
-
-inline cell factorvm::allot_cell(cell x)
-{
- if(x > (cell)fixnum_max)
- return tag<bignum>(cell_to_bignum(x));
- else
- return tag_fixnum(x);
-}
-
-inline cell allot_cell(cell x)
-{
- return vm->allot_cell(x);
-}
-
-inline cell factorvm::allot_float(double n)
-{
- boxed_float *flo = allot<boxed_float>(sizeof(boxed_float));
- flo->n = n;
- return tag(flo);
-}
-
-inline cell allot_float(double n)
-{
- return vm->allot_float(n);
-}
-
-inline bignum *factorvm::float_to_bignum(cell tagged)
-{
- return double_to_bignum(untag_float(tagged));
-}
-
-inline bignum *float_to_bignum(cell tagged)
-{
- return vm->float_to_bignum(tagged);
-}
-
-inline double factorvm::bignum_to_float(cell tagged)
-{
- return bignum_to_double(untag<bignum>(tagged));
-}
-
-inline double bignum_to_float(cell tagged)
-{
- return vm->bignum_to_float(tagged);
-}
-
-inline double factorvm::untag_float(cell tagged)
-{
- return untag<boxed_float>(tagged)->n;
-}
-
-inline double untag_float(cell tagged)
-{
- return vm->untag_float(tagged);
-}
-
-inline double factorvm::untag_float_check(cell tagged)
-{
- return untag_check<boxed_float>(tagged)->n;
-}
-
-inline double untag_float_check(cell tagged)
-{
- return vm->untag_float_check(tagged);
-}
-
-inline fixnum factorvm::float_to_fixnum(cell tagged)
-{
- return (fixnum)untag_float(tagged);
-}
-
-inline static fixnum float_to_fixnum(cell tagged)
-{
- return vm->float_to_fixnum(tagged);
-}
-
-inline double factorvm::fixnum_to_float(cell tagged)
-{
- return (double)untag_fixnum(tagged);
-}
-
-inline double fixnum_to_float(cell tagged)
-{
- return vm->fixnum_to_float(tagged);
-}
-
-
-//callstack.hpp
-/* This is a little tricky. The iterator may allocate memory, so we
-keep the callstack in a GC root and use relative offsets */
-template<typename TYPE> void factorvm::iterate_callstack_object(callstack *stack_, TYPE &iterator)
-{
- gc_root<callstack> stack(stack_,vm);
- fixnum frame_offset = untag_fixnum(stack->length) - sizeof(stack_frame);
-
- while(frame_offset >= 0)
- {
- stack_frame *frame = stack->frame_at(frame_offset);
- frame_offset -= frame->size;
- iterator(frame,this);
- }
-}
-
-template<typename TYPE> void iterate_callstack_object(callstack *stack_, TYPE &iterator)
-{
- return vm->iterate_callstack_object(stack_,iterator);
-}
-
-//booleans.hpp
-inline cell factorvm::tag_boolean(cell untagged)
-{
- return (untagged ? T : F);
-}
-
-inline cell tag_boolean(cell untagged)
-{
- return vm->tag_boolean(untagged);
-}
-
-// callstack.hpp
-template<typename TYPE> void factorvm::iterate_callstack(cell top, cell bottom, TYPE &iterator)
-{
- stack_frame *frame = (stack_frame *)bottom - 1;
-
- while((cell)frame >= top)
- {
- iterator(frame,this);
- frame = frame_successor(frame);
- }
-}
-
-template<typename TYPE> void iterate_callstack(cell top, cell bottom, TYPE &iterator)
-{
- return vm->iterate_callstack(top,bottom,iterator);
-}
-
-
-// data_heap.hpp
-/* Every object has a regular representation in the runtime, which makes GC
-much simpler. Every slot of the object until binary_payload_start is a pointer
-to some other object. */
-struct factorvm;
-inline void factorvm::do_slots(cell obj, void (* iter)(cell *,factorvm*))
-{
- cell scan = obj;
- cell payload_start = binary_payload_start((object *)obj);
- cell end = obj + payload_start;
-
- scan += sizeof(cell);
-
- while(scan < end)
- {
- iter((cell *)scan,this);
- scan += sizeof(cell);
- }
-}
-
-inline void do_slots(cell obj, void (* iter)(cell *,factorvm*))
-{
- return vm->do_slots(obj,iter);
-}
-
-
}
projects / factor.git / commitdiff