Implement start-context and set-context primitives

basis/cpu/x86/32/bootstrap.factor

@@ -3,7 +3,7 @@
 USING: bootstrap.image.private kernel kernel.private namespaces
 system cpu.x86.assembler cpu.x86.assembler.operands layouts
 vocabs parser compiler.constants sequences math math.private
-generic.single.private ;
+generic.single.private threads.private ;
 IN: bootstrap.x86
 
 4 \ cell set
@@ -21,7 +21,7 @@ IN: bootstrap.x86
 : vm-reg ( -- reg ) ECX ;
 : ctx-reg ( -- reg ) EBP ;
 : nv-regs ( -- seq ) { ESI EDI EBX } ;
-: nv-reg ( -- reg ) nv-regs first ;
+: nv-reg ( -- reg ) EBX ;
 : ds-reg ( -- reg ) ESI ;
 : rs-reg ( -- reg ) EDI ;
 : fixnum>slot@ ( -- ) temp0 2 SAR ;
@@ -52,6 +52,7 @@ IN: bootstrap.x86
     ctx-reg vm-reg vm-context-offset [+] MOV ;
 
 : jit-save-context ( -- )
+    jit-load-context
     EDX ESP -4 [+] LEA
     ctx-reg context-callstack-top-offset [+] EDX MOV
     ctx-reg context-datastack-offset [+] ds-reg MOV
@@ -63,7 +64,6 @@ IN: bootstrap.x86
 
 [
     jit-load-vm
-    jit-load-context
     jit-save-context
     ! call the primitive
     ESP [] vm-reg MOV
@@ -96,7 +96,6 @@ IN: bootstrap.x86
     EAX quot-entry-point-offset [+] CALL
 
     jit-load-vm
-    jit-load-context
     jit-save-context
 
     ! load C callstack pointer
@@ -167,7 +166,6 @@ IN: bootstrap.x86
 
 [
     jit-load-vm
-    jit-load-context
     jit-save-context
 
     ! Store arguments
@@ -189,7 +187,6 @@ IN: bootstrap.x86
 ! frame, and the stack. The frame setup takes this into account.
 : jit-inline-cache-miss ( -- )
     jit-load-vm
-    jit-load-context
     jit-save-context
     ESP 4 [+] vm-reg MOV
     ESP [] EBX MOV
@@ -210,7 +207,6 @@ IN: bootstrap.x86
 : jit-overflow ( insn func -- )
     ds-reg 4 SUB
     jit-load-vm
-    jit-load-context
     jit-save-context
     EAX ds-reg [] MOV
     EDX ds-reg 4 [+] MOV
@@ -233,7 +229,6 @@ IN: bootstrap.x86
 [
     ds-reg 4 SUB
     jit-load-vm
-    jit-load-context
     jit-save-context
     EBX ds-reg [] MOV
     EAX EBX MOV
@@ -252,5 +247,58 @@ IN: bootstrap.x86
     jit-conditional
 ] \ fixnum* define-sub-primitive
 
+! Threads
+: jit-set-context ( reg -- )
+    ! Save ds, rs registers
+    jit-load-vm
+    jit-save-context
+
+    ! Make the new context the current one
+    ctx-reg swap MOV
+    vm-reg vm-context-offset [+] ctx-reg MOV
+
+    ! Load new stack pointer
+    ESP ctx-reg context-callstack-top-offset [+] MOV
+
+    ! Load new ds, rs registers
+    jit-restore-context ;
+
+[
+    ! Create the new context in return-reg
+    jit-load-vm
+    ESP [] vm-reg MOV
+    "new_context" jit-call
+
+    ! Save pointer to quotation and parameter, pop them off the
+    ! datastack
+    EBX ds-reg MOV
+    ds-reg 8 SUB
+
+    ! Make the new context the active context
+    EAX jit-set-context
+
+    ! Push parameter
+    EAX EBX -4 [+] MOV
+    ds-reg 4 ADD
+    ds-reg [] EAX MOV
+
+    ! Jump to initial quotation
+    EAX EBX [] MOV
+    EAX quot-entry-point-offset [+] JMP
+] \ (start-context) define-sub-primitive
+
+[
+    ! Load context from datastack
+    EAX ds-reg [] MOV
+    EAX EAX alien-offset [+] MOV
+    ds-reg 4 SUB
+
+    ! Make it the active context
+    EAX jit-set-context
+
+    ! Twiddle stack for return
+    ESP 4 ADD
+] \ (set-context) define-sub-primitive
+
 << "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >>
 call

basis/cpu/x86/64/bootstrap.factor

@@ -3,7 +3,7 @@
 USING: bootstrap.image.private kernel kernel.private namespaces
 system layouts vocabs parser compiler.constants math
 math.private cpu.x86.assembler cpu.x86.assembler.operands
-sequences generic.single.private ;
+sequences generic.single.private threads.private ;
 IN: bootstrap.x86
 
 8 \ cell set
@@ -16,7 +16,7 @@ IN: bootstrap.x86
 : temp2 ( -- reg ) RDX ;
 : temp3 ( -- reg ) RBX ;
 : return-reg ( -- reg ) RAX ;
-: nv-reg ( -- reg ) nv-regs first ;
+: nv-reg ( -- reg ) RBX ;
 : stack-reg ( -- reg ) RSP ;
 : frame-reg ( -- reg ) RBP ;
 : ctx-reg ( -- reg ) R12 ;
@@ -51,8 +51,8 @@ IN: bootstrap.x86
 
 : jit-save-context ( -- )
     jit-load-context
-    RAX RSP -8 [+] LEA
+    R11 RSP -8 [+] LEA
-    ctx-reg context-callstack-top-offset [+] RAX MOV
+    ctx-reg context-callstack-top-offset [+] R11 MOV
     ctx-reg context-datastack-offset [+] ds-reg MOV
     ctx-reg context-retainstack-offset [+] rs-reg MOV ;
 
@@ -222,5 +222,57 @@ IN: bootstrap.x86
     jit-conditional
 ] \ fixnum* define-sub-primitive
 
+! Threads
+: jit-set-context ( reg -- )
+    ! Save ds, rs registers
+    jit-save-context
+
+    ! Make the new context the current one
+    ctx-reg swap MOV
+    vm-reg vm-context-offset [+] ctx-reg MOV
+
+    ! Load new stack pointer
+    RSP ctx-reg context-callstack-top-offset [+] MOV
+
+    ! Load new ds, rs registers
+    jit-restore-context ;
+
+[
+    ! Create the new context in return-reg
+    arg1 vm-reg MOV
+    "new_context" jit-call
+
+    ! Load quotation from datastack
+    arg1 ds-reg [] MOV
+
+    ! Load parameter from datastack
+    arg2 ds-reg -8 [+] MOV
+
+    ds-reg 16 SUB
+
+    ! Make the new context the active context
+    return-reg jit-set-context
+
+    ! Push parameter
+    ds-reg 8 ADD
+    ds-reg [] arg2 MOV
+
+    ! Jump to initial quotation
+    arg1 quot-entry-point-offset [+] JMP
+] \ (start-context) define-sub-primitive
+
+[
+    ! Load context from datastack
+    temp0 ds-reg [] MOV
+    temp0 temp0 alien-offset [+] MOV
+    ds-reg 8 SUB
+
+    ! Make it the active context
+    temp0 jit-set-context
+
+    ! Twiddle stack for return
+    RSP 8 ADD
+] \ (set-context) define-sub-primitive
+
 << "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >>
 call

basis/cpu/x86/bootstrap.factor

@@ -42,7 +42,8 @@ big-endian off
     nv-reg 0 MOV rc-absolute-cell rt-entry-point jit-rel
     nv-reg CALL
 
-    ! Load VM into vm-reg
+    ! Load VM into vm-reg; only needed on x86-32, but doesn't
+    ! hurt on x86-64
     vm-reg 0 MOV rc-absolute-cell rt-vm jit-rel
 
     ! Load C callstack pointer

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

@@ -513,7 +513,9 @@ M: bad-executable summary
 
 \ delete-context { c-ptr } { } define-primitive
 
-\ start-context { quotation } { } define-primitive
+\ (start-context) { object quotation } { } define-primitive
+
+\ (set-context) { alien } { } define-primitive
 
 \ special-object { fixnum } { object } define-primitive
 \ special-object make-flushable

basis/threads/threads.factor

@@ -7,6 +7,16 @@ dlists assocs system combinators combinators.private init boxes
 accessors math.order deques strings quotations fry ;
 IN: threads
 
+<PRIVATE
+
+! (set-context) and (start-context) are sub-primitives, but
+! we don't want them inlined into callers since their behavior
+! depends on what frames are on the callstack
+: start-context ( obj quot: ( obj -- * ) -- ) (start-context) ;
+: set-context ( context -- ) (set-context) ;
+
+PRIVATE>
+
 SYMBOL: initial-thread
 
 TUPLE: thread

core/bootstrap/primitives.factor

@@ -369,6 +369,8 @@ tuple
     { "fixnum<=" "math.private" (( x y -- z )) }
     { "fixnum>" "math.private" (( x y -- ? )) }
     { "fixnum>=" "math.private" (( x y -- ? )) }
+    { "(set-context)" "threads.private" (( context -- )) }
+    { "(start-context)" "threads.private" (( obj quot -- )) }
 } [ first3 make-sub-primitive ] each
 
 ! Primitive words
@@ -534,9 +536,8 @@ tuple
     { "nano-count" "system" "primitive_nano_count" (( -- ns )) }
     { "system-micros" "system" "primitive_system_micros" (( -- us )) }
     { "(sleep)" "threads.private" "primitive_sleep" (( nanos -- )) }
-    { "current-context" "threads.private" "primitive_current_context" (( -- c-ptr )) }
+    { "context" "threads.private" "primitive_context" (( -- c-ptr )) }
     { "delete-context" "threads.private" "primitive_delete_context" (( c-ptr -- )) }
-    { "start-context" "threads.private" "primitive_start_context" (( quot -- )) }
     { "dispatch-stats" "tools.dispatch.private" "primitive_dispatch_stats" (( -- stats )) }
     { "reset-dispatch-stats" "tools.dispatch.private" "primitive_reset_dispatch_stats" (( -- )) }
     { "profiling" "tools.profiler.private" "primitive_profiling" (( ? -- )) }

vm/contexts.cpp

@@ -97,6 +97,11 @@ context *factor_vm::new_context()
 	return new_context;
 }
 
+context *new_context(factor_vm *parent)
+{
+	return parent->new_context();
+}
+
 void factor_vm::delete_context(context *old_context)
 {
 	unused_contexts.push_back(old_context);
@@ -225,18 +230,11 @@ void factor_vm::primitive_load_locals()
 	ctx->retainstack += sizeof(cell) * count;
 }
 
-void factor_vm::primitive_current_context()
+void factor_vm::primitive_context()
 {
 	ctx->push(allot_alien(ctx));
 }
 
-void factor_vm::primitive_start_context()
-{
-	cell quot = ctx->pop();
-	ctx = new_context();
-	unwind_native_frames(quot,ctx->callstack_bottom);
-}
-
 void factor_vm::primitive_delete_context()
 {
 	context *old_context = (context *)pinned_alien_offset(ctx->pop());

vm/contexts.hpp

@@ -79,7 +79,8 @@ struct context {
 	}
 };
 
-VM_C_API void begin_callback(factor_vm *vm);
+VM_C_API context *new_context(factor_vm *parent);
-VM_C_API void end_callback(factor_vm *vm);
+VM_C_API void begin_callback(factor_vm *parent);
+VM_C_API void end_callback(factor_vm *parent);
 
 }

vm/primitives.hpp

@@ -43,9 +43,9 @@ namespace factor
 	_(code_room) \
 	_(compact_gc) \
 	_(compute_identity_hashcode) \
+	_(context) \
 	_(context_object) \
 	_(current_callback) \
-	_(current_context) \
 	_(data_room) \
 	_(datastack) \
 	_(delete_context) \
@@ -122,7 +122,6 @@ namespace factor
 	_(size) \
 	_(sleep) \
 	_(special_object) \
-	_(start_context) \
 	_(string) \
 	_(string_nth) \
 	_(strip_stack_traces) \

vm/vm.hpp

@@ -125,8 +125,7 @@ struct factor_vm
 	void primitive_set_retainstack();
 	void primitive_check_datastack();
 	void primitive_load_locals();
-	void primitive_current_context();
+	void primitive_context();
-	void primitive_start_context();
 	void primitive_delete_context();
 
 	template<typename Iterator> void iterate_active_callstacks(Iterator &iter)