vm: actually use context callstacks when running code

diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor
index 3552f0bd92ca44c5bff578ca35d01d031a039f38..141a77d2b250af45e7eafdd3009407e5d6609987 100644 (file)
--- a/basis/bootstrap/image/image.factor
+++ b/basis/bootstrap/image/image.factor
@@ -129,8 +129,8 @@ SYMBOL: jit-literals
 : jit-vm ( offset rc -- )
     [ jit-parameter ] dip rt-vm jit-rel ;
 
-: jit-dlsym ( name library rc -- )
-    rt-dlsym jit-rel [ string>symbol jit-parameter ] bi@ ;
+: jit-dlsym ( name rc -- )
+    rt-dlsym jit-rel string>symbol jit-parameter f jit-parameter ;
 
 :: jit-conditional ( test-quot false-quot -- )
     [ 0 test-quot call ] B{ } make length :> len

diff --git a/basis/command-line/command-line-docs.factor b/basis/command-line/command-line-docs.factor
index 9a69614766843c5d9c31958072f88ddcf2471a5b..b17f8250dd34ffa31d1ed28c799273410be935e7 100644 (file)
--- a/basis/command-line/command-line-docs.factor
+++ b/basis/command-line/command-line-docs.factor
@@ -43,14 +43,16 @@ ARTICLE: "runtime-cli-args" "Command line switches for the VM"
     { { $snippet "-i=" { $emphasis "image" } } { "Specifies the image file to use; see " { $link "images" } } }
     { { $snippet "-datastack=" { $emphasis "n" } } "Data stack size, kilobytes" }
     { { $snippet "-retainstack=" { $emphasis "n" } } "Retain stack size, kilobytes" }
+    { { $snippet "-callstack=" { $emphasis "n" } } "Call stack size, kilobytes" }
     { { $snippet "-young=" { $emphasis "n" } } { "Size of youngest generation (0), megabytes" } }
     { { $snippet "-aging=" { $emphasis "n" } } "Size of aging generation (1), megabytes" }
     { { $snippet "-tenured=" { $emphasis "n" } } "Size of oldest generation (2), megabytes" }
     { { $snippet "-codeheap=" { $emphasis "n" } } "Code heap size, megabytes" }
+    { { $snippet "-callbacks=" { $emphasis "n" } } "Callback heap size, megabytes" }
     { { $snippet "-pic=" { $emphasis "n" } } "Maximum inline cache size. Setting of 0 disables inline caching, > 1 enables polymorphic inline caching" }
     { { $snippet "-securegc" } "If specified, unused portions of the data heap will be zeroed out after every garbage collection" }
 }
-"If an " { $snippet "-i=" } " switch is not present, the default image file is used, which is usually a file named " { $snippet "factor.image" } " in the same directory as the runtime executable (on Windows and Mac OS X) or the current directory (on Unix)." ;
+"If an " { $snippet "-i=" } " switch is not present, the default image file is used, which is usually a file named " { $snippet "factor.image" } " in the same directory as the Factor executable." ;
 
 ARTICLE: "bootstrap-cli-args" "Command line switches for bootstrap"
 "A number of command line switches can be passed to a bootstrap image to modify the behavior of the resulting image:"

diff --git a/basis/compiler/alien/alien.factor b/basis/compiler/alien/alien.factor
index 6a63b719dfb537da709be8fac6a8b6f0669e49fe..7426d7e9408770a921027d075010bd99c621cecb 100644 (file)
--- a/basis/compiler/alien/alien.factor
+++ b/basis/compiler/alien/alien.factor
@@ -1,17 +1,17 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel namespaces make math sequences layouts
 alien.c-types cpu.architecture ;
 IN: compiler.alien
 
-: large-struct? ( ctype -- ? )
+: large-struct? ( type -- ? )
     dup c-struct? [ return-struct-in-registers? not ] [ drop f ] if ;
 
 : alien-parameters ( params -- seq )
     dup parameters>>
     swap return>> large-struct? [ void* prefix ] when ;
 
-: alien-return ( params -- ctype )
+: alien-return ( params -- type )
     return>> dup large-struct? [ drop void ] when ;
 
 : c-type-stack-align ( type -- align )

diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 73cfd6b86e8bc29c8330689d91f3ef7bddc32ef4..430bd9550d3de57cef8b6e5f8c52c06abb8ecc9b 100755 (executable)
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -458,7 +458,7 @@ M: ##alien-indirect generate-insn
     ! Generate code for boxing input parameters in a callback.
     [
         dup \ %save-param-reg move-parameters
-        %nest-stacks
+        %begin-callback
         box-parameters
     ] with-param-regs ;
 
@@ -482,5 +482,4 @@ M: ##alien-callback generate-insn
     params>>
     [ registers>objects ]
     [ wrap-callback-quot %alien-callback ]
-    [ alien-return [ %unnest-stacks ] [ %callback-value ] if-void ]
-    tri ;
+    [ alien-return [ %end-callback ] [ %end-callback-value ] if-void ] tri ;

diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor
index 73e77cca4dd94f074b5f66acb75f9c2ee90d5794..9769b728015ecc8f5a3c88ab450ed08925601e59 100644 (file)
--- a/basis/compiler/constants/constants.factor
+++ b/basis/compiler/constants/constants.factor
@@ -28,10 +28,12 @@ CONSTANT: deck-bits 18
 : callstack-length-offset ( -- n ) 1 \ callstack type-number slot-offset ; inline
 : callstack-top-offset ( -- n ) 2 \ callstack type-number slot-offset ; inline
 : vm-context-offset ( -- n ) 0 bootstrap-cells ; inline
+: vm-spare-context-offset ( -- n ) 1 bootstrap-cells ; inline
 : context-callstack-top-offset ( -- n ) 0 bootstrap-cells ; inline
 : context-callstack-bottom-offset ( -- n ) 1 bootstrap-cells ; inline
 : context-datastack-offset ( -- n ) 2 bootstrap-cells ; inline
 : context-retainstack-offset ( -- n ) 3 bootstrap-cells ; inline
+: context-callstack-save-offset ( -- n ) 4 bootstrap-cells ; inline
 
 ! Relocation classes
 CONSTANT: rc-absolute-cell 0

diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor
index ad8dac3ef95c285042fa9c73be1f4480fa5b2879..692dbee4c54aeb03ab7fe38301c2dc64f2a7d9c5 100755 (executable)
--- a/basis/compiler/tests/alien.factor
+++ b/basis/compiler/tests/alien.factor
@@ -4,7 +4,7 @@ compiler continuations effects io io.backend io.pathnames
 io.streams.string kernel math memory namespaces
 namespaces.private parser quotations sequences
 specialized-arrays stack-checker stack-checker.errors
-system threads tools.test words alien.complex ;
+system threads tools.test words alien.complex concurrency.promises ;
 FROM: alien.c-types => float short ;
 SPECIALIZED-ARRAY: float
 SPECIALIZED-ARRAY: char
@@ -579,6 +579,21 @@ FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
 
 ] unless
 
+! Test interaction between threads and callbacks
+: thread-callback-1 ( -- callback )
+    int { } "cdecl" [ yield 100 ] alien-callback ;
+
+: thread-callback-2 ( -- callback )
+    int { } "cdecl" [ yield 200 ] alien-callback ;
+
+: thread-callback-invoker ( callback -- n )
+    int { } "cdecl" alien-indirect ;
+
+<promise> "p" set
+[ thread-callback-1 thread-callback-invoker "p" get fulfill ] in-thread
+[ 200 ] [ thread-callback-2 thread-callback-invoker ] unit-test
+[ 100 ] [ "p" get ?promise ] unit-test
+
 ! Regression: calling an undefined function would raise a protection fault
 FUNCTION: void this_does_not_exist ( ) ;
 

diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index 4d99b5a0edcea0591f32f60cd6cba923f2c359b5..b617746a06f81db50e7ddf101845c6efcb4fa36f 100644 (file)
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -582,13 +582,13 @@ HOOK: %prepare-alien-indirect cpu ( -- )
 
 HOOK: %alien-indirect cpu ( -- )
 
-HOOK: %alien-callback cpu ( quot -- )
+HOOK: %begin-callback cpu ( -- )
 
-HOOK: %callback-value cpu ( ctype -- )
+HOOK: %alien-callback cpu ( quot -- )
 
-HOOK: %nest-stacks cpu ( -- )
+HOOK: %end-callback cpu ( -- )
 
-HOOK: %unnest-stacks cpu ( -- )
+HOOK: %end-callback-value cpu ( c-type -- )
 
 HOOK: callback-return-rewind cpu ( params -- n )
 

diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor
index b2ae9c4e73afd6d2d54b48d5ecdd2cee265ab58f..58c0a4ef7b1c6bc9debb2deddef9c0edf12005c8 100644 (file)
--- a/basis/cpu/ppc/bootstrap.factor
+++ b/basis/cpu/ppc/bootstrap.factor
@@ -267,7 +267,7 @@ CONSTANT: ctx-reg 16
     jit-save-context\r
     3 6 MR\r
     4 vm-reg MR\r
-    0 5 LOAD32 "inline_cache_miss" f rc-absolute-ppc-2/2 jit-dlsym\r
+    0 5 LOAD32 "inline_cache_miss" rc-absolute-ppc-2/2 jit-dlsym\r
     5 MTLR\r
     BLRL\r
     jit-restore-context ;\r
@@ -392,7 +392,7 @@ CONSTANT: ctx-reg 16
     1 3 MR\r
     ! Call memcpy; arguments are now in the correct registers\r
     1 1 -64 STWU\r
-    0 2 LOAD32 "factor_memcpy" f rc-absolute-ppc-2/2 jit-dlsym\r
+    0 2 LOAD32 "factor_memcpy" rc-absolute-ppc-2/2 jit-dlsym\r
     2 MTLR\r
     BLRL\r
     1 1 0 LWZ\r
@@ -405,7 +405,7 @@ CONSTANT: ctx-reg 16
 [\r
     jit-save-context\r
     4 vm-reg MR\r
-    0 2 LOAD32 "lazy_jit_compile" f rc-absolute-ppc-2/2 jit-dlsym\r
+    0 2 LOAD32 "lazy_jit_compile" rc-absolute-ppc-2/2 jit-dlsym\r
     2 MTLR\r
     BLRL\r
     5 3 quot-entry-point-offset LWZ\r
@@ -665,7 +665,7 @@ CONSTANT: ctx-reg 16
     [ BNO ]\r
     [\r
         5 vm-reg MR\r
-        0 6 LOAD32 func f rc-absolute-ppc-2/2 jit-dlsym\r
+        0 6 LOAD32 func rc-absolute-ppc-2/2 jit-dlsym\r
         6 MTLR\r
         BLRL\r
     ]\r
@@ -689,7 +689,7 @@ CONSTANT: ctx-reg 16
     [\r
         4 4 tag-bits get SRAWI\r
         5 vm-reg MR\r
-        0 6 LOAD32 "overflow_fixnum_multiply" f rc-absolute-ppc-2/2 jit-dlsym\r
+        0 6 LOAD32 "overflow_fixnum_multiply" rc-absolute-ppc-2/2 jit-dlsym\r
         6 MTLR\r
         BLRL\r
     ]\r

diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor
index 6d84aad8d50bd2a422e722ad3a71dc0aee555589..36beb8679281bb36a1b9c3de43cd1fc5fdce7d2a 100644 (file)
--- a/basis/cpu/ppc/ppc.factor
+++ b/basis/cpu/ppc/ppc.factor
@@ -716,7 +716,7 @@ M: ppc %callback-value ( ctype -- )
     3 1 0 local@ STW
     3 %load-vm-addr
     ! Restore data/call/retain stacks
-    "unnest_stacks" f %alien-invoke
+    "unnest_context" f %alien-invoke
     ! Restore top of data stack
     3 1 0 local@ LWZ
     ! Unbox former top of data stack to return registers
@@ -757,13 +757,13 @@ M: ppc %box-small-struct ( c-type -- )
     4 3 4 LWZ
     3 3 0 LWZ ;
 
-M: ppc %nest-stacks ( -- )
+M: ppc %nest-context ( -- )
     3 %load-vm-addr
-    "nest_stacks" f %alien-invoke ;
+    "nest_context" f %alien-invoke ;
 
-M: ppc %unnest-stacks ( -- )
+M: ppc %unnest-context ( -- )
     3 %load-vm-addr
-    "unnest_stacks" f %alien-invoke ;
+    "unnest_context" f %alien-invoke ;
 
 M: ppc %unbox-small-struct ( size -- )
     heap-size cell align cell /i {

diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index b8b621ee11eee419c3d21bad2a8a9c218ada3a16..09f1ecb32b6763c1b965212ad22d1538f10598f5 100755 (executable)
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -228,14 +228,6 @@ M:: x86.32 %unbox-large-struct ( n c-type -- )
     0 stack@ EAX MOV
     "to_value_struct" f %alien-invoke ;
 
-M: x86.32 %nest-stacks ( -- )
-    0 save-vm-ptr
-    "nest_stacks" f %alien-invoke ;
-
-M: x86.32 %unnest-stacks ( -- )
-    0 save-vm-ptr
-    "unnest_stacks" f %alien-invoke ;
-
 M: x86.32 %prepare-alien-indirect ( -- )
     EAX ds-reg [] MOV
     ds-reg 4 SUB
@@ -247,18 +239,24 @@ M: x86.32 %prepare-alien-indirect ( -- )
 M: x86.32 %alien-indirect ( -- )
     EBP CALL ;
 
+M: x86.32 %begin-callback ( -- )
+    0 save-vm-ptr
+    "begin_callback" f %alien-invoke ;
+
 M: x86.32 %alien-callback ( quot -- )
     EAX EDX %restore-context
     EAX swap %load-reference
     EAX quot-entry-point-offset [+] CALL
     EAX EDX %save-context ;
 
-M: x86.32 %callback-value ( ctype -- )
+M: x86.32 %end-callback ( -- )
+    0 save-vm-ptr
+    "end_callback" f %alien-invoke ;
+
+M: x86.32 %end-callback-value ( ctype -- )
     %pop-context-stack
     4 stack@ EAX MOV
-    0 save-vm-ptr
-    ! Restore data/call/retain stacks
-    "unnest_stacks" f %alien-invoke
+    %end-callback
     ! Place former top of data stack back in EAX
     EAX 4 stack@ MOV
     ! Unbox EAX

diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor
index cf2d09501ccd1524010e520bdf56b5cb46978fdf..c7457d27322ecfda839a72fcca6a239a341be42b 100644 (file)
--- a/basis/cpu/x86/32/bootstrap.factor
+++ b/basis/cpu/x86/32/bootstrap.factor
@@ -16,17 +16,20 @@ IN: bootstrap.x86
 : temp1 ( -- reg ) EDX ;
 : temp2 ( -- reg ) ECX ;
 : temp3 ( -- reg ) EBX ;
-: safe-reg ( -- reg ) EAX ;
 : stack-reg ( -- reg ) ESP ;
 : frame-reg ( -- reg ) EBP ;
 : vm-reg ( -- reg ) ECX ;
 : ctx-reg ( -- reg ) EBP ;
 : nv-regs ( -- seq ) { ESI EDI EBX } ;
+: nv-reg ( -- reg ) nv-regs first ;
 : ds-reg ( -- reg ) ESI ;
 : rs-reg ( -- reg ) EDI ;
 : fixnum>slot@ ( -- ) temp0 2 SAR ;
 : rex-length ( -- n ) 0 ;
 
+: jit-call ( name -- )
+    0 CALL rc-relative jit-dlsym ;
+
 [
     ! save stack frame size
     stack-frame-size PUSH
@@ -49,7 +52,7 @@ IN: bootstrap.x86
     ctx-reg vm-reg vm-context-offset [+] MOV ;
 
 : jit-save-context ( -- )
-    EDX RSP -4 [+] LEA
+    EDX ESP -4 [+] LEA
     ctx-reg context-callstack-top-offset [+] EDX MOV
     ctx-reg context-datastack-offset [+] ds-reg MOV
     ctx-reg context-retainstack-offset [+] rs-reg MOV ;
@@ -70,18 +73,37 @@ IN: bootstrap.x86
 ] jit-primitive jit-define
 
 [
-    ! Load quotation
+    jit-load-vm
+    ESP [] vm-reg MOV
+    "begin_callback" jit-call
+
+    ! load quotation - EBP is ctx-reg so it will get clobbered
+    ! later on
     EAX EBP 8 [+] MOV
-    ! save ctx->callstack_bottom, load ds, rs registers
+
     jit-load-vm
     jit-load-context
     jit-restore-context
-    EDX stack-reg stack-frame-size 4 - [+] LEA
-    ctx-reg context-callstack-bottom-offset [+] EDX MOV
+
+    ! save C callstack pointer
+    ctx-reg context-callstack-save-offset [+] ESP MOV
+
+    ! load Factor callstack pointer
+    ESP ctx-reg context-callstack-bottom-offset [+] MOV
+    ESP 4 ADD
+
     ! call the quotation
     EAX quot-entry-point-offset [+] CALL
-    ! save ds, rs registers
+
+    jit-load-vm
+    jit-load-context
     jit-save-context
+
+    ! load C callstack pointer
+    ESP ctx-reg context-callstack-save-offset [+] MOV
+
+    ESP [] vm-reg MOV
+    "end_callback" jit-call
 ] \ c-to-factor define-sub-primitive
 
 [
@@ -137,7 +159,7 @@ IN: bootstrap.x86
     EDX PUSH
     EBP PUSH
     EAX PUSH
-    0 CALL "factor_memcpy" f rc-relative jit-dlsym
+    "factor_memcpy" jit-call
     ESP 12 ADD
     ! Return with new callstack
     0 RET
@@ -153,7 +175,7 @@ IN: bootstrap.x86
     ESP 4 [+] vm-reg MOV
 
     ! Call VM
-    0 CALL "lazy_jit_compile" f rc-relative jit-dlsym
+    "lazy_jit_compile" jit-call
 ]
 [ EAX quot-entry-point-offset [+] CALL ]
 [ EAX quot-entry-point-offset [+] JMP ]
@@ -171,7 +193,7 @@ IN: bootstrap.x86
     jit-save-context
     ESP 4 [+] vm-reg MOV
     ESP [] EBX MOV
-    0 CALL "inline_cache_miss" f rc-relative jit-dlsym
+    "inline_cache_miss" jit-call
     jit-restore-context ;
 
 [ jit-load-return-address jit-inline-cache-miss ]
@@ -200,7 +222,7 @@ IN: bootstrap.x86
         ESP [] EAX MOV
         ESP 4 [+] EDX MOV
         ESP 8 [+] vm-reg MOV
-        [ 0 CALL ] dip f rc-relative jit-dlsym
+        jit-call
     ]
     jit-conditional ;
 
@@ -225,7 +247,7 @@ IN: bootstrap.x86
         ESP [] EBX MOV
         ESP 4 [+] EBP MOV
         ESP 8 [+] vm-reg MOV
-        0 CALL "overflow_fixnum_multiply" f rc-relative jit-dlsym
+        "overflow_fixnum_multiply" jit-call
     ]
     jit-conditional
 ] \ fixnum* define-sub-primitive

diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor
index 856127aedf49424acccf7ea34fad213cfc052ab4..04f64f96b6d3808b13e764ab3acc7aac1dab7aba 100644 (file)
--- a/basis/cpu/x86/64/64.factor
+++ b/basis/cpu/x86/64/64.factor
@@ -38,6 +38,7 @@ M: x86.64 machine-registers
     } ;
 
 : vm-reg ( -- reg ) R13 ; inline
+: nv-reg ( -- reg ) RBX ; inline
 
 M: x86.64 %mov-vm-ptr ( reg -- )
     vm-reg MOV ;
@@ -215,23 +216,19 @@ M: x86.64 %alien-invoke
     rc-absolute-cell rel-dlsym
     R11 CALL ;
 
-M: x86.64 %nest-stacks ( -- )
-    param-reg-0 %mov-vm-ptr
-    "nest_stacks" f %alien-invoke ;
-
-M: x86.64 %unnest-stacks ( -- )
-    param-reg-0 %mov-vm-ptr
-    "unnest_stacks" f %alien-invoke ;
-
 M: x86.64 %prepare-alien-indirect ( -- )
     param-reg-0 ds-reg [] MOV
     ds-reg 8 SUB
     param-reg-1 %mov-vm-ptr
     "pinned_alien_offset" f %alien-invoke
-    RBP RAX MOV ;
+    nv-reg RAX MOV ;
 
 M: x86.64 %alien-indirect ( -- )
-    RBP CALL ;
+    nv-reg CALL ;
+
+M: x86.64 %begin-callback ( -- )
+    param-reg-0 %mov-vm-ptr
+    "begin_callback" f %alien-invoke ;
 
 M: x86.64 %alien-callback ( quot -- )
     param-reg-0 param-reg-1 %restore-context
@@ -239,16 +236,15 @@ M: x86.64 %alien-callback ( quot -- )
     param-reg-0 quot-entry-point-offset [+] CALL
     param-reg-0 param-reg-1 %save-context ;
 
-M: x86.64 %callback-value ( ctype -- )
-    %pop-context-stack
-    RSP 8 SUB
-    param-reg-0 PUSH
+M: x86.64 %end-callback ( -- )
     param-reg-0 %mov-vm-ptr
-    ! Restore data/call/retain stacks
-    "unnest_stacks" f %alien-invoke
-    ! Put former top of data stack in param-reg-0
-    param-reg-0 POP
-    RSP 8 ADD
+    "end_callback" f %alien-invoke ;
+
+M: x86.64 %end-callback-value ( ctype -- )
+    %pop-context-stack
+    nv-reg param-reg-0 MOV
+    %end-callback
+    param-reg-0 nv-reg MOV
     ! Unbox former top of data stack to return registers
     unbox-return ;
 

diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor
index bc560580fac3dbae0965669c8b9c4e6ba349fabc..2da9f7564e075803c47b96ce86b02aeec21eee6c 100644 (file)
--- a/basis/cpu/x86/64/bootstrap.factor
+++ b/basis/cpu/x86/64/bootstrap.factor
@@ -16,7 +16,7 @@ IN: bootstrap.x86
 : temp2 ( -- reg ) RDX ;
 : temp3 ( -- reg ) RBX ;
 : return-reg ( -- reg ) RAX ;
-: safe-reg ( -- reg ) RAX ;
+: nv-reg ( -- reg ) nv-regs first ;
 : stack-reg ( -- reg ) RSP ;
 : frame-reg ( -- reg ) RBP ;
 : ctx-reg ( -- reg ) R12 ;
@@ -26,13 +26,17 @@ IN: bootstrap.x86
 : fixnum>slot@ ( -- ) temp0 1 SAR ;
 : rex-length ( -- n ) 1 ;
 
+: jit-call ( name -- )
+    RAX 0 MOV rc-absolute-cell jit-dlsym
+    RAX CALL ;
+
 [
     ! load entry point
-    safe-reg 0 MOV rc-absolute-cell rt-this jit-rel
+    RAX 0 MOV rc-absolute-cell rt-this jit-rel
     ! save stack frame size
     stack-frame-size PUSH
     ! push entry point
-    safe-reg PUSH
+    RAX PUSH
     ! alignment
     RSP stack-frame-size 3 bootstrap-cells - SUB
 ] jit-prolog jit-define
@@ -47,8 +51,8 @@ IN: bootstrap.x86
 
 : jit-save-context ( -- )
     jit-load-context
-    safe-reg RSP -8 [+] LEA
-    ctx-reg context-callstack-top-offset [+] safe-reg MOV
+    RAX RSP -8 [+] LEA
+    ctx-reg context-callstack-top-offset [+] RAX MOV
     ctx-reg context-datastack-offset [+] ds-reg MOV
     ctx-reg context-retainstack-offset [+] rs-reg MOV ;
 
@@ -67,13 +71,31 @@ IN: bootstrap.x86
 ] jit-primitive jit-define
 
 [
+    nv-reg arg1 MOV
+
+    arg1 vm-reg MOV
+    "begin_callback" jit-call
+
     jit-restore-context
-    ! save ctx->callstack_bottom
-    safe-reg stack-reg stack-frame-size 8 - [+] LEA
-    ctx-reg context-callstack-bottom-offset [+] safe-reg MOV
+
+    ! save C callstack pointer
+    ctx-reg context-callstack-save-offset [+] stack-reg MOV
+
+    ! load Factor callstack pointer
+    stack-reg ctx-reg context-callstack-bottom-offset [+] MOV
+    stack-reg 8 ADD
+
     ! call the quotation
+    arg1 nv-reg MOV
     arg1 quot-entry-point-offset [+] CALL
+
     jit-save-context
+
+    ! load C callstack pointer
+    stack-reg ctx-reg context-callstack-save-offset [+] MOV
+
+    arg1 vm-reg MOV
+    "end_callback" jit-call
 ] \ c-to-factor define-sub-primitive
 
 [
@@ -124,8 +146,7 @@ IN: bootstrap.x86
     ! Call memcpy; arguments are now in the correct registers
     ! Create register shadow area for Win64
     RSP 32 SUB
-    safe-reg 0 MOV "factor_memcpy" f rc-absolute-cell jit-dlsym
-    safe-reg CALL
+    "factor_memcpy" jit-call
     ! Tear down register shadow area
     RSP 32 ADD
     ! Return with new callstack
@@ -135,8 +156,7 @@ IN: bootstrap.x86
 [
     jit-save-context
     arg2 vm-reg MOV
-    safe-reg 0 MOV "lazy_jit_compile" f rc-absolute-cell jit-dlsym
-    safe-reg CALL
+    "lazy_jit_compile" jit-call
 ]
 [ return-reg quot-entry-point-offset [+] CALL ]
 [ return-reg quot-entry-point-offset [+] JMP ]
@@ -152,8 +172,7 @@ IN: bootstrap.x86
     jit-save-context
     arg1 RBX MOV
     arg2 vm-reg MOV
-    RAX 0 MOV "inline_cache_miss" f rc-absolute-cell jit-dlsym
-    RAX CALL
+    "inline_cache_miss" jit-call
     jit-restore-context ;
 
 [ jit-load-return-address jit-inline-cache-miss ]
@@ -176,11 +195,7 @@ IN: bootstrap.x86
     [ [ arg3 arg2 ] dip call ] dip
     ds-reg [] arg3 MOV
     [ JNO ]
-    [
-        arg3 vm-reg MOV
-        RAX 0 MOV f rc-absolute-cell jit-dlsym
-        RAX CALL
-    ]
+    [ arg3 vm-reg MOV jit-call ]
     jit-conditional ; inline
 
 [ [ ADD ] "overflow_fixnum_add" jit-overflow ] \ fixnum+ define-sub-primitive
@@ -202,8 +217,7 @@ IN: bootstrap.x86
         arg1 tag-bits get SAR
         arg2 RBX MOV
         arg3 vm-reg MOV
-        RAX 0 MOV "overflow_fixnum_multiply" f rc-absolute-cell jit-dlsym
-        RAX CALL
+        "overflow_fixnum_multiply" jit-call
     ]
     jit-conditional
 ] \ fixnum* define-sub-primitive

diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor
index 8f1a4d7f498ebfbc25fd2508bb6a8b2e7f02f8db..1c4a6b779643f902d41f9fd3b124ca63008315b1 100644 (file)
--- a/basis/cpu/x86/bootstrap.factor
+++ b/basis/cpu/x86/bootstrap.factor
@@ -13,35 +13,45 @@ big-endian off
     ! Optimizing compiler's side of callback accesses
     ! arguments that are on the stack via the frame pointer.
     ! On x86-64, some arguments are passed in registers, and
-    ! so the only register that is safe for use here is safe-reg.
+    ! so the only register that is safe for use here is nv-reg.
     frame-reg PUSH
     frame-reg stack-reg MOV
 
     ! Save all non-volatile registers
     nv-regs [ PUSH ] each
 
-    ! Save old stack pointer and align
-    safe-reg stack-reg MOV
-    stack-reg bootstrap-cell SUB
-    stack-reg -16 AND
-    stack-reg [] safe-reg MOV
-
-    ! Register shadow area - only required on Win64, but doesn't
-    ! hurt on other platforms
-    stack-reg 32 SUB
-
     ! Load VM into vm-reg
     vm-reg 0 MOV rc-absolute-cell rt-vm jit-rel
 
+    ! Save old context
+    nv-reg vm-reg vm-context-offset [+] MOV
+    nv-reg PUSH
+
+    ! Switch over to the spare context
+    nv-reg vm-reg vm-spare-context-offset [+] MOV
+    vm-reg vm-context-offset [+] nv-reg MOV
+
+    ! Save C callstack pointer
+    nv-reg context-callstack-save-offset [+] stack-reg MOV
+
+    ! Load Factor callstack pointer
+    stack-reg nv-reg context-callstack-bottom-offset [+] MOV
+    stack-reg bootstrap-cell ADD
+
     ! Call into Factor code
-    safe-reg 0 MOV rc-absolute-cell rt-entry-point jit-rel
-    safe-reg CALL
+    nv-reg 0 MOV rc-absolute-cell rt-entry-point jit-rel
+    nv-reg CALL
 
-    ! Tear down register shadow area
-    stack-reg 32 ADD
+    ! Load VM into vm-reg
+    vm-reg 0 MOV rc-absolute-cell rt-vm jit-rel
 
-    ! Undo stack alignment
-    stack-reg stack-reg [] MOV
+    ! Load C callstack pointer
+    nv-reg vm-reg vm-context-offset [+] MOV
+    stack-reg nv-reg context-callstack-save-offset [+] MOV
+
+    ! Load old context
+    nv-reg POP
+    vm-reg vm-context-offset [+] nv-reg MOV
 
     ! Restore non-volatile registers
     nv-regs <reversed> [ POP ] each
@@ -56,15 +66,15 @@ big-endian off
 
 [
     ! Load word
-    safe-reg 0 MOV rc-absolute-cell rt-literal jit-rel
+    temp0 0 MOV rc-absolute-cell rt-literal jit-rel
     ! Bump profiling counter
-    safe-reg profile-count-offset [+] 1 tag-fixnum ADD
+    temp0 profile-count-offset [+] 1 tag-fixnum ADD
     ! Load word->code
-    safe-reg safe-reg word-code-offset [+] MOV
+    temp0 temp0 word-code-offset [+] MOV
     ! Compute word entry point
-    safe-reg compiled-header-size ADD
+    temp0 compiled-header-size ADD
     ! Jump to entry point
-    safe-reg JMP
+    temp0 JMP
 ] jit-profiling jit-define
 
 [

diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor
index e54e307f79fffe8478574272d83732db7f04a1fa..dbb112bf4bf9a245e062a210d7bc6adfe4b736ba 100644 (file)
--- a/basis/cpu/x86/x86.factor
+++ b/basis/cpu/x86/x86.factor
@@ -1403,10 +1403,7 @@ M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
 
 M:: x86 %restore-context ( temp1 temp2 -- )
     #! Load Factor stack pointers on entry from C to Factor.
-    #! Also save callstack bottom!
     temp1 "ctx" %vm-field
-    temp2 stack-reg stack-frame get total-size>> cell - [+] LEA
-    temp1 "callstack-bottom" context-field-offset [+] temp2 MOV
     ds-reg temp1 "datastack" context-field-offset [+] MOV
     rs-reg temp1 "retainstack" context-field-offset [+] MOV ;
 

diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor
index d0cbb05919210556a66597c0206ea35f08dcc7c9..289afcf28cd42077b4c6267d8630e6dabf4696d3 100644 (file)
--- a/basis/stack-checker/known-words/known-words.factor
+++ b/basis/stack-checker/known-words/known-words.factor
@@ -1,19 +1,20 @@
 ! Copyright (C) 2004, 2010 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: fry accessors alien alien.accessors arrays byte-arrays
-classes continuations.private effects generic hashtables
-hashtables.private io io.backend io.files io.files.private
-io.streams.c kernel kernel.private math math.private
-math.parser.private memory memory.private namespaces
-namespaces.private parser quotations quotations.private sbufs
-sbufs.private sequences sequences.private slots.private strings
-strings.private system threads.private classes.tuple
-classes.tuple.private vectors vectors.private words
-words.private definitions assocs summary compiler.units
-system.private combinators combinators.short-circuit locals
-locals.backend locals.types combinators.private
-stack-checker.values generic.single generic.single.private
-alien.libraries tools.dispatch.private tools.profiler.private
+USING: fry accessors alien alien.accessors alien.private arrays
+byte-arrays classes continuations.private effects generic
+hashtables hashtables.private io io.backend io.files
+io.files.private io.streams.c kernel kernel.private math
+math.private math.parser.private memory memory.private
+namespaces namespaces.private parser quotations
+quotations.private sbufs sbufs.private sequences
+sequences.private slots.private strings strings.private system
+threads.private classes.tuple classes.tuple.private vectors
+vectors.private words words.private definitions assocs summary
+compiler.units system.private combinators
+combinators.short-circuit locals locals.backend locals.types
+combinators.private stack-checker.values generic.single
+generic.single.private alien.libraries tools.dispatch.private
+tools.profiler.private
 stack-checker.alien
 stack-checker.state
 stack-checker.errors
@@ -504,6 +505,16 @@ M: bad-executable summary
 \ word-code { word } { integer integer } define-primitive
 \ word-code make-flushable
 
+\ current-callback { } { fixnum } define-primitive
+\ current-callback make-flushable
+
+\ current-context { } { c-ptr } define-primitive
+\ current-context make-flushable
+
+\ delete-context { c-ptr } { } define-primitive
+
+\ start-context { quotation } { } define-primitive
+
 \ special-object { fixnum } { object } define-primitive
 \ special-object make-flushable
 

diff --git a/basis/vm/vm.factor b/basis/vm/vm.factor
index cc4a291a8b089922fda2dd93bb77174c2e827e1d..b0f2c945f7701eb1c783d270e7cdd78e51d1d793 100644 (file)
--- a/basis/vm/vm.factor
+++ b/basis/vm/vm.factor
@@ -10,12 +10,11 @@ STRUCT: context
 { callstack-bottom void* }
 { datastack cell }
 { retainstack cell }
-{ magic-frame void* }
+{ callstack-save cell }
+{ context-objects cell[10] }
 { datastack-region void* }
 { retainstack-region void* }
-{ catchstack-save cell }
-{ current-callback-save cell }
-{ next context* } ;
+{ callstack-region void* } ;
 
 : context-field-offset ( field -- offset ) context offset-of ; inline
 
@@ -27,6 +26,7 @@ STRUCT: zone
 
 STRUCT: vm
 { ctx context* }
+{ spare-ctx context* }
 { nursery zone }
 { cards-offset cell }
 { decks-offset cell }

diff --git a/core/alien/alien.factor b/core/alien/alien.factor
index 191886393a3537c25e2b4b77c2c1ad85e3508caf..a44d703fbc316b083097f2163617b7daf0652f7f 100644 (file)
--- a/core/alien/alien.factor
+++ b/core/alien/alien.factor
@@ -94,26 +94,21 @@ SYMBOL: callbacks
 
 [ H{ } clone callbacks set-global ] "alien" add-startup-hook
 
-! 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?
+! Every callback invocation has a unique identifier in the VM.
+! We make sure that the current callback is the right one before
+! returning from it, to avoid a bad interaction between threads
+! and callbacks. See basis/compiler/tests/alien.factor for a
+! test case.
+: wait-to-return ( yield-quot callback-id -- )
+    dup current-callback 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
+    current-callback
+    [ 2drop call ] [ wait-to-return drop ] 3bi ; inline
 
 ! A utility for defining global variables that are recompiled in
 ! every session

diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index 19a179a6b1baecad0e81f3f07b8acd793d260255..9bf7be31a2cb504178a31a46e1729cef456a3de7 100644 (file)
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -63,6 +63,7 @@ call( -- )
     "alien"
     "alien.accessors"
     "alien.libraries"
+    "alien.private"
     "arrays"
     "byte-arrays"
     "classes.private"
@@ -415,6 +416,7 @@ tuple
     { "(dlsym)" "alien.libraries" "primitive_dlsym" (( name dll -- alien )) }
     { "dlclose" "alien.libraries" "primitive_dlclose" (( dll -- )) }
     { "dll-valid?" "alien.libraries" "primitive_dll_validp" (( dll -- ? )) }
+    { "current-callback" "alien.private" "primitive_current_callback" (( -- n )) }
     { "<array>" "arrays" "primitive_array" (( n elt -- array )) }
     { "resize-array" "arrays" "primitive_resize_array" (( n array -- newarray )) }
     { "(byte-array)" "byte-arrays" "primitive_uninitialized_byte_array" (( n -- byte-array )) }
@@ -532,6 +534,9 @@ 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 )) }
+    { "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" (( ? -- )) }

diff --git a/vm/callbacks.cpp b/vm/callbacks.cpp
index 416c1395d43444b45e582db45947f3be8535152b..6c8165f5c40807dcd41a91e9a7e8fe092c7fec14 100644 (file)
--- a/vm/callbacks.cpp
+++ b/vm/callbacks.cpp
@@ -64,11 +64,12 @@ code_block *callback_heap::add(cell owner, cell return_rewind)
 
        /* Store VM pointer */
        store_callback_operand(stub,0,(cell)parent);
+       store_callback_operand(stub,2,(cell)parent);
 
        /* On x86, the RET instruction takes an argument which depends on
        the callback's calling convention */
 #if defined(FACTOR_X86) || defined(FACTOR_AMD64)
-       store_callback_operand(stub,2,return_rewind);
+       store_callback_operand(stub,3,return_rewind);
 #endif
 
        update(stub);

diff --git a/vm/callstack.cpp b/vm/callstack.cpp
index 195b212d8b3899b1b741a39e19c7a20af58ca9ad..8389ff8d90ffd8406ed8d37d4e8933d2df471dc4 100755 (executable)
--- a/vm/callstack.cpp
+++ b/vm/callstack.cpp
@@ -13,7 +13,7 @@ void factor_vm::check_frame(stack_frame *frame)
 
 callstack *factor_vm::allot_callstack(cell size)
 {
-       callstack *stack = allot<callstack>(callstack_size(size));
+       callstack *stack = allot<callstack>(callstack_object_size(size));
        stack->length = tag_fixnum(size);
        return stack;
 }

diff --git a/vm/callstack.hpp b/vm/callstack.hpp
index 9f8867447cc1686dea09a2331c20017c825eeccc..9f0693eb7648036ee0d9ecf03cb1af650ef293a2 100755 (executable)
--- a/vm/callstack.hpp
+++ b/vm/callstack.hpp
@@ -1,7 +1,7 @@
 namespace factor
 {
 
-inline static cell callstack_size(cell size)
+inline static cell callstack_object_size(cell size)
 {
        return sizeof(callstack) + size;
 }

diff --git a/vm/code_block_visitor.hpp b/vm/code_block_visitor.hpp
index ac5d140783f45d62691a1bba121607b6a065c90b..deaa41e4b8ef7b282ffdae7b1cabefab41c1fcaa 100644 (file)
--- a/vm/code_block_visitor.hpp
+++ b/vm/code_block_visitor.hpp
@@ -114,7 +114,7 @@ template<typename Visitor>
 void code_block_visitor<Visitor>::visit_context_code_blocks()
 {
        call_frame_code_block_visitor<Visitor> call_frame_visitor(parent,visitor);
-       parent->iterate_active_frames(call_frame_visitor);
+       parent->iterate_active_callstacks(call_frame_visitor);
 }
 
 template<typename Visitor>

diff --git a/vm/contexts.cpp b/vm/contexts.cpp
index 1079c572d2de756ed15b54de6d9e45ec28b66975..b5ca348d146beca2a9d4dbf13535a772fe09a16d 100644 (file)
--- a/vm/contexts.cpp
+++ b/vm/contexts.cpp
@@ -3,28 +3,32 @@
 namespace factor
 {
 
-context::context(cell ds_size, cell rs_size) :
+context::context(cell datastack_size, cell retainstack_size, cell callstack_size) :
        callstack_top(NULL),
        callstack_bottom(NULL),
        datastack(0),
        retainstack(0),
-       datastack_region(new segment(ds_size,false)),
-       retainstack_region(new segment(rs_size,false)),
-       next(NULL)
+       callstack_save(0),
+       datastack_seg(new segment(datastack_size,false)),
+       retainstack_seg(new segment(retainstack_size,false)),
+       callstack_seg(new segment(callstack_size,false))
 {
-       reset_datastack();
-       reset_retainstack();
-       reset_context_objects();
+       reset();
 }
 
 void context::reset_datastack()
 {
-       datastack = datastack_region->start - sizeof(cell);
+       datastack = datastack_seg->start - sizeof(cell);
 }
 
 void context::reset_retainstack()
 {
-       retainstack = retainstack_region->start - sizeof(cell);
+       retainstack = retainstack_seg->start - sizeof(cell);
+}
+
+void context::reset_callstack()
+{
+       callstack_top = callstack_bottom = CALLSTACK_BOTTOM(this);
 }
 
 void context::reset_context_objects()
@@ -32,68 +36,99 @@ void context::reset_context_objects()
        memset_cell(context_objects,false_object,context_object_count * sizeof(cell));
 }
 
-context *factor_vm::alloc_context()
+void context::reset()
+{
+       reset_datastack();
+       reset_retainstack();
+       reset_callstack();
+       reset_context_objects();
+}
+
+context::~context()
+{
+       delete datastack_seg;
+       delete retainstack_seg;
+       delete callstack_seg;
+}
+
+/* called on startup */
+void factor_vm::init_contexts(cell datastack_size_, cell retainstack_size_, cell callstack_size_)
+{
+       datastack_size = datastack_size_;
+       retainstack_size = retainstack_size_;
+       callstack_size = callstack_size_;
+
+       ctx = NULL;
+       spare_ctx = new_context();
+}
+
+void factor_vm::delete_contexts()
+{
+       assert(!ctx);
+       std::vector<context *>::const_iterator iter = unused_contexts.begin();
+       std::vector<context *>::const_iterator end = unused_contexts.end();
+       while(iter != end)
+       {
+               delete *iter;
+               iter++;
+       }
+}
+
+context *factor_vm::new_context()
 {
        context *new_context;
 
-       if(unused_contexts)
+       if(unused_contexts.empty())
        {
-               new_context = unused_contexts;
-               unused_contexts = unused_contexts->next;
+               new_context = new context(datastack_size,
+                       retainstack_size,
+                       callstack_size);
        }
        else
-               new_context = new context(ds_size,rs_size);
+       {
+               new_context = unused_contexts.back();
+               unused_contexts.pop_back();
+       }
+
+       new_context->reset();
+
+       active_contexts.insert(new_context);
 
        return new_context;
 }
 
-void factor_vm::dealloc_context(context *old_context)
+void factor_vm::delete_context(context *old_context)
 {
-       old_context->next = unused_contexts;
-       unused_contexts = old_context;
+       unused_contexts.push_back(old_context);
+       active_contexts.erase(old_context);
 }
 
-/* called on entry into a compiled callback */
-void factor_vm::nest_stacks()
+void factor_vm::begin_callback()
 {
-       context *new_ctx = alloc_context();
-
-       new_ctx->callstack_bottom = (stack_frame *)-1;
-       new_ctx->callstack_top = (stack_frame *)-1;
-
-       new_ctx->reset_datastack();
-       new_ctx->reset_retainstack();
-       new_ctx->reset_context_objects();
-
-       new_ctx->next = ctx;
-       ctx = new_ctx;
+       ctx->reset();
+       spare_ctx = new_context();
+       callback_ids.push_back(callback_id++);
 }
 
-void nest_stacks(factor_vm *parent)
+void begin_callback(factor_vm *parent)
 {
-       return parent->nest_stacks();
+       parent->begin_callback();
 }
 
-/* called when leaving a compiled callback */
-void factor_vm::unnest_stacks()
+void factor_vm::end_callback()
 {
-       context *old_ctx = ctx;
-       ctx = old_ctx->next;
-       dealloc_context(old_ctx);
+       callback_ids.pop_back();
+       delete_context(ctx);
 }
 
-void unnest_stacks(factor_vm *parent)
+void end_callback(factor_vm *parent)
 {
-       return parent->unnest_stacks();
+       parent->end_callback();
 }
 
-/* called on startup */
-void factor_vm::init_stacks(cell ds_size_, cell rs_size_)
+void factor_vm::primitive_current_callback()
 {
-       ds_size = ds_size_;
-       rs_size = rs_size_;
-       ctx = NULL;
-       unused_contexts = NULL;
+       ctx->push(tag_fixnum(callback_ids.back()));
 }
 
 void factor_vm::primitive_context_object()
@@ -126,13 +161,13 @@ bool factor_vm::stack_to_array(cell bottom, cell top)
 
 void factor_vm::primitive_datastack()
 {
-       if(!stack_to_array(ctx->datastack_region->start,ctx->datastack))
+       if(!stack_to_array(ctx->datastack_seg->start,ctx->datastack))
                general_error(ERROR_DS_UNDERFLOW,false_object,false_object,NULL);
 }
 
 void factor_vm::primitive_retainstack()
 {
-       if(!stack_to_array(ctx->retainstack_region->start,ctx->retainstack))
+       if(!stack_to_array(ctx->retainstack_seg->start,ctx->retainstack))
                general_error(ERROR_RS_UNDERFLOW,false_object,false_object,NULL);
 }
 
@@ -146,12 +181,12 @@ cell factor_vm::array_to_stack(array *array, cell bottom)
 
 void factor_vm::primitive_set_datastack()
 {
-       ctx->datastack = array_to_stack(untag_check<array>(ctx->pop()),ctx->datastack_region->start);
+       ctx->datastack = array_to_stack(untag_check<array>(ctx->pop()),ctx->datastack_seg->start);
 }
 
 void factor_vm::primitive_set_retainstack()
 {
-       ctx->retainstack = array_to_stack(untag_check<array>(ctx->pop()),ctx->retainstack_region->start);
+       ctx->retainstack = array_to_stack(untag_check<array>(ctx->pop()),ctx->retainstack_seg->start);
 }
 
 /* Used to implement call( */
@@ -162,12 +197,12 @@ void factor_vm::primitive_check_datastack()
        fixnum height = out - in;
        array *saved_datastack = untag_check<array>(ctx->pop());
        fixnum saved_height = array_capacity(saved_datastack);
-       fixnum current_height = (ctx->datastack - ctx->datastack_region->start + sizeof(cell)) / sizeof(cell);
+       fixnum current_height = (ctx->datastack - ctx->datastack_seg->start + sizeof(cell)) / sizeof(cell);
        if(current_height - height != saved_height)
                ctx->push(false_object);
        else
        {
-               cell *ds_bot = (cell *)ctx->datastack_region->start;
+               cell *ds_bot = (cell *)ctx->datastack_seg->start;
                for(fixnum i = 0; i < saved_height - in; i++)
                {
                        if(ds_bot[i] != array_nth(saved_datastack,i))
@@ -190,4 +225,22 @@ void factor_vm::primitive_load_locals()
        ctx->retainstack += sizeof(cell) * count;
 }
 
+void factor_vm::primitive_current_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());
+       delete_context(old_context);
+}
+
 }

diff --git a/vm/contexts.hpp b/vm/contexts.hpp
index e555bd4a92ec41099f6b38396abafcd2a360f868..e746e53ffa15e0f4a0a81ce1ebc6aad33a3333ff 100644 (file)
--- a/vm/contexts.hpp
+++ b/vm/contexts.hpp
@@ -6,12 +6,13 @@ 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 */
+
+       // First 4 fields accessed directly by compiler. See basis/vm/vm.factor
+
+       /* Factor callstack pointers */
        stack_frame *callstack_top;
        stack_frame *callstack_bottom;
 
@@ -21,22 +22,25 @@ struct context {
        /* current retain stack top pointer */
        cell retainstack;
 
-       /* memory region holding current datastack */
-       segment *datastack_region;
-
-       /* memory region holding current retain stack */
-       segment *retainstack_region;
+       /* C callstack pointer */
+       cell callstack_save;
 
        /* context-specific special objects, accessed by context-object and
        set-context-object primitives */
        cell context_objects[context_object_count];
 
-       context *next;
+       segment *datastack_seg;
+       segment *retainstack_seg;
+       segment *callstack_seg;
+
+       context(cell datastack_size, cell retainstack_size, cell callstack_size);
+       ~context();
 
-       context(cell ds_size, cell rs_size);
        void reset_datastack();
        void reset_retainstack();
+       void reset_callstack();
        void reset_context_objects();
+       void reset();
 
        cell peek()
        {
@@ -65,17 +69,17 @@ struct context {
 
        void fix_stacks()
        {
-               if(datastack + sizeof(cell) < datastack_region->start
-                       || datastack + stack_reserved >= datastack_region->end)
+               if(datastack + sizeof(cell) < datastack_seg->start
+                       || datastack + stack_reserved >= datastack_seg->end)
                        reset_datastack();
 
-               if(retainstack + sizeof(cell) < retainstack_region->start
-                       || retainstack + stack_reserved >= retainstack_region->end)
+               if(retainstack + sizeof(cell) < retainstack_seg->start
+                       || retainstack + stack_reserved >= retainstack_seg->end)
                        reset_retainstack();
        }
 };
 
-VM_C_API void nest_stacks(factor_vm *vm);
-VM_C_API void unnest_stacks(factor_vm *vm);
+VM_C_API void begin_callback(factor_vm *vm);
+VM_C_API void end_callback(factor_vm *vm);
 
 }

diff --git a/vm/cpu-ppc.hpp b/vm/cpu-ppc.hpp
index d09fc173ea5bcc1348d783ec811b825cac9df6d9..6e76164308fde40248dea41383b7edaf2e6c021f 100644 (file)
--- a/vm/cpu-ppc.hpp
+++ b/vm/cpu-ppc.hpp
@@ -3,6 +3,8 @@ namespace factor
 
 #define FACTOR_CPU_STRING "ppc"
 
+#define CALLSTACK_BOTTOM(ctx) (stack_frame *)ctx->callstack_seg->end
+
 /* In the instruction sequence:
 
    LOAD32 r3,...

diff --git a/vm/cpu-x86.hpp b/vm/cpu-x86.hpp
index ac8ac51ade6b3abc13960f32bbb6be0ca7e49c47..bfdcd8afb2ce779bf5e75316087b158eb79597ef 100644 (file)
--- a/vm/cpu-x86.hpp
+++ b/vm/cpu-x86.hpp
@@ -5,6 +5,8 @@ namespace factor
 
 #define FRAME_RETURN_ADDRESS(frame,vm) *(void **)(vm->frame_successor(frame) + 1)
 
+#define CALLSTACK_BOTTOM(ctx) (stack_frame *)(ctx->callstack_seg->end - sizeof(cell))
+
 inline static void flush_icache(cell start, cell len) {}
 
 /* In the instruction sequence:

diff --git a/vm/data_heap.cpp b/vm/data_heap.cpp
index 22ef39e8681f54d3f9f886bf1f04c5da5cc2b598..9b28215bb835d7a236b2a7837a6796b3ebb1dd97 100755 (executable)
--- a/vm/data_heap.cpp
+++ b/vm/data_heap.cpp
@@ -159,7 +159,7 @@ cell object::size() const
        case WRAPPER_TYPE:
                return align(sizeof(wrapper),data_alignment);
        case CALLSTACK_TYPE:
-               return align(callstack_size(untag_fixnum(((callstack *)this)->length)),data_alignment);
+               return align(callstack_object_size(untag_fixnum(((callstack *)this)->length)),data_alignment);
        default:
                critical_error("Invalid header",(cell)this);
                return 0; /* can't happen */

diff --git a/vm/debug.cpp b/vm/debug.cpp
index e82394951a0682315500c14b25300d48dffa1ca1..85335d49ae7f344fbb491ab1aa23b69d0954ff9b 100755 (executable)
--- a/vm/debug.cpp
+++ b/vm/debug.cpp
@@ -145,13 +145,13 @@ void factor_vm::print_objects(cell *start, cell *end)
 void factor_vm::print_datastack()
 {
        std::cout << "==== DATA STACK:\n";
-       print_objects((cell *)ctx->datastack_region->start,(cell *)ctx->datastack);
+       print_objects((cell *)ctx->datastack_seg->start,(cell *)ctx->datastack);
 }
 
 void factor_vm::print_retainstack()
 {
        std::cout << "==== RETAIN STACK:\n";
-       print_objects((cell *)ctx->retainstack_region->start,(cell *)ctx->retainstack);
+       print_objects((cell *)ctx->retainstack_seg->start,(cell *)ctx->retainstack);
 }
 
 struct stack_frame_printer {
@@ -421,9 +421,9 @@ void factor_vm::factorbug()
                else if(strcmp(cmd,"t") == 0)
                        full_output = !full_output;
                else if(strcmp(cmd,"s") == 0)
-                       dump_memory(ctx->datastack_region->start,ctx->datastack);
+                       dump_memory(ctx->datastack_seg->start,ctx->datastack);
                else if(strcmp(cmd,"r") == 0)
-                       dump_memory(ctx->retainstack_region->start,ctx->retainstack);
+                       dump_memory(ctx->retainstack_seg->start,ctx->retainstack);
                else if(strcmp(cmd,".s") == 0)
                        print_datastack();
                else if(strcmp(cmd,".r") == 0)

diff --git a/vm/errors.cpp b/vm/errors.cpp
index ae560012aa6f49902c5dbc123e437b4361e3b341..8efcb3346f36ac9c3a267a41f42518aee15e59a9 100755 (executable)
--- a/vm/errors.cpp
+++ b/vm/errors.cpp
@@ -99,13 +99,13 @@ bool factor_vm::in_page(cell fault, cell area, cell area_size, int offset)
 
 void factor_vm::memory_protection_error(cell addr, stack_frame *native_stack)
 {
-       if(in_page(addr, ctx->datastack_region->start, 0, -1))
+       if(in_page(addr, ctx->datastack_seg->start, 0, -1))
                general_error(ERROR_DS_UNDERFLOW,false_object,false_object,native_stack);
-       else if(in_page(addr, ctx->datastack_region->start, ds_size, 0))
+       else if(in_page(addr, ctx->datastack_seg->start, datastack_size, 0))
                general_error(ERROR_DS_OVERFLOW,false_object,false_object,native_stack);
-       else if(in_page(addr, ctx->retainstack_region->start, 0, -1))
+       else if(in_page(addr, ctx->retainstack_seg->start, 0, -1))
                general_error(ERROR_RS_UNDERFLOW,false_object,false_object,native_stack);
-       else if(in_page(addr, ctx->retainstack_region->start, rs_size, 0))
+       else if(in_page(addr, ctx->retainstack_seg->start, retainstack_size, 0))
                general_error(ERROR_RS_OVERFLOW,false_object,false_object,native_stack);
        else if(in_page(addr, nursery.end, 0, 0))
                critical_error("allot_object() missed GC check",0);

diff --git a/vm/factor.cpp b/vm/factor.cpp
index 4433095173b74b54c949a9fa3cd5e48de2afc481..c38e38a5d05de2b8a48677f372b71dcd6a4df205 100755 (executable)
--- a/vm/factor.cpp
+++ b/vm/factor.cpp
@@ -14,8 +14,9 @@ void factor_vm::default_parameters(vm_parameters *p)
 {
        p->image_path = NULL;
 
-       p->ds_size = 32 * sizeof(cell);
-       p->rs_size = 32 * sizeof(cell);
+       p->datastack_size = 32 * sizeof(cell);
+       p->retainstack_size = 32 * sizeof(cell);
+       p->callstack_size = 128 * sizeof(cell);
 
        p->code_size = 8 * sizeof(cell);
        p->young_size = sizeof(cell) / 4;
@@ -59,8 +60,9 @@ void factor_vm::init_parameters_from_args(vm_parameters *p, int argc, vm_char **
        {
                vm_char *arg = argv[i];
                if(STRCMP(arg,STRING_LITERAL("--")) == 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("-datastack=%d"),&p->datastack_size));
+               else if(factor_arg(arg,STRING_LITERAL("-retainstack=%d"),&p->retainstack_size));
+               else if(factor_arg(arg,STRING_LITERAL("-callstack=%d"),&p->callstack_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));
@@ -91,8 +93,9 @@ void factor_vm::prepare_boot_image()
 void factor_vm::init_factor(vm_parameters *p)
 {
        /* Kilobytes */
-       p->ds_size = align_page(p->ds_size << 10);
-       p->rs_size = align_page(p->rs_size << 10);
+       p->datastack_size = align_page(p->datastack_size << 10);
+       p->retainstack_size = align_page(p->retainstack_size << 10);
+       p->callstack_size = align_page(p->retainstack_size << 10);
        p->callback_size = align_page(p->callback_size << 10);
 
        /* Megabytes */
@@ -117,7 +120,7 @@ void factor_vm::init_factor(vm_parameters *p)
 
        srand((unsigned int)system_micros());
        init_ffi();
-       init_stacks(p->ds_size,p->rs_size);
+       init_contexts(p->datastack_size,p->retainstack_size,p->callstack_size);
        init_callbacks(p->callback_size);
        load_image(p);
        init_c_io();
@@ -161,16 +164,12 @@ void factor_vm::start_factor(vm_parameters *p)
 {
        if(p->fep) factorbug();
 
-       nest_stacks();
        c_to_factor_toplevel(special_objects[OBJ_STARTUP_QUOT]);
-       unnest_stacks();
 }
 
 void factor_vm::stop_factor()
 {
-       nest_stacks();
        c_to_factor_toplevel(special_objects[OBJ_SHUTDOWN_QUOT]);
-       unnest_stacks();
 }
 
 char *factor_vm::factor_eval_string(char *string)

diff --git a/vm/image.hpp b/vm/image.hpp
index 101482b1dac740dbe905d8d04a986b25ae7e6579..40ffa28d114c4e70b0f248ef2afe127f5a3ee788 100755 (executable)
--- a/vm/image.hpp
+++ b/vm/image.hpp
@@ -30,7 +30,7 @@ struct image_header {
 struct vm_parameters {
        const vm_char *image_path;
        const vm_char *executable_path;
-       cell ds_size, rs_size;
+       cell datastack_size, retainstack_size, callstack_size;
        cell young_size, aging_size, tenured_size;
        cell code_size;
        bool fep;

diff --git a/vm/primitives.hpp b/vm/primitives.hpp
index df36ed84b213289ab807facd231652374cb0dbe0..cbbadd2596c3b5b6d824d5e9f4560168d77f697d 100644 (file)
--- a/vm/primitives.hpp
+++ b/vm/primitives.hpp
@@ -2,157 +2,159 @@ namespace factor
 {
 
 /* Generated with PRIMITIVE in primitives.cpp */
-#define EACH_PRIMITIVE(_) \
-    _(alien_address) \
-    _(all_instances) \
-    _(array) \
-    _(array_to_quotation) \
-    _(become) \
-    _(bignum_add) \
-    _(bignum_and) \
-    _(bignum_bitp) \
-    _(bignum_divint) \
-    _(bignum_divmod) \
-    _(bignum_eq) \
-    _(bignum_greater) \
-    _(bignum_greatereq) \
-    _(bignum_less) \
-    _(bignum_lesseq) \
-    _(bignum_log2) \
-    _(bignum_mod) \
-    _(bignum_multiply) \
-    _(bignum_not) \
-    _(bignum_or) \
-    _(bignum_shift) \
-    _(bignum_subtract) \
-    _(bignum_to_fixnum) \
-    _(bignum_to_float) \
-    _(bignum_xor) \
-    _(bits_double) \
-    _(bits_float) \
-    _(byte_array) \
-    _(byte_array_to_bignum) \
-    _(call_clear) \
-    _(callback) \
-    _(callstack) \
-    _(callstack_to_array) \
-    _(check_datastack) \
-    _(clone) \
-    _(code_blocks) \
-    _(code_room) \
-    _(compact_gc) \
-    _(compute_identity_hashcode) \
-    _(context_object) \
-    _(data_room) \
-    _(datastack) \
-    _(die) \
-    _(disable_gc_events) \
-    _(dispatch_stats) \
-    _(displaced_alien) \
-    _(dlclose) \
-    _(dll_validp) \
-    _(dlopen) \
-    _(dlsym) \
-    _(double_bits) \
-    _(enable_gc_events) \
-    _(existsp) \
-    _(exit) \
-    _(fclose) \
-    _(fflush) \
-    _(fgetc) \
-    _(fixnum_divint) \
-    _(fixnum_divmod) \
-    _(fixnum_shift) \
-    _(fixnum_to_bignum) \
-    _(fixnum_to_float) \
-    _(float_add) \
-    _(float_bits) \
-    _(float_divfloat) \
-    _(float_eq) \
-    _(float_greater) \
-    _(float_greatereq) \
-    _(float_less) \
-    _(float_lesseq) \
-    _(float_mod) \
-    _(float_multiply) \
-    _(float_subtract) \
-    _(float_to_bignum) \
-    _(float_to_fixnum) \
-    _(float_to_str) \
-    _(fopen) \
-    _(fputc) \
-    _(fread) \
-    _(fseek) \
-    _(ftell) \
-    _(full_gc) \
-    _(fwrite) \
-    _(identity_hashcode) \
-    _(innermost_stack_frame_executing) \
-    _(innermost_stack_frame_scan) \
-    _(jit_compile) \
-    _(load_locals) \
-    _(lookup_method) \
-    _(mega_cache_miss) \
-    _(minor_gc) \
-    _(modify_code_heap) \
-    _(nano_count) \
-    _(optimized_p) \
-    _(profiling) \
-    _(quot_compiled_p) \
-    _(quotation_code) \
-    _(reset_dispatch_stats) \
-    _(resize_array) \
-    _(resize_byte_array) \
-    _(resize_string) \
-    _(retainstack) \
-    _(save_image) \
-    _(save_image_and_exit) \
-    _(set_context_object) \
-    _(set_datastack) \
-    _(set_innermost_stack_frame_quot) \
-    _(set_retainstack) \
-    _(set_slot) \
-    _(set_special_object) \
-    _(set_string_nth_fast) \
-    _(set_string_nth_slow) \
-    _(size) \
-    _(sleep) \
-    _(special_object) \
-    _(string) \
-    _(string_nth) \
-    _(strip_stack_traces) \
-    _(system_micros) \
-    _(tuple) \
-    _(tuple_boa) \
-    _(unimplemented) \
-    _(uninitialized_byte_array) \
-    _(word) \
-    _(word_code) \
-    _(wrapper)
 
-/* These are generated with macros in alien.cpp, and not with PRIMIIVE in
-primitives.cpp */
+#define EACH_PRIMITIVE(_) \
+       _(alien_address) \
+       _(all_instances) \
+       _(array) \
+       _(array_to_quotation) \
+       _(become) \
+       _(bignum_add) \
+       _(bignum_and) \
+       _(bignum_bitp) \
+       _(bignum_divint) \
+       _(bignum_divmod) \
+       _(bignum_eq) \
+       _(bignum_greater) \
+       _(bignum_greatereq) \
+       _(bignum_less) \
+       _(bignum_lesseq) \
+       _(bignum_log2) \
+       _(bignum_mod) \
+       _(bignum_multiply) \
+       _(bignum_not) \
+       _(bignum_or) \
+       _(bignum_shift) \
+       _(bignum_subtract) \
+       _(bignum_to_fixnum) \
+       _(bignum_to_float) \
+       _(bignum_xor) \
+       _(bits_double) \
+       _(bits_float) \
+       _(byte_array) \
+       _(byte_array_to_bignum) \
+       _(call_clear) \
+       _(callback) \
+       _(callstack) \
+       _(callstack_to_array) \
+       _(check_datastack) \
+       _(clone) \
+       _(code_blocks) \
+       _(code_room) \
+       _(compact_gc) \
+       _(compute_identity_hashcode) \
+       _(context_object) \
+       _(current_callback) \
+       _(current_context) \
+       _(data_room) \
+       _(datastack) \
+       _(delete_context) \
+       _(die) \
+       _(disable_gc_events) \
+       _(dispatch_stats) \
+       _(displaced_alien) \
+       _(dlclose) \
+       _(dll_validp) \
+       _(dlopen) \
+       _(dlsym) \
+       _(double_bits) \
+       _(enable_gc_events) \
+       _(existsp) \
+       _(exit) \
+       _(fclose) \
+       _(fflush) \
+       _(fgetc) \
+       _(fixnum_divint) \
+       _(fixnum_divmod) \
+       _(fixnum_shift) \
+       _(fixnum_to_bignum) \
+       _(fixnum_to_float) \
+       _(float_add) \
+       _(float_bits) \
+       _(float_divfloat) \
+       _(float_eq) \
+       _(float_greater) \
+       _(float_greatereq) \
+       _(float_less) \
+       _(float_lesseq) \
+       _(float_mod) \
+       _(float_multiply) \
+       _(float_subtract) \
+       _(float_to_bignum) \
+       _(float_to_fixnum) \
+       _(float_to_str) \
+       _(fopen) \
+       _(fputc) \
+       _(fread) \
+       _(fseek) \
+       _(ftell) \
+       _(full_gc) \
+       _(fwrite) \
+       _(identity_hashcode) \
+       _(innermost_stack_frame_executing) \
+       _(innermost_stack_frame_scan) \
+       _(jit_compile) \
+       _(load_locals) \
+       _(lookup_method) \
+       _(mega_cache_miss) \
+       _(minor_gc) \
+       _(modify_code_heap) \
+       _(nano_count) \
+       _(optimized_p) \
+       _(profiling) \
+       _(quot_compiled_p) \
+       _(quotation_code) \
+       _(reset_dispatch_stats) \
+       _(resize_array) \
+       _(resize_byte_array) \
+       _(resize_string) \
+       _(retainstack) \
+       _(save_image) \
+       _(save_image_and_exit) \
+       _(set_context_object) \
+       _(set_datastack) \
+       _(set_innermost_stack_frame_quot) \
+       _(set_retainstack) \
+       _(set_slot) \
+       _(set_special_object) \
+       _(set_string_nth_fast) \
+       _(set_string_nth_slow) \
+       _(size) \
+       _(sleep) \
+       _(special_object) \
+       _(start_context) \
+       _(string) \
+       _(string_nth) \
+       _(strip_stack_traces) \
+       _(system_micros) \
+       _(tuple) \
+       _(tuple_boa) \
+       _(unimplemented) \
+       _(uninitialized_byte_array) \
+       _(word) \
+       _(word_code) \
+       _(wrapper)
 
 #define EACH_ALIEN_PRIMITIVE(_) \
-    _(signed_cell,fixnum,from_signed_cell,to_fixnum) \
-    _(unsigned_cell,cell,from_unsigned_cell,to_cell) \
-    _(signed_8,s64,from_signed_8,to_signed_8) \
-    _(unsigned_8,u64,from_unsigned_8,to_unsigned_8) \
-    _(signed_4,s32,from_signed_4,to_fixnum) \
-    _(unsigned_4,u32,from_unsigned_4,to_cell) \
-    _(signed_2,s16,from_signed_2,to_fixnum) \
-    _(unsigned_2,u16,from_unsigned_2,to_cell) \
-    _(signed_1,s8,from_signed_1,to_fixnum) \
-    _(unsigned_1,u8,from_unsigned_1,to_cell) \
-    _(float,float,from_float,to_float) \
-    _(double,double,from_double,to_double) \
-    _(cell,void *,allot_alien,pinned_alien_offset)
+       _(signed_cell,fixnum,from_signed_cell,to_fixnum) \
+       _(unsigned_cell,cell,from_unsigned_cell,to_cell) \
+       _(signed_8,s64,from_signed_8,to_signed_8) \
+       _(unsigned_8,u64,from_unsigned_8,to_unsigned_8) \
+       _(signed_4,s32,from_signed_4,to_fixnum) \
+       _(unsigned_4,u32,from_unsigned_4,to_cell) \
+       _(signed_2,s16,from_signed_2,to_fixnum) \
+       _(unsigned_2,u16,from_unsigned_2,to_cell) \
+       _(signed_1,s8,from_signed_1,to_fixnum) \
+       _(unsigned_1,u8,from_unsigned_1,to_cell) \
+       _(float,float,from_float,to_float) \
+       _(double,double,from_double,to_double) \
+       _(cell,void *,allot_alien,pinned_alien_offset)
 
 #define DECLARE_PRIMITIVE(name) VM_C_API void primitive_##name(factor_vm *parent);
 
 #define DECLARE_ALIEN_PRIMITIVE(name, type, from, to) \
-    DECLARE_PRIMITIVE(alien_##name) \
-    DECLARE_PRIMITIVE(set_alien_##name)
+       DECLARE_PRIMITIVE(alien_##name) \
+       DECLARE_PRIMITIVE(set_alien_##name)
 
 EACH_PRIMITIVE(DECLARE_PRIMITIVE)
 EACH_ALIEN_PRIMITIVE(DECLARE_ALIEN_PRIMITIVE)

diff --git a/vm/slot_visitor.hpp b/vm/slot_visitor.hpp
index e8ff7e30d25d567b86466c3db158d6dc5e05e909..d4dd44bed1a59b81cc78b5bdc50b04dedfb8ed75 100644 (file)
--- a/vm/slot_visitor.hpp
+++ b/vm/slot_visitor.hpp
@@ -170,15 +170,17 @@ void slot_visitor<Visitor>::visit_roots()
 template<typename Visitor>
 void slot_visitor<Visitor>::visit_contexts()
 {
-       context *ctx = parent->ctx;
-
-       while(ctx)
+       std::set<context *>::const_iterator begin = parent->active_contexts.begin();
+       std::set<context *>::const_iterator end = parent->active_contexts.end();
+       while(begin != end)
        {
-               visit_stack_elements(ctx->datastack_region,(cell *)ctx->datastack);
-               visit_stack_elements(ctx->retainstack_region,(cell *)ctx->retainstack);
+               context *ctx = *begin;
+
+               visit_stack_elements(ctx->datastack_seg,(cell *)ctx->datastack);
+               visit_stack_elements(ctx->retainstack_seg,(cell *)ctx->retainstack);
                visit_object_array(ctx->context_objects,ctx->context_objects + context_object_count);
 
-               ctx = ctx->next;
+               begin++;
        }
 }
 

diff --git a/vm/vm.cpp b/vm/vm.cpp
index be43371087b969b3454ac1a42f149ea05387efe7..87bf47f2906eba8d2d670197be2c720ab50c3e96 100755 (executable)
--- a/vm/vm.cpp
+++ b/vm/vm.cpp
@@ -5,6 +5,7 @@ namespace factor
 
 factor_vm::factor_vm() :
        nursery(0,0),
+       callback_id(0),
        c_to_factor_func(NULL),
        profiling_p(false),
        gc_off(false),
@@ -17,4 +18,9 @@ factor_vm::factor_vm() :
        primitive_reset_dispatch_stats();
 }
 
+factor_vm::~factor_vm()
+{
+       delete_contexts();
+}
+
 }

diff --git a/vm/vm.hpp b/vm/vm.hpp
index f20145b43f2a58cfde9d0782711be5f29aa19a82..f2f2d9a769857393a0f08569ccf0c8ebd23bafdb 100755 (executable)
--- a/vm/vm.hpp
+++ b/vm/vm.hpp
@@ -6,11 +6,14 @@ struct code_root;
 
 struct factor_vm
 {
-       // First five fields accessed directly by assembler. See vm.factor
+       // First 5 fields accessed directly by compiler. See basis/vm/vm.factor
 
-       /* Current stacks */
+       /* Current context */
        context *ctx;
-       
+
+       /* Spare context -- for callbacks */
+       context *spare_ctx;
+
        /* New objects are allocated here */
        nursery_space nursery;
 
@@ -23,10 +26,19 @@ struct factor_vm
        cell special_objects[special_object_count];
 
        /* Data stack and retain stack sizes */
-       cell ds_size, rs_size;
+       cell datastack_size, retainstack_size, callstack_size;
+
+       /* Stack of callback IDs */
+       std::vector<int> callback_ids;
+
+       /* Next callback ID */
+       int callback_id;
 
-       /* Pooling unused contexts to make callbacks cheaper */
-       context *unused_contexts;
+       /* Pooling unused contexts to make context allocation cheaper */
+       std::vector<context *> unused_contexts;
+
+       /* Active contexts, for tracing by the GC */
+       std::set<context *> active_contexts;
 
        /* Canonical truth value. In Factor, 't' */
        cell true_object;
@@ -96,11 +108,13 @@ struct factor_vm
        u64 last_nano_count;
 
        // contexts
-       context *alloc_context();
-       void dealloc_context(context *old_context);
-       void nest_stacks();
-       void unnest_stacks();
-       void init_stacks(cell ds_size_, cell rs_size_);
+       context *new_context();
+       void delete_context(context *old_context);
+       void init_contexts(cell datastack_size_, cell retainstack_size_, cell callstack_size_);
+       void delete_contexts();
+       void begin_callback();
+       void end_callback();
+       void primitive_current_callback();
        void primitive_context_object();
        void primitive_set_context_object();
        bool stack_to_array(cell bottom, cell top);
@@ -111,16 +125,15 @@ struct factor_vm
        void primitive_set_retainstack();
        void primitive_check_datastack();
        void primitive_load_locals();
+       void primitive_current_context();
+       void primitive_start_context();
+       void primitive_delete_context();
 
-       template<typename Iterator> void iterate_active_frames(Iterator &iter)
+       template<typename Iterator> void iterate_active_callstacks(Iterator &iter)
        {
-               context *ctx = this->ctx;
-
-               while(ctx)
-               {
-                       iterate_callstack(ctx,iter);
-                       ctx = ctx->next;
-               }
+               std::set<context *>::const_iterator begin = active_contexts.begin();
+               std::set<context *>::const_iterator end = active_contexts.end();
+               while(begin != end) iterate_callstack(*begin++,iter);
        }
 
        // run
@@ -694,6 +707,7 @@ struct factor_vm
   #endif
 
        factor_vm();
+       ~factor_vm();
 
 };