From f1e19aabdbf96fcfc8b84abf2e6b3bd7f9649533 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 27 Mar 2010 12:03:06 -0400 Subject: [PATCH] threads: simplify 'suspend' combinator --- basis/alarms/alarms-tests.factor | 5 +-- basis/channels/channels.factor | 10 ++--- .../concurrency/conditions/conditions.factor | 9 ++-- .../concurrency/exchangers/exchangers.factor | 5 ++- basis/deques/deques.factor | 10 ++--- basis/io/backend/unix/unix.factor | 11 +++-- basis/io/backend/windows/nt/nt.factor | 4 +- basis/io/launcher/launcher.factor | 8 +--- basis/threads/threads-docs.factor | 6 +-- basis/threads/threads-tests.factor | 6 +-- basis/threads/threads.factor | 44 ++++++++++--------- .../tools/continuations/continuations.factor | 14 +++--- 12 files changed, 64 insertions(+), 68 deletions(-) diff --git a/basis/alarms/alarms-tests.factor b/basis/alarms/alarms-tests.factor index 2379e3e80d..8f7868324d 100644 --- a/basis/alarms/alarms-tests.factor +++ b/basis/alarms/alarms-tests.factor @@ -11,7 +11,6 @@ IN: alarms.tests ] unit-test [ ] [ - [ - [ resume ] curry instant later drop - ] "test" suspend drop + self [ resume ] curry instant later drop + "test" suspend drop ] unit-test diff --git a/basis/channels/channels.factor b/basis/channels/channels.factor index 0eb7881f95..870085f77a 100644 --- a/basis/channels/channels.factor +++ b/basis/channels/channels.factor @@ -17,7 +17,7 @@ GENERIC: from ( channel -- value ) > 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 ad00bbdfa9..4a1c7d3370 100644 --- a/basis/concurrency/conditions/conditions.factor +++ b/basis/concurrency/conditions/conditions.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: deques threads kernel arrays sequences alarms fry ; IN: concurrency.conditions @@ -22,10 +22,13 @@ IN: concurrency.conditions ERROR: wait-timeout ; +: queue ( queue -- ) + [ self ] dip push-front ; + : wait ( queue timeout status -- ) over [ - [ queue-timeout [ drop ] ] dip suspend + [ queue-timeout ] dip suspend [ wait-timeout ] [ cancel-alarm ] if ] [ - [ drop '[ _ push-front ] ] dip suspend drop + [ drop queue ] dip suspend drop ] if ; diff --git a/basis/concurrency/exchangers/exchangers.factor b/basis/concurrency/exchangers/exchangers.factor index 97b3c14fe4..7cfe016085 100644 --- a/basis/concurrency/exchangers/exchangers.factor +++ b/basis/concurrency/exchangers/exchangers.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel threads boxes accessors fry ; IN: concurrency.exchangers @@ -17,5 +17,6 @@ TUPLE: exchanger thread object ; [ thread>> box> resume-with ] dip ] [ [ object>> >box ] keep - '[ _ thread>> >box ] "exchange" suspend + [ self ] dip thread>> >box + "exchange" suspend ] if ; diff --git a/basis/deques/deques.factor b/basis/deques/deques.factor index 1e1be404a7..7483c0f56b 100644 --- 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 39f0a5fec3..0e84f1b65e 100644 --- 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 de29f33ee6..5cbe7b3ad9 100644 --- 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 3999a026c0..dfbbd33d2e 100755 --- 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 995fc867e7..335fbb3902 100644 --- 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 4568b7c491..6e573ccd88 100644 --- 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 ( -- ? ) :> p gensym :> g [ diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor index 9282dda46f..09869924f4 100644 --- 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> : ( 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 15fdb9f9b5..6f748cdb31 100644 --- 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 >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