threads: simplify 'suspend' combinator

diff --git a/basis/alarms/alarms-tests.factor b/basis/alarms/alarms-tests.factor
index 2379e3e80d809baba9cd08424a94a6955f28c67a..8f7868324d1f874061bf0f07de26015280f96c23 100644 (file)
--- a/basis/alarms/alarms-tests.factor
+++ b/basis/alarms/alarms-tests.factor
@@ -11,7 +11,6 @@ IN: alarms.tests
 ] unit-test\r
 \r
 [ ] [\r
-    [\r
-        [ resume ] curry instant later drop\r
-    ] "test" suspend drop\r
+    self [ resume ] curry instant later drop\r
+    "test" suspend drop\r
 ] unit-test\r

diff --git a/basis/channels/channels.factor b/basis/channels/channels.factor
index 0eb7881f95915c9c336ba09400e731ac2aaf1d1f..870085f77afbee1540475f5d3293a5d6892212b0 100644 (file)
--- a/basis/channels/channels.factor
+++ b/basis/channels/channels.factor
@@ -17,7 +17,7 @@ GENERIC: from ( channel -- value )
 <PRIVATE
 
 : wait ( channel -- )
-    [ senders>> push ] curry
+    [ self ] dip senders>> push
     "channel send" suspend drop ;
 
 : (to) ( value receivers -- )
@@ -36,7 +36,7 @@ M: channel to ( value channel -- )
     [ dup wait to ] [ nip (to) ] if-empty ;
 
 M: channel from ( channel -- value )
-    [
-        notify senders>>
-        [ (from) ] unless-empty
-    ] curry "channel receive" suspend ;
+    [ self ] dip
+    notify senders>>
+    [ (from) ] unless-empty
+    "channel receive" suspend ;

diff --git a/basis/concurrency/conditions/conditions.factor b/basis/concurrency/conditions/conditions.factor
index ad00bbdfa9ff262ca7f36af3248efc478c81f4c5..4a1c7d3370f40963f5a5fb798f22b818a0a56c2d 100644 (file)
--- a/basis/concurrency/conditions/conditions.factor
+++ b/basis/concurrency/conditions/conditions.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.\r
+! Copyright (C) 2008, 2010 Slava Pestov.\r
 ! See http://factorcode.org/license.txt for BSD license.\r
 USING: deques threads kernel arrays sequences alarms fry ;\r
 IN: concurrency.conditions\r
@@ -22,10 +22,13 @@ IN: concurrency.conditions
 \r
 ERROR: wait-timeout ;\r
 \r
+: queue ( queue -- )\r
+    [ self ] dip push-front ;\r
+\r
 : wait ( queue timeout status -- )\r
     over [\r
-        [ queue-timeout [ drop ] ] dip suspend\r
+        [ queue-timeout ] dip suspend\r
         [ wait-timeout ] [ cancel-alarm ] if\r
     ] [\r
-        [ drop '[ _ push-front ] ] dip suspend drop\r
+        [ drop queue ] dip suspend drop\r
     ] if ;\r

diff --git a/basis/concurrency/exchangers/exchangers.factor b/basis/concurrency/exchangers/exchangers.factor
index 97b3c14fe41cd29c4ac1185119b10463fcece045..7cfe01608529082aa7055e4b9c81ae7749697dfe 100644 (file)
--- a/basis/concurrency/exchangers/exchangers.factor
+++ b/basis/concurrency/exchangers/exchangers.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.\r
+! Copyright (C) 2008, 2010 Slava Pestov.\r
 ! See http://factorcode.org/license.txt for BSD license.\r
 USING: kernel threads boxes accessors fry ;\r
 IN: concurrency.exchangers\r
@@ -17,5 +17,6 @@ TUPLE: exchanger thread object ;
         [ thread>> box> resume-with ] dip\r
     ] [\r
         [ object>> >box ] keep\r
-        '[ _ thread>> >box ] "exchange" suspend\r
+        [ self ] dip thread>> >box\r
+        "exchange" suspend\r
     ] if ;\r

diff --git a/basis/deques/deques.factor b/basis/deques/deques.factor
index 1e1be404a77f5459215e6455e9d3aa7603b5847d..7483c0f56b12c90e330ae9a89c090f1496b68822 100644 (file)
--- a/basis/deques/deques.factor
+++ b/basis/deques/deques.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences math fry ;
 IN: deques
@@ -16,22 +16,22 @@ GENERIC: node-value ( node -- value )
 GENERIC: deque-empty? ( deque -- ? )
 
 : push-front ( obj deque -- )
-    push-front* drop ;
+    push-front* drop ; inline
 
 : push-all-front ( seq deque -- )
     [ push-front ] curry each ;
 
 : push-back ( obj deque -- )
-    push-back* drop ;
+    push-back* drop ; inline
 
 : push-all-back ( seq deque -- )
     [ push-back ] curry each ;
 
 : pop-front ( deque -- obj )
-    [ peek-front ] [ pop-front* ] bi ;
+    [ peek-front ] [ pop-front* ] bi ; inline
 
 : pop-back ( deque -- obj )
-    [ peek-back ] [ pop-back* ] bi ;
+    [ peek-back ] [ pop-back* ] bi ; inline
 
 : slurp-deque ( deque quot -- )
     [ drop '[ _ deque-empty? not ] ]

diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor
index 39f0a5fec381bd1d2e2bebfbc41a0017ce74bcee..0e84f1b65e522ff478cb779d93ff288bc60d6bb7 100644 (file)
--- a/basis/io/backend/unix/unix.factor
+++ b/basis/io/backend/unix/unix.factor
@@ -67,12 +67,11 @@ M: io-timeout summary drop "I/O operation timed out" ;
 
 : wait-for-fd ( handle event -- )
     dup +retry+ eq? [ 2drop ] [
-        '[
-            swap handle-fd mx get-global _ {
-                { +input+ [ add-input-callback ] }
-                { +output+ [ add-output-callback ] }
-            } case
-        ] "I/O" suspend nip [ io-timeout ] when
+        [ [ self ] dip handle-fd mx get-global ] dip {
+            { +input+ [ add-input-callback ] }
+            { +output+ [ add-output-callback ] }
+        } case
+        "I/O" suspend [ io-timeout ] when
     ] if ;
 
 : wait-for-port ( port event -- )

diff --git a/basis/io/backend/windows/nt/nt.factor b/basis/io/backend/windows/nt/nt.factor
index de29f33ee612d20bfb84222e1fc07eba6f4ee7fe..5cbe7b3ad94155f0630331b5ad9cb725d55d8076 100644 (file)
--- a/basis/io/backend/windows/nt/nt.factor
+++ b/basis/io/backend/windows/nt/nt.factor
@@ -40,8 +40,8 @@ M: winnt add-completion ( win32-handle -- )
 : twiddle-thumbs ( overlapped port -- bytes-transferred )
     [
         drop
-        [ >c-ptr pending-overlapped get-global set-at ] curry "I/O" suspend
-        {
+        [ self ] dip >c-ptr pending-overlapped get-global set-at
+        "I/O" suspend {
             { [ dup integer? ] [ ] }
             { [ dup array? ] [
                 first dup eof?

diff --git a/basis/io/launcher/launcher.factor b/basis/io/launcher/launcher.factor
index 3999a026c08f08baf6a2e35b2a0f1ed0ad78a376..dfbbd33d2e905fc7cc46f10aaac8bde1eabeb607 100755 (executable)
--- a/basis/io/launcher/launcher.factor
+++ b/basis/io/launcher/launcher.factor
@@ -129,12 +129,8 @@ M: process-was-killed error.
 
 : (wait-for-process) ( process -- status )
     dup handle>>
-    [
-        dup [ processes get at push ] curry
-        "process" suspend drop
-    ] when
-    dup killed>>
-    [ process-was-killed ] [ status>> ] if ;
+    [ self over processes get at push "process" suspend drop ] when
+    dup killed>> [ process-was-killed ] [ status>> ] if ;
 
 : wait-for-process ( process -- status )
     [ (wait-for-process) ] with-timeout ;

diff --git a/basis/threads/threads-docs.factor b/basis/threads/threads-docs.factor
index 995fc867e71c94f9160fa25f607187ff032d241e..335fbb3902705d131c5dff6d72d8c85b9bf3caad 100644 (file)
--- a/basis/threads/threads-docs.factor
+++ b/basis/threads/threads-docs.factor
@@ -142,10 +142,8 @@ HELP: interrupt
 { $description "Interrupts a sleeping thread." } ;
 
 HELP: suspend
-{ $values { "quot" { $quotation "( thread -- )" } } { "state" string } { "obj" object } }
-{ $description "Suspends the current thread and passes it to the quotation."
-$nl
-"After the quotation returns, control yields to the next runnable thread and the current thread does not execute again until it is resumed, and so the quotation must arrange for another thread to later resume the suspended thread with a call to " { $link resume } " or " { $link resume-with } "."
+{ $values { "state" string } { "obj" object } }
+{ $description "Suspends the current thread. Control yields to the next runnable thread and the current thread does not execute again until it is resumed, and so the caller of this word must arrange for another thread to later resume the suspended thread with a call to " { $link resume } " or " { $link resume-with } "."
 $nl
 "The status string is for debugging purposes; see " { $link "tools.threads" } "." } ;
 

diff --git a/basis/threads/threads-tests.factor b/basis/threads/threads-tests.factor
index 4568b7c491c76cf73b077f5ffdd3108107ed076c..6e573ccd884113ada0deeb14d763faad810d7b89 100644 (file)
--- a/basis/threads/threads-tests.factor
+++ b/basis/threads/threads-tests.factor
@@ -13,9 +13,7 @@ yield
 [ ] [ 0.3 sleep ] unit-test
 [ "hey" sleep ] must-fail
 
-[ 3 ] [
-    [ 3 swap resume-with ] "Test suspend" suspend
-] unit-test
+[ 3 ] [ 3 self resume-with "Test suspend" suspend ] unit-test
 
 [ f ] [ f get-global ] unit-test
 
@@ -29,8 +27,6 @@ yield
     ] parallel-map
 ] unit-test
 
-[ [ 3 throw ] "A" suspend ] [ 3 = ] must-fail-with
-
 :: spawn-namespace-test ( -- ? )
     <promise> :> p gensym :> g
     [

diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor
index 9282dda46f66a0bb437f75c3475c168d9a515b64..09869924f425d9464f8317697a073a4a828ccea7 100644 (file)
--- a/basis/threads/threads.factor
+++ b/basis/threads/threads.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2009 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
 ! Copyright (C) 2005 Mackenzie Straight.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays hashtables heaps kernel kernel.private math
@@ -12,8 +12,8 @@ IN: threads
 ! (set-context) and (start-context) are sub-primitives, but
 ! we don't want them inlined into callers since their behavior
 ! depends on what frames are on the callstack
-: start-context ( obj quot: ( obj -- * ) -- ) (start-context) ;
-: set-context ( context -- ) (set-context) ;
+: set-context ( obj context -- obj' ) (set-context) ;
+: start-context ( obj quot: ( obj -- * ) -- obj' ) (start-context) ;
 
 PRIVATE>
 
@@ -24,14 +24,15 @@ TUPLE: thread
 { quot callable initial: [ ] }
 { exit-handler callable initial: [ ] }
 { id integer }
-continuation
+{ continuation box }
 state
 runnable
 mailbox
-variables
+{ variables hashtable }
 sleep-entry ;
 
-: self ( -- thread ) 63 special-object ; inline
+: self ( -- thread )
+    63 special-object { thread } declare ; inline
 
 ! Thread-local storage
 : tnamespace ( -- assoc )
@@ -46,9 +47,11 @@ sleep-entry ;
 : tchange ( key quot -- )
     tnamespace swap change-at ; inline
 
-: threads ( -- assoc ) 64 special-object ;
+: threads ( -- assoc )
+    64 special-object { hashtable } declare ; inline
 
-: thread ( id -- thread ) threads at ;
+: thread ( id -- thread )
+    threads at ;
 
 : thread-registered? ( thread -- ? )
     id>> threads key? ;
@@ -85,9 +88,11 @@ PRIVATE>
 : <thread> ( quot name -- thread )
     \ thread new-thread ;
 
-: run-queue ( -- dlist ) 65 special-object ;
+: run-queue ( -- dlist )
+    65 special-object { dlist } declare ; inline
 
-: sleep-queue ( -- heap ) 66 special-object ;
+: sleep-queue ( -- heap )
+    66 special-object { dlist } declare ; inline
 
 : resume ( thread -- )
     f >>state
@@ -175,25 +180,22 @@ DEFER: next
 
 PRIVATE>
 
-: stop ( -- )
+: stop ( -- * )
     self [ exit-handler>> call( -- ) ] [ unregister-thread ] bi next ;
 
-: suspend ( quot state -- obj )
-    [
-        [ [ self swap call ] dip self (>>state) ] dip
-        self continuation>> >box
-        next
-    ] callcc1 2nip ; inline
+: suspend ( state -- obj )
+    self (>>state)
+    [ self continuation>> >box next ] callcc1 ; inline
 
-: yield ( -- ) [ resume ] f suspend drop ;
+: yield ( -- ) self resume f suspend drop ;
 
 GENERIC: sleep-until ( n/f -- )
 
 M: integer sleep-until
-    '[ _ schedule-sleep ] "sleep" suspend drop ;
+    [ self ] dip schedule-sleep "sleep" suspend drop ;
 
 M: f sleep-until
-    drop [ drop ] "interrupt" suspend drop ;
+    drop "interrupt" suspend drop ;
 
 GENERIC: sleep ( dt -- )
 
@@ -218,7 +220,7 @@ M: real sleep
 
 : in-thread ( quot -- )
     [ datastack ] dip
-    '[ _ set-datastack _ call ]
+    '[ _ set-datastack @ ]
     "Thread" spawn drop ;
 
 GENERIC: error-in-thread ( error thread -- )

diff --git a/basis/tools/continuations/continuations.factor b/basis/tools/continuations/continuations.factor
index 15fdb9f9b551b5b431e2d1d8da76412f754d770f..6f748cdb311c61240f6ad8e64cd0a0ce8620774b 100644 (file)
--- a/basis/tools/continuations/continuations.factor
+++ b/basis/tools/continuations/continuations.factor
@@ -1,10 +1,11 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: threads kernel namespaces continuations combinators
-sequences math namespaces.private continuations.private
-concurrency.messaging quotations kernel.private words
-sequences.private assocs models models.arrow arrays accessors
-generic generic.single definitions make sbufs tools.crossref fry ;
+USING: threads threads.private kernel namespaces continuations
+combinators sequences math namespaces.private
+continuations.private concurrency.messaging quotations
+kernel.private words sequences.private assocs models
+models.arrow arrays accessors generic generic.single definitions
+make sbufs tools.crossref fry ;
 IN: tools.continuations
 
 <PRIVATE
@@ -126,6 +127,7 @@ PRIVATE>
     >n ndrop >c c>
     continue continue-with
     stop suspend (spawn)
+    set-context start-context
 } [ don't-step-into ] each
 
 \ break [ break ] "step-into" set-word-prop