Change do-callback to register the current thread with the callback, instead of busy...

diff --git a/basis/bootstrap/threads/threads.factor b/basis/bootstrap/threads/threads.factor
index 2bc8d612b699fb916bdf986819ab7f99bc61b802..571f5bac5eac1c9a782f79372b761421142dc57c 100644 (file)
--- a/basis/bootstrap/threads/threads.factor
+++ b/basis/bootstrap/threads/threads.factor
@@ -1,9 +1,6 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2011 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: vocabs.loader kernel io.thread threads
-compiler.utilities namespaces ;
-IN: bootstrap.threads
+USE: vocabs.loader
 
-{ "bootstrap.threads" "debugger" } "debugger.threads" require-when
-
-[ yield ] yield-hook set-global
+"threads" require
+"io.thread" require

diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor
index e4fd64505e36cee763218e7e170f58ac17c92797..0aae136caef29ba5fcef7c20166137e4a51cb7a6 100644 (file)
--- a/basis/compiler/compiler.factor
+++ b/basis/compiler/compiler.factor
@@ -4,6 +4,7 @@ USING: accessors kernel namespaces arrays sequences io words fry
 continuations vocabs assocs definitions math graphs generic
 generic.single combinators combinators.smart macros
 source-files.errors combinators.short-circuit classes.algebra
+vocabs.loader
 
 stack-checker stack-checker.dependencies stack-checker.inlining
 stack-checker.errors
@@ -181,3 +182,5 @@ M: optimizing-compiler process-forgotten-words
 
 : disable-optimizer ( -- )
     f compiler-impl set-global ;
+
+{ "threads" "compiler" } "compiler.threads" require-when

diff --git a/basis/compiler/threads/authors.txt b/basis/compiler/threads/authors.txt
new file mode 100644 (file)
index 0000000..1901f27
--- /dev/null
+++ b/basis/compiler/threads/authors.txt
@@ -0,0 +1 @@
+Slava Pestov

diff --git a/basis/compiler/threads/threads.factor b/basis/compiler/threads/threads.factor
new file mode 100644 (file)
index 0000000..ed79653
--- /dev/null
+++ b/basis/compiler/threads/threads.factor
@@ -0,0 +1,12 @@
+! Copyright (C) 2011 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.private compiler.utilities kernel namespaces
+stack-checker.alien threads threads.private  ;
+IN: compiler.threads
+
+[ yield ] yield-hook set-global
+
+[
+    dup current-callback eq?
+    [ drop ] [ wait-for-callback ] if
+] wait-for-callback-hook set-global

diff --git a/basis/core-foundation/run-loop/run-loop.factor b/basis/core-foundation/run-loop/run-loop.factor
index 5396b83dcadeb4a65037176604a9c161af9b1ea3..4a095f173c6cfec9a9da928ed26cd82032d470f5 100644 (file)
--- a/basis/core-foundation/run-loop/run-loop.factor
+++ b/basis/core-foundation/run-loop/run-loop.factor
@@ -104,15 +104,8 @@ TUPLE: run-loop fds sources timers ;
 : (reset-timer) ( timer timestamp -- )
     >CFAbsoluteTime CFRunLoopTimerSetNextFireDate ;
 
-: nano-count>micros ( x -- n )
-    nano-count - 1,000 /f system-micros + ;
-
 : reset-timer ( timer -- )
-    {
-        { [ run-queue deque-empty? not ] [ system-micros ] }
-        { [ sleep-queue heap-empty? not ] [ sleep-queue heap-peek nip nano-count>micros ] }
-        [ system-micros 1,000,000 + ]
-    } cond (reset-timer) ;
+    sleep-time 1000 /f system-micros + (reset-timer) ;
 
 PRIVATE>
 

diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor
index 9159b7f46c6013f84a189a943b542244ef69e0a0..b3eb1d4ad03c4f90db8364db538422af483123b1 100755 (executable)
--- a/basis/debugger/debugger.factor
+++ b/basis/debugger/debugger.factor
@@ -355,3 +355,5 @@ M: not-found-in-roots summary drop "Cannot resolve vocab: path" ;
 M: wrong-values summary drop "Quotation's stack effect does not match call site" ;
 
 M: stack-effect-omits-dashes summary drop "Stack effect must contain “--”" ;
+
+{ "threads" "debugger" } "debugger.threads" require-when

diff --git a/basis/stack-checker/alien/alien.factor b/basis/stack-checker/alien/alien.factor
index 149168532f23d76a2fc475315935545b9755221f..d393aa93321a2b361b6499791839e9903f84b61c 100644 (file)
--- a/basis/stack-checker/alien/alien.factor
+++ b/basis/stack-checker/alien/alien.factor
@@ -122,9 +122,13 @@ TUPLE: alien-callback-params < alien-node-params xt ;
 
 GENERIC: wrap-callback-quot ( params quot -- quot' )
 
+SYMBOL: wait-for-callback-hook
+
+wait-for-callback-hook [ [ drop ] ] initialize
+
 M: callable wrap-callback-quot
     swap [ callback-parameter-quot ] [ callback-return-quot ] bi surround
-    yield-hook get
+    wait-for-callback-hook get
     '[ _ _ do-callback ]
     >quotation ;
 

diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor
index 330b4abd6cae99b88a9b61d9302f061f3d8e8739..fe4f2a0f24045a0ff7862ab455669c7349d73f1f 100644 (file)
--- a/basis/threads/threads.factor
+++ b/basis/threads/threads.factor
@@ -1,8 +1,8 @@
-! Copyright (C) 2004, 2010 Slava Pestov.
+! Copyright (C) 2004, 2011 Slava Pestov.
 ! Copyright (C) 2005 Mackenzie Straight.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays hashtables heaps kernel kernel.private math
-namespaces sequences vectors continuations continuations.private
+USING: alien.private arrays hashtables heaps kernel kernel.private
+math namespaces sequences vectors continuations continuations.private
 dlists assocs system combinators init boxes accessors math.order
 deques strings quotations fry ;
 IN: threads
@@ -101,6 +101,9 @@ PRIVATE>
 : sleep-queue ( -- heap )
     66 special-object { min-heap } declare ; inline
 
+: waiting-callbacks ( -- assoc )
+    68 special-object { hashtable } declare ; inline
+
 : new-thread ( quot name class -- thread )
     new
         swap >>name
@@ -123,6 +126,7 @@ PRIVATE>
 
 : sleep-time ( -- nanos/f )
     {
+        { [ current-callback waiting-callbacks key? ] [ 0 ] }
         { [ run-queue deque-empty? not ] [ 0 ] }
         { [ sleep-queue heap-empty? ] [ f ] }
         [ sleep-queue heap-peek nip nano-count [-] ]
@@ -176,8 +180,13 @@ M: thread (next)
     [ context>> box> set-context-and-delete ]
     [ t >>runnable drop [start] start-context-and-delete ] if ;
 
+: wake-up-callbacks ( -- )
+    current-callback waiting-callbacks delete-at*
+    [ resume-now ] [ drop ] if ;
+
 : next ( -- obj thread )
     expire-sleep-loop
+    wake-up-callbacks
     run-queue pop-back
     dup array? [ first2 ] [ [ f ] dip ] if
     f >>state
@@ -230,7 +239,8 @@ GENERIC: error-in-thread ( error thread -- )
 : init-thread-state ( -- )
     H{ } clone 64 set-special-object
     <dlist> 65 set-special-object
-    <min-heap> 66 set-special-object ;
+    <min-heap> 66 set-special-object
+    H{ } clone 68 set-special-object ;
 
 : init-initial-thread ( -- )
     [ ] "Initial" <thread>
@@ -244,6 +254,10 @@ GENERIC: error-in-thread ( error thread -- )
     init-thread-state
     init-initial-thread ;
 
+: wait-for-callback ( callback -- )
+    self swap waiting-callbacks set-at
+    "Callback return" suspend drop ;
+
 PRIVATE>
 
 [ init-threads ] "threads" add-startup-hook

diff --git a/core/alien/alien.factor b/core/alien/alien.factor
index 98b1d6428cfff4c441481ec4cd294ae4956d3213..cb61f70c2cd9f83fe8af4620f1a04541342a9b26 100755 (executable)
--- a/core/alien/alien.factor
+++ b/core/alien/alien.factor
@@ -101,21 +101,12 @@ SYMBOL: callbacks
 
 [ H{ } clone callbacks set-global ] "alien" add-startup-hook
 
-! 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 ; inline recursive
-
 ! Used by compiler.codegen to wrap callback bodies
-: do-callback ( callback-quot yield-quot: ( -- ) -- )
+: do-callback ( callback-quot wait-quot: ( callback -- ) -- )
     init-namespaces
     init-catchstack
     current-callback
-    [ 2drop call ] [ wait-to-return drop ] 3bi ; inline
+    [ 2drop call ] [ swap call( callback -- ) drop ] 3bi ; inline
 
 ! A utility for defining global variables that are recompiled in
 ! every session

diff --git a/vm/objects.hpp b/vm/objects.hpp
index 41265cd241dd5d17304ccafa330e284b720db38f..0b17c921bff00735995a8b44feb57dd6a3e5247d 100755 (executable)
--- a/vm/objects.hpp
+++ b/vm/objects.hpp
@@ -93,6 +93,8 @@ enum special_object {
        OBJ_SLEEP_QUEUE = 66,
 
        OBJ_VM_COMPILER = 67,     /* version string of the compiler we were built with */
+
+       OBJ_WAITING_CALLBACKS = 68,
 };
 
 /* save-image-and-exit discards special objects that are filled in on startup