1 ! Copyright (C) 2005, 2010 Chris Double, Slava Pestov.
\r
2 ! See http://factorcode.org/license.txt for BSD license.
\r
3 USING: kernel kernel.private threads concurrency.mailboxes
\r
4 continuations namespaces assocs accessors summary fry ;
\r
5 IN: concurrency.messaging
\r
7 GENERIC: send ( message thread -- )
\r
9 GENERIC: mailbox-of ( thread -- mailbox )
\r
11 M: thread mailbox-of
\r
13 [ { mailbox } declare ]
\r
14 [ <mailbox> [ >>mailbox drop ] keep ] ?if ; inline
\r
16 M: thread send ( message thread -- )
\r
17 mailbox-of mailbox-put ;
\r
19 : my-mailbox ( -- mailbox ) self mailbox-of ; inline
\r
21 : receive ( -- message )
\r
22 my-mailbox mailbox-get ?linked ;
\r
24 : receive-timeout ( timeout -- message )
\r
25 [ my-mailbox ] dip mailbox-get-timeout ?linked ;
\r
27 : receive-if ( pred -- message )
\r
28 [ my-mailbox ] dip mailbox-get? ?linked ; inline
\r
30 : receive-if-timeout ( timeout pred -- message )
\r
31 [ my-mailbox ] 2dip mailbox-get-timeout? ?linked ; inline
\r
33 : rethrow-linked ( error process supervisor -- )
\r
34 [ <linked-error> ] dip send ;
\r
36 : spawn-linked ( quot name -- thread )
\r
37 my-mailbox spawn-linked-to ;
\r
39 TUPLE: synchronous data sender tag ;
\r
41 : <synchronous> ( data -- sync )
\r
42 self synchronous counter synchronous boa ;
\r
44 TUPLE: reply data tag ;
\r
46 : <reply> ( data synchronous -- reply )
\r
49 : synchronous-reply? ( response synchronous -- ? )
\r
50 over reply? [ [ tag>> ] same? ] [ 2drop f ] if ;
\r
52 ERROR: cannot-send-synchronous-to-self message thread ;
\r
54 M: cannot-send-synchronous-to-self summary
\r
55 drop "Cannot synchronous send to myself" ;
\r
57 : send-synchronous ( message thread -- reply )
\r
59 cannot-send-synchronous-to-self
\r
61 [ <synchronous> dup ] dip send
\r
62 '[ _ synchronous-reply? ] receive-if
\r
66 : reply-synchronous ( message synchronous -- )
\r
67 [ <reply> ] keep sender>> send ;
\r
69 : handle-synchronous ( quot -- )
\r
72 ] keep reply-synchronous ; inline
\r