1 ! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
\r
2 ! See http://factorcode.org/license.txt for BSD license.
\r
3 IN: concurrency.mailboxes
\r
4 USING: dlists deques threads sequences continuations
\r
5 destructors namespaces random math quotations words kernel
\r
6 arrays assocs init system concurrency.conditions accessors
\r
7 debugger debugger.threads locals ;
\r
9 TUPLE: mailbox threads data disposed ;
\r
11 M: mailbox dispose* threads>> notify-all ;
\r
13 : <mailbox> ( -- mailbox )
\r
14 <dlist> <dlist> f mailbox boa ;
\r
16 : mailbox-empty? ( mailbox -- bool )
\r
17 data>> deque-empty? ;
\r
19 : mailbox-put ( obj mailbox -- )
\r
20 [ data>> push-front ]
\r
21 [ threads>> notify-all ] bi yield ;
\r
23 : wait-for-mailbox ( mailbox timeout -- )
\r
24 >r threads>> r> "mailbox" wait ;
\r
26 :: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- )
\r
27 mailbox check-disposed
\r
28 mailbox data>> pred dlist-contains? [
\r
29 mailbox timeout wait-for-mailbox
\r
30 mailbox timeout pred block-unless-pred
\r
31 ] unless ; inline recursive
\r
33 : block-if-empty ( mailbox timeout -- mailbox )
\r
35 over mailbox-empty? [
\r
36 2dup wait-for-mailbox block-if-empty
\r
41 : mailbox-peek ( mailbox -- obj )
\r
44 : mailbox-get-timeout ( mailbox timeout -- obj )
\r
45 block-if-empty data>> pop-back ;
\r
47 : mailbox-get ( mailbox -- obj )
\r
48 f mailbox-get-timeout ;
\r
50 : mailbox-get-all-timeout ( mailbox timeout -- array )
\r
52 [ dup mailbox-empty? ]
\r
53 [ dup data>> pop-back ]
\r
56 : mailbox-get-all ( mailbox -- array )
\r
57 f mailbox-get-all-timeout ;
\r
59 : while-mailbox-empty ( mailbox quot -- )
\r
60 [ [ mailbox-empty? ] curry ] dip [ ] while ; inline
\r
62 : mailbox-get-timeout? ( mailbox timeout pred -- obj )
\r
63 [ block-unless-pred ]
\r
64 [ nip >r data>> r> delete-node-if ]
\r
67 : mailbox-get? ( mailbox pred -- obj )
\r
68 f swap mailbox-get-timeout? ; inline
\r
70 : wait-for-close-timeout ( mailbox timeout -- )
\r
72 [ 2drop ] [ 2dup wait-for-mailbox wait-for-close-timeout ] if ;
\r
74 : wait-for-close ( mailbox -- )
\r
75 f wait-for-close-timeout ;
\r
77 TUPLE: linked-error error thread ;
\r
79 M: linked-error error.
\r
80 [ thread>> error-in-thread. ] [ error>> error. ] bi ;
\r
82 C: <linked-error> linked-error
\r
84 : ?linked ( message -- message )
\r
85 dup linked-error? [ rethrow ] when ;
\r
87 TUPLE: linked-thread < thread supervisor ;
\r
89 M: linked-thread error-in-thread
\r
90 [ <linked-error> ] [ supervisor>> ] bi mailbox-put ;
\r
92 : <linked-thread> ( quot name mailbox -- thread' )
\r
93 >r linked-thread new-thread r> >>supervisor ;
\r
95 : spawn-linked-to ( quot name mailbox -- thread )
\r
96 <linked-thread> [ (spawn) ] keep ;
\r