88 lines
2.4 KiB
Factor
Executable File
88 lines
2.4 KiB
Factor
Executable File
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
IN: concurrency.mailboxes
|
|
USING: dlists threads sequences continuations
|
|
namespaces random math quotations words kernel arrays assocs
|
|
init system concurrency.conditions ;
|
|
|
|
TUPLE: mailbox threads data ;
|
|
|
|
: <mailbox> ( -- mailbox )
|
|
<dlist> <dlist> mailbox construct-boa ;
|
|
|
|
: mailbox-empty? ( mailbox -- bool )
|
|
mailbox-data dlist-empty? ;
|
|
|
|
: mailbox-put ( obj mailbox -- )
|
|
[ mailbox-data push-front ] keep
|
|
mailbox-threads notify-all yield ;
|
|
|
|
: block-unless-pred ( pred mailbox timeout -- )
|
|
2over mailbox-data dlist-contains? [
|
|
3drop
|
|
] [
|
|
2dup >r mailbox-threads r> "mailbox" wait
|
|
block-unless-pred
|
|
] if ; inline
|
|
|
|
: block-if-empty ( mailbox timeout -- mailbox )
|
|
over mailbox-empty? [
|
|
2dup >r mailbox-threads r> "mailbox" wait
|
|
block-if-empty
|
|
] [
|
|
drop
|
|
] if ;
|
|
|
|
: mailbox-peek ( mailbox -- obj )
|
|
mailbox-data peek-back ;
|
|
|
|
: mailbox-get-timeout ( mailbox timeout -- obj )
|
|
block-if-empty mailbox-data pop-back ;
|
|
|
|
: mailbox-get ( mailbox -- obj )
|
|
f mailbox-get-timeout ;
|
|
|
|
: mailbox-get-all-timeout ( mailbox timeout -- array )
|
|
block-if-empty
|
|
[ dup mailbox-empty? ]
|
|
[ dup mailbox-data pop-back ]
|
|
[ ] unfold nip ;
|
|
|
|
: mailbox-get-all ( mailbox -- array )
|
|
f mailbox-get-all-timeout ;
|
|
|
|
: while-mailbox-empty ( mailbox quot -- )
|
|
over mailbox-empty? [
|
|
dup >r swap slip r> while-mailbox-empty
|
|
] [
|
|
2drop
|
|
] if ; inline
|
|
|
|
: mailbox-get-timeout? ( pred mailbox timeout -- obj )
|
|
[ block-unless-pred ] 3keep drop
|
|
mailbox-data delete-node-if ; inline
|
|
|
|
: mailbox-get? ( pred mailbox -- obj )
|
|
f mailbox-get-timeout? ; inline
|
|
|
|
TUPLE: linked-error thread ;
|
|
|
|
: <linked-error> ( error thread -- linked )
|
|
{ set-delegate set-linked-error-thread }
|
|
linked-error construct ;
|
|
|
|
: ?linked dup linked-error? [ rethrow ] when ;
|
|
|
|
TUPLE: linked-thread supervisor ;
|
|
|
|
M: linked-thread error-in-thread
|
|
[ <linked-error> ] keep
|
|
linked-thread-supervisor mailbox-put ;
|
|
|
|
: <linked-thread> ( quot name mailbox -- thread' )
|
|
>r <thread> linked-thread construct-delegate r>
|
|
over set-linked-thread-supervisor ;
|
|
|
|
: spawn-linked-to ( quot name mailbox -- thread )
|
|
<linked-thread> [ (spawn) ] keep ;
|