diff --git a/basis/compiler/tests/callback-error.factor b/basis/compiler/tests/callback-error.factor new file mode 100644 index 0000000000..9882cc2501 --- /dev/null +++ b/basis/compiler/tests/callback-error.factor @@ -0,0 +1,43 @@ +USING: accessors io io.encodings.ascii io.launcher kernel make +sequences system tools.test ; +IN: compiler.tests.callback-error + +: run-vm-with-script ( string -- lines ) + [ ] dip + [ vm , , ] { } make >>command + +closed+ >>stdin + +stdout+ >>stderr + ascii stream-lines ; + +! Callback error from initial thread +[ t ] [ + """-e=USING: alien alien.c-types alien.syntax kernel ; + IN: scratchpad + + : callback-death ( -- callback ) + void { } cdecl [ "Error!" throw ] alien-callback ; + + : callback-invoke ( callback -- ) + void { } cdecl alien-indirect ; + + callback-death callback-invoke""" + run-vm-with-script + "\"Error!\"" swap member? +] unit-test + +! Callback error from another thread +[ t ] [ + """-e=USING: alien alien.c-types alien.syntax kernel threads ; + IN: scratchpad + + : callback-death ( -- callback ) + void { } cdecl [ "Error!" throw ] alien-callback ; + + : callback-invoke ( callback -- ) + void { } cdecl alien-indirect ; + + [ callback-death callback-invoke ] in-thread + stop""" + run-vm-with-script + "\"Error!\"" swap member? +] unit-test diff --git a/basis/debugger/threads/threads.factor b/basis/debugger/threads/threads.factor index 27ffdc629b..4b6c2d6c4f 100644 --- a/basis/debugger/threads/threads.factor +++ b/basis/debugger/threads/threads.factor @@ -1,7 +1,8 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2011 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors debugger continuations threads threads.private -io io.styles prettyprint kernel math.parser namespaces make ; +USING: accessors alien debugger continuations threads +threads.private io io.styles prettyprint kernel make math.parser +namespaces ; IN: debugger.threads : error-in-thread. ( thread -- ) @@ -12,17 +13,21 @@ IN: debugger.threads ", " % dup quot>> unparse-short % ")" % ] "" make swap write-object ":" print ; -M: thread error-in-thread ( error thread -- ) - initial-thread get-global eq? [ - die drop - ] [ - global [ - error-thread get-global error-in-thread. nl - print-error nl - :c - flush - ] bind - ] if ; +: call-thread-error-handler? ( thread -- ? ) + initial-thread get-global eq? + in-callback? + or not ; -[ self error-in-thread stop ] -thread-error-hook set-global +M: thread error-in-thread ( error thread -- ) + global [ + error-in-thread. nl + print-error nl + :c + flush + ] bind ; + +[ + dup call-thread-error-handler? + [ self error-in-thread stop ] + [ [ die ] call( error thread -- * ) ] if +] thread-error-hook set-global diff --git a/core/alien/alien.factor b/core/alien/alien.factor index cb61f70c2c..f2cbb57276 100755 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -103,6 +103,7 @@ SYMBOL: callbacks ! Used by compiler.codegen to wrap callback bodies : do-callback ( callback-quot wait-quot: ( callback -- ) -- ) + t 3 set-context-object init-namespaces init-catchstack current-callback @@ -117,6 +118,8 @@ TUPLE: expiry-check object alien ; PRIVATE> +: in-callback? ( -- ? ) 3 context-object ; + : initialize-alien ( symbol quot -- ) swap dup get-global dup recompute-value? [ drop [ call dup 31337 expiry-check boa ] dip set-global ] diff --git a/vm/contexts.hpp b/vm/contexts.hpp index 1098bb892f..58fb0aad82 100644 --- a/vm/contexts.hpp +++ b/vm/contexts.hpp @@ -7,6 +7,7 @@ enum context_object { OBJ_NAMESTACK, OBJ_CATCHSTACK, OBJ_CONTEXT, + OBJ_IN_CALLBACK_P, }; static const cell stack_reserved = 1024;