Change do-callback to register the current thread with the callback, instead of busy waiting for the current callback to become the right one before returning. Fixes 100% CPU usage issue with system-alert. Thanks to Blei and ex-rzr for doing preliminary analysis of the issue

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

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

basis/compiler/threads/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

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

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>
 

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

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 ;
 

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

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

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