Merge branch 'master' of git://factorcode.org/git/factor into conditional

basis/compiler/codegen/codegen.factor

@@ -1,11 +1,12 @@
 ! 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
+USING: namespaces make math math.order math.parser sequences
-kernel kernel.private layouts assocs words summary arrays
+accessors kernel layouts assocs words summary arrays combinators
-combinators classes.algebra alien alien.c-types
+classes.algebra alien alien.private alien.c-types alien.strings
-alien.strings alien.arrays alien.complex alien.libraries sets libc
+alien.arrays alien.complex alien.libraries sets libc
-continuations.private fry cpu.architecture classes classes.struct locals
+continuations.private fry cpu.architecture classes
-source-files.errors slots parser generic.parser strings
+classes.struct locals source-files.errors slots parser
+generic.parser strings quotations
 compiler.errors
 compiler.alien
 compiler.constants
@@ -461,22 +462,6 @@ M: ##alien-indirect generate-insn
         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 [ ] ] }
@@ -488,12 +473,10 @@ TUPLE: callback-context ;
     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-prep-quot ]
+     yield-hook get
-        [ quot>> ]
+     '[ _ _ do-callback ]
-        [ callback-return-quot ] tri 3append ,
+     >quotation ;
-        [ callback-context new do-callback ] %
-    ] [ ] make ;
 
 M: ##alien-callback generate-insn
     params>>

basis/compiler/tests/alien.factor

@@ -330,26 +330,15 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
 
 : callback-3 ( -- callback ) void { } "cdecl" [ 5 "x" set ] alien-callback ;
 
-[ t ] [
+[ t 3 5 ] [
-    namestack*
-    3 "x" set callback-3 callback_test_1
-    namestack* eq?
-] unit-test
-
-[ 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 ;
 

basis/stack-checker/alien/alien.factor

@@ -1,9 +1,10 @@
 ! 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
+init sets words assocs alien.libraries alien alien.private
-cpu.architecture fry stack-checker.backend stack-checker.errors
+alien.c-types cpu.architecture fry stack-checker.backend
-stack-checker.visitor stack-checker.dependencies ;
+stack-checker.errors stack-checker.visitor
+stack-checker.dependencies ;
 IN: stack-checker.alien
 
 TUPLE: alien-node-params return parameters abi in-d out-d ;

basis/stack-checker/known-words/known-words.factor

@@ -509,6 +509,11 @@ M: bad-executable summary
 
 \ 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

basis/stack-checker/row-polymorphism/row-polymorphism.factor

@@ -4,7 +4,6 @@ continuations effects fry kernel locals math math.order namespaces
 quotations sequences splitting
 stack-checker.backend
 stack-checker.errors
-stack-checker.known-words
 stack-checker.state
 stack-checker.values
 stack-checker.visitor ;

core/alien/alien.factor

@@ -1,7 +1,8 @@
 ! 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 ;
@@ -83,6 +84,8 @@ ERROR: alien-assembly-error code ;
 : 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
@@ -91,8 +94,29 @@ SYMBOL: callbacks
 
 [ 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 -- ? )

core/bootstrap/primitives.factor

@@ -447,8 +447,10 @@ tuple
     { "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 -- )) }

core/bootstrap/stage1.factor

@@ -40,7 +40,7 @@ load-help? off
             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

core/continuations/continuations.factor

@@ -13,7 +13,7 @@ SYMBOL: restarts
 <PRIVATE
 
 : catchstack* ( -- catchstack )
-    1 special-object { vector } declare ; inline
+    1 context-object { vector } declare ; inline
 
 : >c ( continuation -- ) catchstack* push ;
 
@@ -23,13 +23,14 @@ SYMBOL: restarts
 : dummy-1 ( -- obj ) f ;
 : dummy-2 ( obj -- obj ) dup drop ;
 
-: init-catchstack ( -- ) V{ } clone 1 set-special-object ;
-
-PRIVATE>
-
 : catchstack ( -- catchstack ) catchstack* clone ; inline
 
-: set-catchstack ( catchstack -- ) >vector 1 set-special-object ; inline
+: set-catchstack ( catchstack -- )
+    >vector 1 set-context-object ; inline
+
+: init-catchstack ( -- ) f set-catchstack ;
+
+PRIVATE>
 
 TUPLE: continuation data call retain name catch ;
 
@@ -39,14 +40,12 @@ C: <continuation> continuation
     datastack callstack retainstack namestack catchstack
     <continuation> ;
 
+<PRIVATE
+
 : >continuation< ( continuation -- data call retain name catch )
-    {
+    { [ data>> ] [ call>> ] [ retain>> ] [ name>> ] [ catch>> ] } cleave ;
-        [ data>>   ]
+
-        [ call>>   ]
+PRIVATE>
-        [ retain>> ]
-        [ name>>   ]
-        [ catch>>  ]
-    } cleave ;
 
 : ifcc ( capture restore -- )
     [ dummy-1 continuation ] 2dip [ dummy-2 ] prepose ?if ; inline
@@ -172,7 +171,7 @@ M: condition compute-restarts
 <PRIVATE
 
 : init-error-handler ( -- )
-    V{ } clone set-catchstack
+    init-catchstack
     ! VM calls on error
     [
         ! 63 = self

core/namespaces/namespaces.factor

@@ -1,4 +1,4 @@
-! 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 ;
@@ -6,7 +6,7 @@ IN: namespaces
 
 <PRIVATE
 
-: namestack* ( -- namestack ) 0 special-object { vector } declare ; inline
+: namestack* ( -- namestack ) 0 context-object { vector } declare ; inline
 : >n ( namespace -- ) namestack* push ;
 : ndrop ( -- ) namestack* pop* ;
 
@@ -14,7 +14,7 @@ PRIVATE>
 
 : 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

extra/mason/test/test.factor

@@ -58,19 +58,21 @@ M: method word-vocabulary "method-generic" word-prop word-vocabulary ;
     compiler-error-messages-file
     do-step ;
 
-: check-boot-image ( -- )
+: outdated-core-vocabs ( -- modified-sources modified-docs any? )
-    "" to-refresh drop 2dup [ empty? not ] either?
+    "" to-refresh drop 2dup [ empty? not ] either? ;
-    [
+
-        "Boot image is out of date. Changed vocabs:" print
+: outdated-boot-image. ( modified-sources modified-docs -- )
-        members [ print ] each
+    "Boot image is out of date. Changed vocabs:" print
-        flush
+    union [ print ] each
-        1 exit
+    flush ;
-    ] [ 2drop ] if ;
+
+: check-boot-image ( -- ? )
+    outdated-core-vocabs [ outdated-boot-image. t ] [ 2drop f ] if ;
 
 : do-all ( -- )
     ".." [
         bootstrap-time get boot-time-file to-file
-        check-boot-image
+        check-boot-image [ 1 exit ] when
         [ do-load ] benchmark load-time-file to-file
         [ generate-help ] benchmark html-help-time-file to-file
         [ do-tests ] benchmark test-time-file to-file

vm/contexts.cpp

@@ -10,12 +10,26 @@ context::context(cell ds_size, cell rs_size) :
 	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()
@@ -47,12 +61,9 @@ void factor_vm::nest_stacks()
 	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;
@@ -66,10 +77,6 @@ void nest_stacks(factor_vm *parent)
 /* 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);
@@ -89,6 +96,19 @@ void factor_vm::init_stacks(cell ds_size_, cell rs_size_)
 	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));

vm/contexts.hpp

@@ -1,6 +1,14 @@
 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 */
@@ -19,13 +27,16 @@ struct context {
 	/* memory region holding current retain stack */
 	segment *retainstack_region;
 
-	/* saved special_objects slots on entry to callback */
+	/* context-specific special objects, accessed by context-object and
-	cell catchstack_save;
+	set-context-object primitives */
-	cell current_callback_save;
+	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()
 	{
@@ -50,16 +61,6 @@ struct context {
 		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()

vm/objects.cpp

@@ -5,15 +5,15 @@ namespace factor
 
 void factor_vm::primitive_special_object()
 {
-	fixnum e = untag_fixnum(ctx->peek());
+	fixnum n = untag_fixnum(ctx->peek());
-	ctx->replace(special_objects[e]);
+	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()

vm/objects.hpp

@@ -4,11 +4,7 @@ namespace factor
 static const cell special_object_count = 70;
 
 enum special_object {
-	OBJ_NAMESTACK,             /* used by library only */
+	OBJ_WALKER_HOOK = 3,       /* non-local exit hook, 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_CALLCC_1,              /* used to pass the value in callcc1 */
 
 	ERROR_HANDLER_QUOT = 5,    /* quotation called when VM throws an error */

vm/primitives.cpp

@@ -47,6 +47,7 @@ PRIMITIVE(code_blocks)
 PRIMITIVE(code_room)
 PRIMITIVE(compact_gc)
 PRIMITIVE(compute_identity_hashcode)
+PRIMITIVE(context_object)
 PRIMITIVE(data_room)
 PRIMITIVE(datastack)
 PRIMITIVE(die)
@@ -111,6 +112,7 @@ PRIMITIVE(resize_string)
 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)

vm/primitives.hpp

@@ -43,6 +43,7 @@ DECLARE_PRIMITIVE(code_blocks)
 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)
@@ -107,6 +108,7 @@ DECLARE_PRIMITIVE(resize_string)
 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)

vm/slot_visitor.hpp

@@ -26,6 +26,7 @@ template<typename Visitor> struct slot_visitor {
 
 	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);
@@ -55,6 +56,12 @@ void slot_visitor<Visitor>::visit_handle(cell *handle)
 	*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)
 {
@@ -64,7 +71,7 @@ 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);
 	}
 }
 
@@ -77,8 +84,7 @@ void slot_visitor<Visitor>::visit_slots(object *ptr)
 template<typename Visitor>
 void slot_visitor<Visitor>::visit_stack_elements(segment *region, cell *top)
 {
-	for(cell *ptr = (cell *)region->start; ptr <= top; ptr++)
+	visit_object_array((cell *)region->start,top + 1);
-		visit_handle(ptr);
 }
 
 template<typename Visitor>
@@ -88,11 +94,7 @@ void slot_visitor<Visitor>::visit_data_roots()
 	std::vector<data_root_range>::const_iterator end = parent->data_roots.end();
 
 	for(; iter < end; iter++)
-	{
+		visit_object_array(iter->start,iter->start + iter->len);
-		data_root_range r = *iter;
-		for(cell index = 0; index < r.len; index++)
-			visit_handle(r.start + index);
-	}
 }
 
 template<typename Visitor>
@@ -162,8 +164,7 @@ void slot_visitor<Visitor>::visit_roots()
 	visit_callback_roots();
 	visit_literal_table_roots();
 
-	for(cell i = 0; i < special_object_count; i++)
+	visit_object_array(parent->special_objects,parent->special_objects + special_object_count);
-		visit_handle(&parent->special_objects[i]);
 }
 
 template<typename Visitor>
@@ -175,9 +176,7 @@ void slot_visitor<Visitor>::visit_contexts()
 	{
 		visit_stack_elements(ctx->datastack_region,(cell *)ctx->datastack);
 		visit_stack_elements(ctx->retainstack_region,(cell *)ctx->retainstack);
-
+		visit_object_array(ctx->context_objects,ctx->context_objects + context_object_count);
-		visit_handle(&ctx->catchstack_save);
-		visit_handle(&ctx->current_callback_save);
 
 		ctx = ctx->next;
 	}

vm/vm.hpp

@@ -18,7 +18,8 @@ struct factor_vm
 	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 */
@@ -100,6 +101,8 @@ struct factor_vm
 	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();