Fix infinite loop and empty-dlist error when an error is thrown from a callback runni...

diff --git a/basis/compiler/tests/callback-error.factor b/basis/compiler/tests/callback-error.factor
new file mode 100644 (file)
index 0000000..9882cc2
--- /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 )
+    [ <process> ] dip
+        [ vm , , ] { } make >>command
+        +closed+ >>stdin
+        +stdout+ >>stderr
+    ascii <process-reader> 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 27ffdc629bbd4453631e51ec8caea9828514139d..4b6c2d6c4fad584565f8ed67a56a18282c0c77ef 100644 (file)
--- 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 ;
 
+: call-thread-error-handler? ( thread -- ? )
+    initial-thread get-global eq?
+    in-callback?
+    or not ;
+
 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 ;
+    global [
+        error-in-thread. nl
+        print-error nl
+        :c
+        flush
+    ] bind ;
 
-[ self error-in-thread stop ]
-thread-error-hook set-global
+[
+    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 cb61f70c2cd9f83fe8af4620f1a04541342a9b26..f2cbb572769d91092e098ac3c728cfd21ae168c6 100755 (executable)
--- 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 <alien> expiry-check boa ] dip set-global ]

diff --git a/vm/contexts.hpp b/vm/contexts.hpp
index 1098bb892faa950d2b38c428e80d6ff2afaf4318..58fb0aad82b3a6171b1c2fd311bca1db6033847a 100644 (file)
--- 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;