vm/bignum.o \
vm/booleans.o \
vm/byte_arrays.o \
+ vm/callbacks.o \
vm/callstack.o \
vm/code_block.o \
vm/code_heap.o \
USERENV: jit-execute-call 43
USERENV: jit-declare-word 44
+USERENV: callback-stub 45
+
! PIC stubs
USERENV: pic-load 47
USERENV: pic-tag 48
"testing" callback-5 callback_test_1
] unit-test
-: callback-5a ( -- callback )
- "void" { } "cdecl" [ 8000000 f <array> drop ] alien-callback ;
+: callback-5b ( -- callback )
+ "void" { } "cdecl" [ compact-gc ] alien-callback ;
-! Hack; if we're on ARM, we probably don't have much RAM, so
-! skip this test.
-! cpu "arm" = [
-! [ "testing" ] [
-! "testing" callback-5a callback_test_1
-! ] unit-test
-! ] unless
+[ "testing" ] [
+ "testing" callback-5b callback_test_1
+] unit-test
: callback-6 ( -- callback )
"void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
FUNCTION: void this_does_not_exist ( ) ;
[ this_does_not_exist ] [ { "kernel-error" 10 f f } = ] must-fail-with
+
! fall-through on miss\r
] mega-lookup jit-define\r
\r
+[\r
+ 0 2 LOAD32 rc-absolute-cell rt-xt jit-rel\r
+ 2 MTCTR\r
+ BCTR\r
+] callback-stub jit-define\r
+\r
! ! ! Sub-primitives\r
\r
! Quotations and words\r
3 3 0 LWZ ;
M: ppc %nest-stacks ( -- )
- 3 %load-vm-addr
+ ! Save current frame. See comment in vm/contexts.hpp
+ 3 1 stack-frame get total-size>> 2 cells - ADDI
+ 4 %load-vm-addr
"nest_stacks" f %alien-invoke ;
M: ppc %unnest-stacks ( -- )
#! parameter being passed to a callback from C.
over [ load-return-reg ] [ 2drop ] if ;
-CONSTANT: vm-ptr-size 4
-
M:: x86.32 %box ( n rep func -- )
n rep (%box)
- rep rep-size vm-ptr-size + [
+ rep rep-size cell + [
push-vm-ptr
rep push-return-reg
func f %alien-invoke
M: x86.32 %box-long-long ( n func -- )
[ (%box-long-long) ] dip
- 8 vm-ptr-size + [
+ 12 [
push-vm-ptr
EDX PUSH
EAX PUSH
M:: x86.32 %box-large-struct ( n c-type -- )
! Compute destination address
EDX n struct-return@ LEA
- 8 vm-ptr-size + [
+ 12 [
push-vm-ptr
! Push struct size
c-type heap-size PUSH
M: x86.32 %box-small-struct ( c-type -- )
#! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
- 12 vm-ptr-size + [
+ 16 [
push-vm-ptr
heap-size PUSH
EDX PUSH
: %unbox-struct-1 ( -- )
#! Alien must be in EAX.
- 4 vm-ptr-size + [
+ 8 [
push-vm-ptr
EAX PUSH
"alien_offset" f %alien-invoke
: %unbox-struct-2 ( -- )
#! Alien must be in EAX.
- 4 vm-ptr-size + [
+ 8 [
push-vm-ptr
EAX PUSH
"alien_offset" f %alien-invoke
! Alien must be in EAX.
! Compute destination address
EDX n stack@ LEA
- 12 vm-ptr-size + [
+ 16 [
push-vm-ptr
! Push struct size
c-type heap-size PUSH
] with-aligned-stack ;
M: x86.32 %nest-stacks ( -- )
- 4 [
+ 8 [
push-vm-ptr
+ ! Save current frame. See comment in vm/contexts.hpp
+ EAX stack-reg stack-frame get total-size>> [+] LEA
+ EAX PUSH
"nest_stacks" f %alien-invoke
] with-aligned-stack ;
: temp1 ( -- reg ) EDX ;
: temp2 ( -- reg ) ECX ;
: temp3 ( -- reg ) EBX ;
+: safe-reg ( -- reg ) EAX ;
: stack-reg ( -- reg ) ESP ;
: ds-reg ( -- reg ) ESI ;
: rs-reg ( -- reg ) EDI ;
R11 CALL ;
M: x86.64 %nest-stacks ( -- )
- param-reg-1 %mov-vm-ptr
+ ! Save current frame. See comment in vm/contexts.hpp
+ param-reg-1 stack-reg stack-frame get total-size>> 3 cells - [+] LEA
+ param-reg-2 %mov-vm-ptr
"nest_stacks" f %alien-invoke ;
M: x86.64 %unnest-stacks ( -- )
: temp1 ( -- reg ) RSI ;
: temp2 ( -- reg ) RDX ;
: temp3 ( -- reg ) RBX ;
+: safe-reg ( -- reg ) RAX ;
: stack-reg ( -- reg ) RSP ;
: ds-reg ( -- reg ) R14 ;
: rs-reg ( -- reg ) R15 ;
! fall-through on miss
] mega-lookup jit-define
+[
+ safe-reg 0 MOV rc-absolute-cell rt-xt jit-rel
+ safe-reg JMP
+] callback-stub jit-define
+
! ! ! Sub-primitives
! Quotations and words
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences accessors combinators math namespaces
-init sets words alien.libraries
-alien alien.c-types
+init sets words assocs alien.libraries alien alien.c-types
stack-checker.backend stack-checker.errors stack-checker.visitor ;
IN: stack-checker.alien
! Quotation which coerces return value to required type
return-prep-quot infer-quot-here ;
-: register-callback ( word -- ) callbacks get conjoin ;
+: callback-xt ( word -- alien )
+ callbacks get [ <callback> ] cache ;
: callback-bottom ( params -- )
- xt>> [ [ register-callback ] [ word-xt drop <alien> ] bi ] curry
- infer-quot-here ;
+ xt>> [ callback-xt ] curry infer-quot-here ;
: infer-alien-callback ( -- )
alien-callback-params new
pop-literal nip >>abi
pop-literal nip >>parameters
pop-literal nip >>return
- gensym >>xt
+ "( callback )" f <word> >>xt
dup callback-bottom
#alien-callback, ;
\ (exists?) { string } { object } define-primitive
+\ minor-gc { } { } define-primitive
+
\ gc { } { } define-primitive
+\ compact-gc { } { } define-primitive
+
\ gc-stats { } { array } define-primitive
\ (save-image) { byte-array } { } define-primitive
\ inline-cache-stats { } { array } define-primitive
\ optimized? { word } { object } define-primitive
+
+\ strip-stack-traces { } { } define-primitive
+
+\ <callback> { word } { alien } define-primitive
}
} ;
-ARTICLE: "alien-callback-gc" "Callbacks and code GC"
-"A callback consits of two parts; the callback word, which pushes the address of the callback on the stack when executed, and the callback body itself. If the callback word is redefined, removed from the dictionary using " { $link forget } ", or recompiled, the callback body will not be reclaimed by the garbage collector, since potentially C code may be holding a reference to the callback body."
-$nl
-"This is the safest approach, however it can lead to code heap leaks when repeatedly reloading code which defines callbacks. If you are " { $emphasis "completely sure" } " that no running C code is holding a reference to any callbacks, you can blow them all away:"
-{ $code "USE: alien callbacks get clear-hash gc" }
-"This will reclaim all callback bodies which are otherwise unreachable from the dictionary (that is, their associated callback words have since been redefined, recompiled or forgotten)." ;
-
ARTICLE: "alien-callback" "Calling Factor from C"
"Callbacks can be defined and passed to C code as function pointers; the C code can then invoke the callback and run Factor code:"
{ $subsections
POSTPONE: CALLBACK:
}
"There are some caveats concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "."
-{ $subsections "alien-callback-gc" }
{ $see-also "byte-arrays-gc" } ;
ARTICLE: "alien-globals" "Accessing C global variables"
: alien-invoke ( ... return library function parameters -- ... )
2over alien-invoke-error ;
-! Callbacks are registered in a global hashtable. If you clear
-! this hashtable, they will all be blown away by code GC, beware.
+! Callbacks are registered in a global hashtable. Note that they
+! are also pinned in a special callback area, so clearing this
+! hashtable will not reclaim callbacks. It should only be
+! cleared on startup.
SYMBOL: callbacks
[ H{ } clone callbacks set-global ] "alien" add-init-hook
{ "getenv" "kernel.private" (( n -- obj )) }
{ "setenv" "kernel.private" (( obj n -- )) }
{ "(exists?)" "io.files.private" (( path -- ? )) }
+ { "minor-gc" "memory" (( -- )) }
{ "gc" "memory" (( -- )) }
+ { "compact-gc" "memory" (( -- )) }
{ "gc-stats" "memory" f }
{ "(save-image)" "memory.private" (( path -- )) }
{ "(save-image-and-exit)" "memory.private" (( path -- )) }
{ "quot-compiled?" "quotations" (( quot -- ? )) }
{ "vm-ptr" "vm" (( -- ptr )) }
{ "strip-stack-traces" "kernel.private" (( -- )) }
+ { "<callback>" "alien" (( word -- alien )) }
} [ [ first3 ] dip swap make-primitive ] each-index
! Bump build number
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+callback_heap::callback_heap(cell size, factor_vm *myvm_) :
+ seg(new segment(size,true)),
+ here(seg->start),
+ myvm(myvm_) {}
+
+callback_heap::~callback_heap()
+{
+ delete seg;
+ seg = NULL;
+}
+
+void factor_vm::init_callbacks(cell size)
+{
+ callbacks = new callback_heap(size,this);
+}
+
+void callback_heap::update(callback *stub)
+{
+ tagged<array> code_template(myvm->userenv[CALLBACK_STUB]);
+
+ cell rel_class = untag_fixnum(array_nth(code_template.untagged(),1));
+ cell offset = untag_fixnum(array_nth(code_template.untagged(),3));
+
+ myvm->store_address_in_code_block(rel_class,
+ (cell)(stub + 1) + offset,
+ (cell)(stub->compiled + 1));
+
+ flush_icache((cell)stub,stub->size);
+}
+
+callback *callback_heap::add(code_block *compiled)
+{
+ tagged<array> code_template(myvm->userenv[CALLBACK_STUB]);
+ tagged<byte_array> insns(array_nth(code_template.untagged(),0));
+ cell size = array_capacity(insns.untagged());
+
+ cell bump = align8(size) + sizeof(callback);
+ if(here + bump > seg->end) fatal_error("Out of callback space",0);
+
+ callback *stub = (callback *)here;
+ stub->compiled = compiled;
+ memcpy(stub + 1,insns->data<void>(),size);
+
+ stub->size = align8(size);
+ here += bump;
+
+ update(stub);
+
+ return stub;
+}
+
+void factor_vm::primitive_callback()
+{
+ tagged<word> w(dpop());
+ w.untag_check(this);
+
+ callback *stub = callbacks->add(w->code);
+ box_alien(stub + 1);
+}
+
+}
--- /dev/null
+namespace factor
+{
+
+struct callback {
+ cell size;
+ code_block *compiled;
+ void *code() { return (void *)(this + 1); }
+};
+
+struct callback_heap {
+ segment *seg;
+ cell here;
+ factor_vm *myvm;
+
+ explicit callback_heap(cell size, factor_vm *myvm);
+ ~callback_heap();
+
+ callback *callback_heap::add(code_block *compiled);
+ void update(callback *stub);
+
+ callback *next(callback *stub)
+ {
+ return (callback *)((cell)stub + stub->size + sizeof(callback));
+ }
+
+ template<typename Iterator> void iterate(Iterator &iter)
+ {
+ callback *scan = (callback *)seg->start;
+ callback *end = (callback *)here;
+ while(scan < end)
+ {
+ iter(scan);
+ scan = next(scan);
+ }
+ }
+};
+
+}
be calling it at all, so we leave it as it is for now. */
stack_frame *factor_vm::capture_start()
{
- stack_frame *frame = stack_chain->callstack_bottom - 1;
- while(frame >= stack_chain->callstack_top
- && frame_successor(frame) >= stack_chain->callstack_top)
- {
+ stack_frame *frame = ctx->callstack_bottom - 1;
+ while(frame >= ctx->callstack_top && frame_successor(frame) >= ctx->callstack_top)
frame = frame_successor(frame);
- }
return frame + 1;
}
void factor_vm::primitive_callstack()
{
stack_frame *top = capture_start();
- stack_frame *bottom = stack_chain->callstack_bottom;
+ stack_frame *bottom = ctx->callstack_bottom;
fixnum size = (cell)bottom - (cell)top;
if(size < 0)
{
callstack *stack = untag_check<callstack>(dpop());
- set_callstack(stack_chain->callstack_bottom,
+ set_callstack(ctx->callstack_bottom,
stack->top(),
untag_fixnum(stack->length),
memcpy);
/* called before entry into Factor code. */
void factor_vm::save_callstack_bottom(stack_frame *callstack_bottom)
{
- stack_chain->callstack_bottom = callstack_bottom;
+ ctx->callstack_bottom = callstack_bottom;
}
VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom, factor_vm *myvm)
case RT_DLSYM:
return 2;
case RT_THIS:
- case RT_STACK_CHAIN:
+ case RT_CONTEXT:
case RT_MEGAMORPHIC_CACHE_HITS:
case RT_CARDS_OFFSET:
case RT_DECKS_OFFSET:
}
case RT_THIS:
return (cell)(compiled + 1);
- case RT_STACK_CHAIN:
- return (cell)&stack_chain;
+ case RT_CONTEXT:
+ return (cell)&ctx;
case RT_UNTAGGED:
return untag_fixnum(ARG);
case RT_MEGAMORPHIC_CACHE_HITS:
#endif
store_address_in_code_block(relocation_class_of(rel),
- relocation_offset_of(rel) + (cell)compiled->xt(),
- compute_relocation(rel,index,compiled));
+ relocation_offset_of(rel) + (cell)compiled->xt(),
+ compute_relocation(rel,index,compiled));
}
struct word_references_updater {
{
heap_block *block = code->heap_allot(size + sizeof(code_block),type);
- /* If allocation failed, do a code GC */
+ /* If allocation failed, do a full GC and compact the code heap.
+ A full GC that occurs as a result of the data heap filling up does not
+ trigger a compaction. This setup ensures that most GCs do not compact
+ the code heap, but if the code fills up, it probably means it will be
+ fragmented after GC anyway, so its best to compact. */
if(block == NULL)
{
- primitive_full_gc();
+ primitive_compact_gc();
block = code->heap_allot(size + sizeof(code_block),type);
/* Insufficient room even after code GC, give up */
RT_THIS,
/* immediate literal */
RT_IMMEDIATE,
- /* address of stack_chain var */
- RT_STACK_CHAIN,
+ /* address of ctx var */
+ RT_CONTEXT,
/* untagged fixnum literal */
RT_UNTAGGED,
/* address of megamorphic_cache_hits var */
void factor_vm::forward_context_xts()
{
- context *ctx = stack_chain;
+ callframe_forwarder forwarder(this);
+ iterate_active_frames(forwarder);
+}
+
+struct callback_forwarder {
+ code_heap *code;
+ callback_heap *callbacks;
- while(ctx)
+ callback_forwarder(code_heap *code_, callback_heap *callbacks_) :
+ code(code_), callbacks(callbacks_) {}
+
+ void operator()(callback *stub)
{
- callframe_forwarder forwarder(this);
- iterate_callstack(ctx,forwarder);
- ctx = ctx->next;
+ stub->compiled = code->forward_code_block(stub->compiled);
+ callbacks->update(stub);
}
+};
+
+void factor_vm::forward_callback_xts()
+{
+ callback_forwarder forwarder(code,callbacks);
+ callbacks->iterate(forwarder);
}
/* Move all free space to the end of the code heap. Live blocks must be marked
{
code->compact_heap();
forward_object_xts();
- if(trace_contexts_p) forward_context_xts();
+ if(trace_contexts_p)
+ {
+ forward_context_xts();
+ forward_callback_xts();
+ }
}
struct stack_trace_stripper {
void trace_contexts()
{
- context *ctx = myvm->stack_chain;
+ context *ctx = myvm->ctx;
while(ctx)
{
be stored in registers, so callbacks must save and restore the correct values */
void factor_vm::save_stacks()
{
- if(stack_chain)
+ if(ctx)
{
- stack_chain->datastack = ds;
- stack_chain->retainstack = rs;
+ ctx->datastack = ds;
+ ctx->retainstack = rs;
}
}
}
/* called on entry into a compiled callback */
-void factor_vm::nest_stacks()
+void factor_vm::nest_stacks(stack_frame *magic_frame)
{
- context *new_context = alloc_context();
+ context *new_ctx = alloc_context();
- new_context->callstack_bottom = (stack_frame *)-1;
- new_context->callstack_top = (stack_frame *)-1;
+ new_ctx->callstack_bottom = (stack_frame *)-1;
+ new_ctx->callstack_top = (stack_frame *)-1;
/* note that these register values are not necessarily valid stack
pointers. they are merely saved non-volatile registers, and are
- Factor callback returns
- C function restores registers
- C function returns to Factor code */
- new_context->datastack_save = ds;
- new_context->retainstack_save = rs;
+ new_ctx->datastack_save = ds;
+ new_ctx->retainstack_save = rs;
+
+ new_ctx->magic_frame = magic_frame;
/* save per-callback userenv */
- new_context->current_callback_save = userenv[CURRENT_CALLBACK_ENV];
- new_context->catchstack_save = userenv[CATCHSTACK_ENV];
+ new_ctx->current_callback_save = userenv[CURRENT_CALLBACK_ENV];
+ new_ctx->catchstack_save = userenv[CATCHSTACK_ENV];
- new_context->next = stack_chain;
- stack_chain = new_context;
+ new_ctx->next = ctx;
+ ctx = new_ctx;
reset_datastack();
reset_retainstack();
}
-void nest_stacks(factor_vm *myvm)
+void nest_stacks(stack_frame *magic_frame, factor_vm *myvm)
{
- return myvm->nest_stacks();
+ return myvm->nest_stacks(magic_frame);
}
/* called when leaving a compiled callback */
void factor_vm::unnest_stacks()
{
- ds = stack_chain->datastack_save;
- rs = stack_chain->retainstack_save;
+ ds = ctx->datastack_save;
+ rs = ctx->retainstack_save;
/* restore per-callback userenv */
- userenv[CURRENT_CALLBACK_ENV] = stack_chain->current_callback_save;
- userenv[CATCHSTACK_ENV] = stack_chain->catchstack_save;
+ userenv[CURRENT_CALLBACK_ENV] = ctx->current_callback_save;
+ userenv[CATCHSTACK_ENV] = ctx->catchstack_save;
- context *old_ctx = stack_chain;
- stack_chain = old_ctx->next;
+ context *old_ctx = ctx;
+ ctx = old_ctx->next;
dealloc_context(old_ctx);
}
{
ds_size = ds_size_;
rs_size = rs_size_;
- stack_chain = NULL;
+ ctx = NULL;
unused_contexts = NULL;
}
/* saved contents of rs register on entry to callback */
cell retainstack_save;
+ /* callback-bottom stack frame, or NULL for top-level context.
+ When nest_stacks() is called, callstack layout with callbacks
+ is as follows:
+
+ [ C function ]
+ [ callback stub in code heap ] <-- this is the magic frame
+ [ native frame: c_to_factor() ]
+ [ callback quotation frame ] <-- first call frame in call stack
+
+ magic frame is retained so that it's XT can be traced and forwarded. */
+ stack_frame *magic_frame;
+
/* memory region holding current datastack */
segment *datastack_region;
context *next;
};
-#define ds_bot (stack_chain->datastack_region->start)
-#define ds_top (stack_chain->datastack_region->end)
-#define rs_bot (stack_chain->retainstack_region->start)
-#define rs_top (stack_chain->retainstack_region->end)
+#define ds_bot (ctx->datastack_region->start)
+#define ds_top (ctx->datastack_region->end)
+#define rs_bot (ctx->retainstack_region->start)
+#define rs_top (ctx->retainstack_region->end)
DEFPUSHPOP(d,ds)
DEFPUSHPOP(r,rs)
-VM_C_API void nest_stacks(factor_vm *vm);
+VM_C_API void nest_stacks(stack_frame *magic_frame, factor_vm *vm);
VM_C_API void unnest_stacks(factor_vm *vm);
}
{
print_string("==== CALL STACK:\n");
stack_frame_printer printer(this);
- iterate_callstack(stack_chain,printer);
+ iterate_callstack(ctx,printer);
}
void factor_vm::dump_cell(cell x)
actual stack pointer at the time, since the saved pointer is
not necessarily up to date at that point. */
if(callstack_top)
- {
- callstack_top = fix_callstack_top(callstack_top,
- stack_chain->callstack_bottom);
- }
+ callstack_top = fix_callstack_top(callstack_top,ctx->callstack_bottom);
else
- callstack_top = stack_chain->callstack_top;
+ callstack_top = ctx->callstack_top;
throw_impl(userenv[BREAK_ENV],callstack_top,this);
}
void factor_vm::primitive_call_clear()
{
- throw_impl(dpop(),stack_chain->callstack_bottom,this);
+ throw_impl(dpop(),ctx->callstack_bottom,this);
}
/* For testing purposes */
p->secure_gc = false;
p->fep = false;
+ p->signals = true;
#ifdef WINDOWS
p->console = false;
p->console = false;
#endif
+
+ p->callback_size = 256;
}
bool factor_vm::factor_arg(const vm_char* str, const vm_char* arg, cell* value)
for(i = 1; i < argc; i++)
{
- if(factor_arg(argv[i],STRING_LITERAL("-datastack=%d"),&p->ds_size));
- else if(factor_arg(argv[i],STRING_LITERAL("-retainstack=%d"),&p->rs_size));
- else if(factor_arg(argv[i],STRING_LITERAL("-young=%d"),&p->young_size));
- else if(factor_arg(argv[i],STRING_LITERAL("-aging=%d"),&p->aging_size));
- else if(factor_arg(argv[i],STRING_LITERAL("-tenured=%d"),&p->tenured_size));
- else if(factor_arg(argv[i],STRING_LITERAL("-codeheap=%d"),&p->code_size));
- else if(factor_arg(argv[i],STRING_LITERAL("-pic=%d"),&p->max_pic_size));
- else if(STRCMP(argv[i],STRING_LITERAL("-securegc")) == 0) p->secure_gc = true;
- else if(STRCMP(argv[i],STRING_LITERAL("-fep")) == 0) p->fep = true;
- else if(STRNCMP(argv[i],STRING_LITERAL("-i="),3) == 0) p->image_path = argv[i] + 3;
- else if(STRCMP(argv[i],STRING_LITERAL("-console")) == 0) p->console = true;
+ vm_char *arg = argv[i];
+ if(STRCMP(arg,"--") == 0) break;
+ else if(factor_arg(arg,STRING_LITERAL("-datastack=%d"),&p->ds_size));
+ else if(factor_arg(arg,STRING_LITERAL("-retainstack=%d"),&p->rs_size));
+ else if(factor_arg(arg,STRING_LITERAL("-young=%d"),&p->young_size));
+ else if(factor_arg(arg,STRING_LITERAL("-aging=%d"),&p->aging_size));
+ else if(factor_arg(arg,STRING_LITERAL("-tenured=%d"),&p->tenured_size));
+ else if(factor_arg(arg,STRING_LITERAL("-codeheap=%d"),&p->code_size));
+ else if(factor_arg(arg,STRING_LITERAL("-pic=%d"),&p->max_pic_size));
+ else if(factor_arg(arg,STRING_LITERAL("-callbacks=%d"),&p->callback_size));
+ else if(STRCMP(arg,STRING_LITERAL("-securegc")) == 0) p->secure_gc = true;
+ else if(STRCMP(arg,STRING_LITERAL("-fep")) == 0) p->fep = true;
+ else if(STRCMP(arg,STRING_LITERAL("-nosignals")) == 0) p->signals = false;
+ else if(STRNCMP(arg,STRING_LITERAL("-i="),3) == 0) p->image_path = arg + 3;
+ else if(STRCMP(arg,STRING_LITERAL("-console")) == 0) p->console = true;
}
}
/* Kilobytes */
p->ds_size = align_page(p->ds_size << 10);
p->rs_size = align_page(p->rs_size << 10);
+ p->callback_size = align_page(p->callback_size << 10);
/* Megabytes */
p->young_size <<= 20;
srand(current_micros());
init_ffi();
init_stacks(p->ds_size,p->rs_size);
+ init_callbacks(p->callback_size);
load_image(p);
init_c_io();
init_inline_caching(p->max_pic_size);
- init_signals();
+ if(p->signals)
+ init_signals();
if(p->console)
open_console();
{
if(p->fep) factorbug();
- nest_stacks();
+ nest_stacks(NULL);
c_to_factor_toplevel(userenv[BOOT_ENV]);
unnest_stacks();
}
/* Mark code blocks executing in currently active stack frames. */
void full_collector::mark_active_blocks()
{
- context *ctx = this->myvm->stack_chain;
-
- while(ctx)
- {
- stack_frame_marker marker(this);
- myvm->iterate_callstack(ctx,marker);
- ctx = ctx->next;
- }
+ stack_frame_marker marker(this);
+ myvm->iterate_active_frames(marker);
}
void full_collector::mark_object_code_block(object *obj)
}
}
+struct callback_tracer {
+ full_collector *collector;
+
+ callback_tracer(full_collector *collector_) : collector(collector_) {}
+
+ void operator()(callback *stub)
+ {
+ collector->mark_code_block(stub->compiled);
+ }
+};
+
+void full_collector::trace_callbacks()
+{
+ callback_tracer tracer(this);
+ myvm->callbacks->iterate(tracer);
+}
+
/* Trace all literals referenced from a code block. Only for aging and nursery collections */
void full_collector::trace_literal_references(code_block *compiled)
{
/* After growing the heap, we have to perform a full relocation to update
references to card and deck arrays. */
-struct after_growing_heap_updater {
+struct big_code_heap_updater {
factor_vm *myvm;
- after_growing_heap_updater(factor_vm *myvm_) : myvm(myvm_) {}
+ big_code_heap_updater(factor_vm *myvm_) : myvm(myvm_) {}
void operator()(heap_block *block)
{
/* After a full GC that did not grow the heap, we have to update references
to literals and other words. */
-struct after_full_updater {
+struct small_code_heap_updater {
factor_vm *myvm;
- after_full_updater(factor_vm *myvm_) : myvm(myvm_) {}
+ small_code_heap_updater(factor_vm *myvm_) : myvm(myvm_) {}
void operator()(heap_block *block)
{
{
collector.trace_contexts();
collector.mark_active_blocks();
+ collector.trace_callbacks();
}
collector.cheneys_algorithm();
/* In both cases, compact code heap before updating code blocks so that
XTs are correct after */
+void factor_vm::big_code_heap_update()
+{
+ big_code_heap_updater updater(this);
+ code->free_unmarked(updater);
+ code->clear_remembered_set();
+}
+
void factor_vm::collect_growing_heap(cell requested_bytes,
bool trace_contexts_p,
bool compact_code_heap_p)
if(compact_code_heap_p) compact_code_heap(trace_contexts_p);
- after_growing_heap_updater updater(this);
+ big_code_heap_update();
+}
+
+void factor_vm::small_code_heap_update()
+{
+ small_code_heap_updater updater(this);
code->free_unmarked(updater);
code->clear_remembered_set();
}
reset_generation(data->tenured);
collect_full_impl(trace_contexts_p);
- if(compact_code_heap_p) compact_code_heap(trace_contexts_p);
-
- after_full_updater updater(this);
- code->free_unmarked(updater);
- code->clear_remembered_set();
+ if(compact_code_heap_p)
+ {
+ compact_code_heap(trace_contexts_p);
+ big_code_heap_update();
+ }
+ else
+ small_code_heap_update();
}
}
full_collector(factor_vm *myvm_);
void mark_active_blocks();
void mark_object_code_block(object *object);
+ void trace_callbacks();
void trace_literal_references(code_block *compiled);
void mark_code_block(code_block *compiled);
void cheneys_algorithm();
current_gc = NULL;
}
-void factor_vm::primitive_full_gc()
+void factor_vm::primitive_minor_gc()
{
- gc(collect_full_op,
+ gc(collect_nursery_op,
0, /* requested size */
true, /* trace contexts? */
false /* compact code heap? */);
}
-void factor_vm::primitive_minor_gc()
+void factor_vm::primitive_full_gc()
{
- gc(collect_nursery_op,
+ gc(collect_full_op,
0, /* requested size */
true, /* trace contexts? */
false /* compact code heap? */);
void factor_vm::primitive_save_image()
{
/* do a full GC to push everything into tenured space */
- primitive_full_gc();
+ primitive_compact_gc();
gc_root<byte_array> path(dpop(),this);
path.untag_check(this);
bool secure_gc;
bool fep;
bool console;
+ bool signals;
cell max_pic_size;
+ cell callback_size;
};
}
#include "image.hpp"
#include "alien.hpp"
#include "code_heap.hpp"
+#include "callbacks.hpp"
#include "vm.hpp"
#include "tagged.hpp"
#include "local_roots.hpp"
PRIMITIVE_FORWARD(getenv)
PRIMITIVE_FORWARD(setenv)
PRIMITIVE_FORWARD(existsp)
+PRIMITIVE_FORWARD(minor_gc)
PRIMITIVE_FORWARD(full_gc)
+PRIMITIVE_FORWARD(compact_gc)
PRIMITIVE_FORWARD(gc_stats)
PRIMITIVE_FORWARD(save_image)
PRIMITIVE_FORWARD(save_image_and_exit)
PRIMITIVE_FORWARD(quot_compiled_p)
PRIMITIVE_FORWARD(vm_ptr)
PRIMITIVE_FORWARD(strip_stack_traces)
+PRIMITIVE_FORWARD(callback)
const primitive_type primitives[] = {
primitive_bignum_to_fixnum,
primitive_getenv,
primitive_setenv,
primitive_existsp,
+ primitive_minor_gc,
primitive_full_gc,
+ primitive_compact_gc,
primitive_gc_stats,
primitive_save_image,
primitive_save_image_and_exit,
primitive_quot_compiled_p,
primitive_vm_ptr,
primitive_strip_stack_traces,
+ primitive_callback,
};
}
cell factor_vm::lazy_jit_compile_impl(cell quot_, stack_frame *stack)
{
gc_root<quotation> quot(quot_,this);
- stack_chain->callstack_top = stack;
+ ctx->callstack_top = stack;
jit_compile(quot.value(),true);
return quot.value();
}
JIT_EXECUTE_CALL,
JIT_DECLARE_WORD,
+ /* Callback stub generation in callbacks.c */
+ CALLBACK_STUB = 45,
+
/* Polymorphic inline cache generation in inline_cache.c */
PIC_LOAD = 47,
PIC_TAG,
// First five fields accessed directly by assembler. See vm.factor
/* Current stacks */
- context *stack_chain;
+ context *ctx;
/* New objects are allocated here */
zone nursery;
/* Code heap */
code_heap *code;
+ /* Pinned callback stubs */
+ callback_heap *callbacks;
+
/* Only set if we're performing a GC */
gc_state *current_gc;
void save_stacks();
context *alloc_context();
void dealloc_context(context *old_context);
- void nest_stacks();
+ void nest_stacks(stack_frame *magic_frame);
void unnest_stacks();
void init_stacks(cell ds_size_, cell rs_size_);
bool stack_to_array(cell bottom, cell top);
void primitive_set_retainstack();
void primitive_check_datastack();
+ template<typename Iterator> void factor_vm::iterate_active_frames(Iterator &iter)
+ {
+ context *ctx = this->ctx;
+
+ while(ctx)
+ {
+ iterate_callstack(ctx,iter);
+ if(ctx->magic_frame) iter(ctx->magic_frame);
+ ctx = ctx->next;
+ }
+ }
+
// run
void primitive_getenv();
void primitive_setenv();
void collect_nursery();
void collect_aging();
void collect_to_tenured();
+ void big_code_heap_update();
+ void small_code_heap_update();
void collect_full_impl(bool trace_contexts_p);
void collect_growing_heap(cell requested_bytes, bool trace_contexts_p, bool compact_code_heap_p);
void collect_full(bool trace_contexts_p, bool compact_code_heap_p);
void record_gc_stats(generation_statistics *stats);
void gc(gc_op op, cell requested_bytes, bool trace_contexts_p, bool compact_code_heap_p);
- void primitive_full_gc();
void primitive_minor_gc();
+ void primitive_full_gc();
void primitive_compact_gc();
void primitive_gc_stats();
void clear_gc_stats();
void primitive_code_room();
void forward_object_xts();
void forward_context_xts();
+ void forward_callback_xts();
void compact_code_heap(bool trace_contexts_p);
void primitive_strip_stack_traces();
}
}
+ //callbacks
+ void factor_vm::init_callbacks(cell size);
+ void factor_vm::primitive_callback();
+
//image
void init_objects(image_header *h);
void load_data_heap(FILE *file, image_header *h, vm_parameters *p);
projects / factor.git / commitdiff