! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces make math math.order math.parser sequences accessors
-kernel kernel.private layouts assocs words summary arrays
-combinators classes.algebra alien alien.c-types
-alien.strings alien.arrays alien.complex alien.libraries sets libc
-continuations.private fry cpu.architecture classes classes.struct locals
-source-files.errors slots parser generic.parser strings
+USING: namespaces make math math.order math.parser sequences
+accessors kernel layouts assocs words summary arrays combinators
+classes.algebra alien alien.private alien.c-types alien.strings
+alien.arrays alien.complex alien.libraries sets libc
+continuations.private fry cpu.architecture classes
+classes.struct locals source-files.errors slots parser
+generic.parser strings quotations
compiler.errors
compiler.alien
compiler.constants
box-parameters
] with-param-regs ;
-TUPLE: callback-context ;
-
-: current-callback ( -- id ) 2 special-object ;
-
-: wait-to-return ( token -- )
- dup current-callback eq? [
- drop
- ] [
- yield-hook get call( -- ) wait-to-return
- ] if ;
-
-: do-callback ( quot token -- )
- init-catchstack
- [ 2 set-special-object call ] keep
- wait-to-return ; inline
-
: callback-return-quot ( ctype -- quot )
return>> {
{ [ dup void? ] [ drop [ ] ] }
parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
: wrap-callback-quot ( params -- quot )
- [
- [ callback-prep-quot ]
- [ quot>> ]
- [ callback-return-quot ] tri 3append ,
- [ callback-context new do-callback ] %
- ] [ ] make ;
+ [ callback-prep-quot ] [ quot>> ] [ callback-return-quot ] tri 3append
+ yield-hook get
+ '[ _ _ do-callback ]
+ >quotation ;
M: ##alien-callback generate-insn
params>>
: callback-3 ( -- callback ) void { } "cdecl" [ 5 "x" set ] alien-callback ;
-[ t ] [
- namestack*
- 3 "x" set callback-3 callback_test_1
- namestack* eq?
-] unit-test
-
-[ 5 ] [
+[ t 3 5 ] [
[
- 3 "x" set callback-3 callback_test_1 "x" get
+ namestack*
+ 3 "x" set callback-3 callback_test_1
+ namestack* eq?
+ "x" get "x" get-global
] with-scope
] unit-test
-: callback-4 ( -- callback )
- void { } "cdecl" [ "Hello world" write ] alien-callback
- gc ;
-
-[ "Hello world" ] [
- [ callback-4 callback_test_1 ] with-string-writer
-] unit-test
-
: callback-5 ( -- callback )
void { } "cdecl" [ gc ] alien-callback ;
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences accessors combinators math namespaces
-init sets words assocs alien.libraries alien alien.c-types
-cpu.architecture fry stack-checker.backend stack-checker.errors
-stack-checker.visitor stack-checker.dependencies ;
+init sets words assocs alien.libraries alien alien.private
+alien.c-types cpu.architecture fry stack-checker.backend
+stack-checker.errors stack-checker.visitor
+stack-checker.dependencies ;
IN: stack-checker.alien
TUPLE: alien-node-params return parameters abi in-d out-d ;
\ set-special-object { object fixnum } { } define-primitive
+\ context-object { fixnum } { object } define-primitive
+\ context-object make-flushable
+
+\ set-context-object { object fixnum } { } define-primitive
+
\ (exists?) { string } { object } define-primitive
\ minor-gc { } { } define-primitive
quotations sequences splitting
stack-checker.backend
stack-checker.errors
-stack-checker.known-words
stack-checker.state
stack-checker.values
stack-checker.visitor ;
! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel math namespaces sequences system
-kernel.private byte-arrays byte-vectors arrays init ;
+kernel.private byte-arrays byte-vectors arrays init
+continuations.private ;
IN: alien
PREDICATE: pinned-alien < alien underlying>> not ;
: alien-assembly ( args... return parameters abi quot -- return... )
dup alien-assembly-error ;
+<PRIVATE
+
! 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
[ H{ } clone callbacks set-global ] "alien" add-startup-hook
-<PRIVATE
+! Every context object in the VM is identified from the Factor
+! side by a unique identifier
+TUPLE: context-id < identity-tuple ;
+
+C: <context-id> context-id
+
+: context-id ( -- id ) 2 context-object ;
+
+: set-context-id ( id -- ) 2 set-context-object ;
+
+: wait-to-return ( yield-quot id -- )
+ dup context-id eq?
+ [ 2drop ] [ over call( -- ) wait-to-return ] if ;
+
+! Used by compiler.codegen to wrap callback bodies
+: do-callback ( callback-quot yield-quot -- )
+ init-namespaces
+ init-catchstack
+ <context-id>
+ [ set-context-id drop call ] [ wait-to-return drop ] 3bi ; inline
+! A utility for defining global variables that are recompiled in
+! every session
TUPLE: expiry-check object alien ;
: recompute-value? ( check -- ? )
{ "call-clear" "kernel.private" "primitive_call_clear" (( quot -- * )) }
{ "check-datastack" "kernel.private" "primitive_check_datastack" (( array in# out# -- ? )) }
{ "compute-identity-hashcode" "kernel.private" "primitive_compute_identity_hashcode" (( obj -- )) }
+ { "context-object" "kernel.private" "primitive_context_object" (( n -- obj )) }
{ "innermost-frame-executing" "kernel.private" "primitive_innermost_stack_frame_executing" (( callstack -- obj )) }
{ "innermost-frame-scan" "kernel.private" "primitive_innermost_stack_frame_scan" (( callstack -- n )) }
+ { "set-context-object" "kernel.private" "primitive_set_context_object" (( obj n -- )) }
{ "set-datastack" "kernel.private" "primitive_set_datastack" (( ds -- )) }
{ "set-innermost-frame-quot" "kernel.private" "primitive_set_innermost_stack_frame_quot" (( n callstack -- )) }
{ "set-retainstack" "kernel.private" "primitive_set_retainstack" (( rs -- )) }
run-file
] [
"Cannot find " write write "." print
- "Please move " write image write " to the same directory as the Factor sources," print
+ "Please move " write image write " into the same directory as the Factor sources," print
"and try again." print
1 (exit)
] if
<PRIVATE
: catchstack* ( -- catchstack )
- 1 special-object { vector } declare ; inline
+ 1 context-object { vector } declare ; inline
: >c ( continuation -- ) catchstack* push ;
: dummy-1 ( -- obj ) f ;
: dummy-2 ( obj -- obj ) dup drop ;
-: init-catchstack ( -- ) V{ } clone 1 set-special-object ;
+: catchstack ( -- catchstack ) catchstack* clone ; inline
-PRIVATE>
+: set-catchstack ( catchstack -- )
+ >vector 1 set-context-object ; inline
-: catchstack ( -- catchstack ) catchstack* clone ; inline
+: init-catchstack ( -- ) f set-catchstack ;
-: set-catchstack ( catchstack -- ) >vector 1 set-special-object ; inline
+PRIVATE>
TUPLE: continuation data call retain name catch ;
datastack callstack retainstack namestack catchstack
<continuation> ;
+<PRIVATE
+
: >continuation< ( continuation -- data call retain name catch )
- {
- [ data>> ]
- [ call>> ]
- [ retain>> ]
- [ name>> ]
- [ catch>> ]
- } cleave ;
+ { [ data>> ] [ call>> ] [ retain>> ] [ name>> ] [ catch>> ] } cleave ;
+
+PRIVATE>
: ifcc ( capture restore -- )
[ dummy-1 continuation ] 2dip [ dummy-2 ] prepose ?if ; inline
<PRIVATE
: init-error-handler ( -- )
- V{ } clone set-catchstack
+ init-catchstack
! VM calls on error
[
! 63 = self
-! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2003, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel vectors sequences hashtables
arrays kernel.private math strings assocs ;
<PRIVATE
-: namestack* ( -- namestack ) 0 special-object { vector } declare ; inline
+: namestack* ( -- namestack ) 0 context-object { vector } declare ; inline
: >n ( namespace -- ) namestack* push ;
: ndrop ( -- ) namestack* pop* ;
: namespace ( -- namespace ) namestack* last ; inline
: namestack ( -- namestack ) namestack* clone ;
-: set-namestack ( namestack -- ) >vector 0 set-special-object ;
+: set-namestack ( namestack -- ) >vector 0 set-context-object ;
: global ( -- g ) 21 special-object { hashtable } declare ; inline
: init-namespaces ( -- ) global 1array set-namestack ;
: get ( variable -- value ) namestack* assoc-stack ; inline
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();
+ reset_context_objects();
+}
+
+void context::reset_datastack()
+{
+ datastack = datastack_region->start - sizeof(cell);
+}
+
+void context::reset_retainstack()
+{
+ retainstack = retainstack_region->start - sizeof(cell);
+}
+
+void context::reset_context_objects()
+{
+ memset_cell(context_objects,false_object,context_object_count * sizeof(cell));
}
context *factor_vm::alloc_context()
new_ctx->callstack_bottom = (stack_frame *)-1;
new_ctx->callstack_top = (stack_frame *)-1;
- /* save per-callback special_objects */
- new_ctx->current_callback_save = special_objects[OBJ_CURRENT_CALLBACK];
- new_ctx->catchstack_save = special_objects[OBJ_CATCHSTACK];
-
new_ctx->reset_datastack();
new_ctx->reset_retainstack();
+ new_ctx->reset_context_objects();
new_ctx->next = ctx;
ctx = new_ctx;
/* 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);
unused_contexts = NULL;
}
+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;
+}
+
bool factor_vm::stack_to_array(cell bottom, cell top)
{
fixnum depth = (fixnum)(top - bottom + sizeof(cell));
namespace factor
{
+static const cell context_object_count = 10;
+
+enum context_object {
+ OBJ_NAMESTACK,
+ OBJ_CATCHSTACK,
+ OBJ_CONTEXT_ID,
+};
+
/* Assembly code makes assumptions about the layout of this struct */
struct context {
/* C stack pointer on entry */
/* memory region holding current retain stack */
segment *retainstack_region;
- /* saved special_objects slots on entry to callback */
- cell catchstack_save;
- cell current_callback_save;
+ /* context-specific special objects, accessed by context-object and
+ set-context-object primitives */
+ cell context_objects[context_object_count];
context *next;
context(cell ds_size, cell rs_size);
+ void reset_datastack();
+ void reset_retainstack();
+ void reset_context_objects();
cell peek()
{
replace(tagged);
}
- void reset_datastack()
- {
- datastack = datastack_region->start - sizeof(cell);
- }
-
- void reset_retainstack()
- {
- retainstack = retainstack_region->start - sizeof(cell);
- }
-
static const cell stack_reserved = (64 * sizeof(cell));
void fix_stacks()
void factor_vm::primitive_special_object()
{
- fixnum e = untag_fixnum(ctx->peek());
- ctx->replace(special_objects[e]);
+ fixnum n = untag_fixnum(ctx->peek());
+ ctx->replace(special_objects[n]);
}
void factor_vm::primitive_set_special_object()
{
- fixnum e = untag_fixnum(ctx->pop());
+ fixnum n = untag_fixnum(ctx->pop());
cell value = ctx->pop();
- special_objects[e] = value;
+ special_objects[n] = value;
}
void factor_vm::primitive_identity_hashcode()
static const cell special_object_count = 70;
enum special_object {
- OBJ_NAMESTACK, /* used by library only */
- OBJ_CATCHSTACK, /* used by library only, per-callback */
-
- OBJ_CURRENT_CALLBACK = 2, /* used by library only, per-callback */
- OBJ_WALKER_HOOK, /* non-local exit hook, used by library only */
+ OBJ_WALKER_HOOK = 3, /* non-local exit hook, used by library only */
OBJ_CALLCC_1, /* used to pass the value in callcc1 */
ERROR_HANDLER_QUOT = 5, /* quotation called when VM throws an error */
PRIMITIVE(code_room)
PRIMITIVE(compact_gc)
PRIMITIVE(compute_identity_hashcode)
+PRIMITIVE(context_object)
PRIMITIVE(data_room)
PRIMITIVE(datastack)
PRIMITIVE(die)
PRIMITIVE(retainstack)
PRIMITIVE(save_image)
PRIMITIVE(save_image_and_exit)
+PRIMITIVE(set_context_object)
PRIMITIVE(set_datastack)
PRIMITIVE(set_innermost_stack_frame_quot)
PRIMITIVE(set_retainstack)
DECLARE_PRIMITIVE(code_room)
DECLARE_PRIMITIVE(compact_gc)
DECLARE_PRIMITIVE(compute_identity_hashcode)
+DECLARE_PRIMITIVE(context_object)
DECLARE_PRIMITIVE(data_room)
DECLARE_PRIMITIVE(datastack)
DECLARE_PRIMITIVE(die)
DECLARE_PRIMITIVE(retainstack)
DECLARE_PRIMITIVE(save_image)
DECLARE_PRIMITIVE(save_image_and_exit)
+DECLARE_PRIMITIVE(set_context_object)
DECLARE_PRIMITIVE(set_datastack)
DECLARE_PRIMITIVE(set_innermost_stack_frame_quot)
DECLARE_PRIMITIVE(set_retainstack)
cell visit_pointer(cell pointer);
void visit_handle(cell *handle);
+ void visit_object_array(cell *start, cell *end);
void visit_slots(object *ptr, cell payload_start);
void visit_slots(object *ptr);
void visit_stack_elements(segment *region, cell *top);
*handle = visit_pointer(*handle);
}
+template<typename Visitor>
+void slot_visitor<Visitor>::visit_object_array(cell *start, cell *end)
+{
+ while(start < end) visit_handle(start++);
+}
+
template<typename Visitor>
void slot_visitor<Visitor>::visit_slots(object *ptr, cell payload_start)
{
if(slot != end)
{
slot++;
- for(; slot < end; slot++) visit_handle(slot);
+ visit_object_array(slot,end);
}
}
template<typename Visitor>
void slot_visitor<Visitor>::visit_stack_elements(segment *region, cell *top)
{
- for(cell *ptr = (cell *)region->start; ptr <= top; ptr++)
- visit_handle(ptr);
+ visit_object_array((cell *)region->start,top + 1);
}
template<typename Visitor>
std::vector<data_root_range>::const_iterator end = parent->data_roots.end();
for(; iter < end; iter++)
- {
- data_root_range r = *iter;
- for(cell index = 0; index < r.len; index++)
- visit_handle(r.start + index);
- }
+ visit_object_array(iter->start,iter->start + iter->len);
}
template<typename Visitor>
visit_callback_roots();
visit_literal_table_roots();
- for(cell i = 0; i < special_object_count; i++)
- visit_handle(&parent->special_objects[i]);
+ visit_object_array(parent->special_objects,parent->special_objects + special_object_count);
}
template<typename Visitor>
{
visit_stack_elements(ctx->datastack_region,(cell *)ctx->datastack);
visit_stack_elements(ctx->retainstack_region,(cell *)ctx->retainstack);
-
- visit_handle(&ctx->catchstack_save);
- visit_handle(&ctx->current_callback_save);
+ visit_object_array(ctx->context_objects,ctx->context_objects + context_object_count);
ctx = ctx->next;
}
cell cards_offset;
cell decks_offset;
- /* TAGGED user environment data; see getenv/setenv prims */
+ /* Various special objects, accessed by special-object and
+ set-special-object primitives */
cell special_objects[special_object_count];
/* Data stack and retain stack sizes */
void nest_stacks();
void unnest_stacks();
void init_stacks(cell ds_size_, cell rs_size_);
+ void primitive_context_object();
+ void primitive_set_context_object();
bool stack_to_array(cell bottom, cell top);
cell array_to_stack(array *array, cell bottom);
void primitive_datastack();
projects / factor.git / commitdiff