Merge up
Erik Charlebois
parent
430ace7b7b
commit
30b586ef5f
|
|
@ -1,54 +1,54 @@
|
|||
USING: concurrency.mailboxes concurrency.count-downs concurrency.conditions
|
||||
vectors sequences threads tools.test math kernel strings namespaces
|
||||
continuations calendar destructors ;
|
||||
IN: concurrency.mailboxes.tests
|
||||
|
||||
{ 1 1 } [ [ integer? ] mailbox-get? ] must-infer-as
|
||||
|
||||
[ V{ 1 2 3 } ] [
|
||||
0 <vector>
|
||||
<mailbox>
|
||||
[ mailbox-get swap push ] in-thread
|
||||
[ mailbox-get swap push ] in-thread
|
||||
[ mailbox-get swap push ] in-thread
|
||||
1 over mailbox-put
|
||||
2 over mailbox-put
|
||||
3 swap mailbox-put
|
||||
] unit-test
|
||||
|
||||
[ V{ 1 2 3 } ] [
|
||||
0 <vector>
|
||||
<mailbox>
|
||||
[ [ integer? ] mailbox-get? swap push ] in-thread
|
||||
[ [ integer? ] mailbox-get? swap push ] in-thread
|
||||
[ [ integer? ] mailbox-get? swap push ] in-thread
|
||||
1 over mailbox-put
|
||||
2 over mailbox-put
|
||||
3 swap mailbox-put
|
||||
] unit-test
|
||||
|
||||
[ V{ 1 "junk" 3 "junk2" } [ 456 ] ] [
|
||||
0 <vector>
|
||||
<mailbox>
|
||||
[ [ integer? ] mailbox-get? swap push ] in-thread
|
||||
[ [ integer? ] mailbox-get? swap push ] in-thread
|
||||
[ [ string? ] mailbox-get? swap push ] in-thread
|
||||
[ [ string? ] mailbox-get? swap push ] in-thread
|
||||
1 over mailbox-put
|
||||
"junk" over mailbox-put
|
||||
[ 456 ] over mailbox-put
|
||||
3 over mailbox-put
|
||||
"junk2" over mailbox-put
|
||||
mailbox-get
|
||||
] unit-test
|
||||
|
||||
[ { "foo" "bar" } ] [
|
||||
<mailbox>
|
||||
"foo" over mailbox-put
|
||||
"bar" over mailbox-put
|
||||
mailbox-get-all
|
||||
] unit-test
|
||||
|
||||
[
|
||||
<mailbox> 1 seconds mailbox-get-timeout
|
||||
] [ wait-timeout? ] must-fail-with
|
||||
USING: concurrency.mailboxes concurrency.count-downs concurrency.conditions
|
||||
vectors sequences threads tools.test math kernel strings namespaces
|
||||
continuations calendar destructors ;
|
||||
IN: concurrency.mailboxes.tests
|
||||
|
||||
{ 1 1 } [ [ integer? ] mailbox-get? ] must-infer-as
|
||||
|
||||
[ V{ 1 2 3 } ] [
|
||||
0 <vector>
|
||||
<mailbox>
|
||||
[ mailbox-get swap push ] in-thread
|
||||
[ mailbox-get swap push ] in-thread
|
||||
[ mailbox-get swap push ] in-thread
|
||||
1 over mailbox-put
|
||||
2 over mailbox-put
|
||||
3 swap mailbox-put
|
||||
] unit-test
|
||||
|
||||
[ V{ 1 2 3 } ] [
|
||||
0 <vector>
|
||||
<mailbox>
|
||||
[ [ integer? ] mailbox-get? swap push ] in-thread
|
||||
[ [ integer? ] mailbox-get? swap push ] in-thread
|
||||
[ [ integer? ] mailbox-get? swap push ] in-thread
|
||||
1 over mailbox-put
|
||||
2 over mailbox-put
|
||||
3 swap mailbox-put
|
||||
] unit-test
|
||||
|
||||
[ V{ 1 "junk" 3 "junk2" } [ 456 ] ] [
|
||||
0 <vector>
|
||||
<mailbox>
|
||||
[ [ integer? ] mailbox-get? swap push ] in-thread
|
||||
[ [ integer? ] mailbox-get? swap push ] in-thread
|
||||
[ [ string? ] mailbox-get? swap push ] in-thread
|
||||
[ [ string? ] mailbox-get? swap push ] in-thread
|
||||
1 over mailbox-put
|
||||
"junk" over mailbox-put
|
||||
[ 456 ] over mailbox-put
|
||||
3 over mailbox-put
|
||||
"junk2" over mailbox-put
|
||||
mailbox-get
|
||||
] unit-test
|
||||
|
||||
[ { "foo" "bar" } ] [
|
||||
<mailbox>
|
||||
"foo" over mailbox-put
|
||||
"bar" over mailbox-put
|
||||
mailbox-get-all
|
||||
] unit-test
|
||||
|
||||
[
|
||||
<mailbox> 1 seconds mailbox-get-timeout
|
||||
] [ wait-timeout? ] must-fail-with
|
||||
|
|
|
|||
|
|
@ -1,94 +1,94 @@
|
|||
! Copyright (C) 2005, 2010 Chris Double, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: dlists deques threads sequences continuations namespaces
|
||||
math quotations words kernel arrays assocs init system
|
||||
concurrency.conditions accessors debugger debugger.threads
|
||||
locals fry ;
|
||||
IN: concurrency.mailboxes
|
||||
|
||||
TUPLE: mailbox threads data ;
|
||||
|
||||
: <mailbox> ( -- mailbox )
|
||||
mailbox new
|
||||
<dlist> >>threads
|
||||
<dlist> >>data ;
|
||||
|
||||
: mailbox-empty? ( mailbox -- bool )
|
||||
data>> deque-empty? ;
|
||||
|
||||
: mailbox-put ( obj mailbox -- )
|
||||
[ data>> push-front ]
|
||||
[ threads>> notify-all ] bi yield ;
|
||||
|
||||
: wait-for-mailbox ( mailbox timeout -- )
|
||||
[ threads>> ] dip "mailbox" wait ;
|
||||
|
||||
:: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- )
|
||||
mailbox data>> pred dlist-any? [
|
||||
mailbox timeout wait-for-mailbox
|
||||
mailbox timeout pred block-unless-pred
|
||||
] unless ; inline recursive
|
||||
|
||||
: block-if-empty ( mailbox timeout -- mailbox )
|
||||
over mailbox-empty? [
|
||||
2dup wait-for-mailbox block-if-empty
|
||||
] [
|
||||
drop
|
||||
] if ;
|
||||
|
||||
: mailbox-peek ( mailbox -- obj )
|
||||
data>> peek-back ;
|
||||
|
||||
: mailbox-get-timeout ( mailbox timeout -- obj )
|
||||
block-if-empty data>> pop-back ;
|
||||
|
||||
: mailbox-get ( mailbox -- obj )
|
||||
f mailbox-get-timeout ;
|
||||
|
||||
: mailbox-get-all-timeout ( mailbox timeout -- array )
|
||||
block-if-empty
|
||||
[ dup mailbox-empty? not ]
|
||||
[ dup data>> pop-back ]
|
||||
produce nip ;
|
||||
|
||||
: mailbox-get-all ( mailbox -- array )
|
||||
f mailbox-get-all-timeout ;
|
||||
|
||||
: while-mailbox-empty ( mailbox quot -- )
|
||||
[ '[ _ mailbox-empty? ] ] dip while ; inline
|
||||
|
||||
: mailbox-get-timeout? ( mailbox timeout pred -- obj )
|
||||
[ block-unless-pred ]
|
||||
[ [ drop data>> ] dip delete-node-if ]
|
||||
3bi ; inline
|
||||
|
||||
: mailbox-get? ( mailbox pred -- obj )
|
||||
f swap mailbox-get-timeout? ; inline
|
||||
|
||||
: wait-for-close-timeout ( mailbox timeout -- )
|
||||
over disposed>>
|
||||
[ 2drop ] [ 2dup wait-for-mailbox wait-for-close-timeout ] if ;
|
||||
|
||||
: wait-for-close ( mailbox -- )
|
||||
f wait-for-close-timeout ;
|
||||
|
||||
TUPLE: linked-error error thread ;
|
||||
|
||||
M: linked-error error.
|
||||
[ thread>> error-in-thread. ] [ error>> error. ] bi ;
|
||||
|
||||
C: <linked-error> linked-error
|
||||
|
||||
: ?linked ( message -- message )
|
||||
dup linked-error? [ rethrow ] when ;
|
||||
|
||||
TUPLE: linked-thread < thread supervisor ;
|
||||
|
||||
M: linked-thread error-in-thread
|
||||
[ <linked-error> ] [ supervisor>> ] bi mailbox-put ;
|
||||
|
||||
: <linked-thread> ( quot name mailbox -- thread' )
|
||||
[ linked-thread new-thread ] dip >>supervisor ;
|
||||
|
||||
: spawn-linked-to ( quot name mailbox -- thread )
|
||||
<linked-thread> [ (spawn) ] keep ;
|
||||
! Copyright (C) 2005, 2010 Chris Double, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: dlists deques threads sequences continuations namespaces
|
||||
math quotations words kernel arrays assocs init system
|
||||
concurrency.conditions accessors debugger debugger.threads
|
||||
locals fry ;
|
||||
IN: concurrency.mailboxes
|
||||
|
||||
TUPLE: mailbox threads data ;
|
||||
|
||||
: <mailbox> ( -- mailbox )
|
||||
mailbox new
|
||||
<dlist> >>threads
|
||||
<dlist> >>data ;
|
||||
|
||||
: mailbox-empty? ( mailbox -- bool )
|
||||
data>> deque-empty? ;
|
||||
|
||||
: mailbox-put ( obj mailbox -- )
|
||||
[ data>> push-front ]
|
||||
[ threads>> notify-all ] bi yield ;
|
||||
|
||||
: wait-for-mailbox ( mailbox timeout -- )
|
||||
[ threads>> ] dip "mailbox" wait ;
|
||||
|
||||
:: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- )
|
||||
mailbox data>> pred dlist-any? [
|
||||
mailbox timeout wait-for-mailbox
|
||||
mailbox timeout pred block-unless-pred
|
||||
] unless ; inline recursive
|
||||
|
||||
: block-if-empty ( mailbox timeout -- mailbox )
|
||||
over mailbox-empty? [
|
||||
2dup wait-for-mailbox block-if-empty
|
||||
] [
|
||||
drop
|
||||
] if ;
|
||||
|
||||
: mailbox-peek ( mailbox -- obj )
|
||||
data>> peek-back ;
|
||||
|
||||
: mailbox-get-timeout ( mailbox timeout -- obj )
|
||||
block-if-empty data>> pop-back ;
|
||||
|
||||
: mailbox-get ( mailbox -- obj )
|
||||
f mailbox-get-timeout ;
|
||||
|
||||
: mailbox-get-all-timeout ( mailbox timeout -- array )
|
||||
block-if-empty
|
||||
[ dup mailbox-empty? not ]
|
||||
[ dup data>> pop-back ]
|
||||
produce nip ;
|
||||
|
||||
: mailbox-get-all ( mailbox -- array )
|
||||
f mailbox-get-all-timeout ;
|
||||
|
||||
: while-mailbox-empty ( mailbox quot -- )
|
||||
[ '[ _ mailbox-empty? ] ] dip while ; inline
|
||||
|
||||
: mailbox-get-timeout? ( mailbox timeout pred -- obj )
|
||||
[ block-unless-pred ]
|
||||
[ [ drop data>> ] dip delete-node-if ]
|
||||
3bi ; inline
|
||||
|
||||
: mailbox-get? ( mailbox pred -- obj )
|
||||
f swap mailbox-get-timeout? ; inline
|
||||
|
||||
: wait-for-close-timeout ( mailbox timeout -- )
|
||||
over disposed>>
|
||||
[ 2drop ] [ 2dup wait-for-mailbox wait-for-close-timeout ] if ;
|
||||
|
||||
: wait-for-close ( mailbox -- )
|
||||
f wait-for-close-timeout ;
|
||||
|
||||
TUPLE: linked-error error thread ;
|
||||
|
||||
M: linked-error error.
|
||||
[ thread>> error-in-thread. ] [ error>> error. ] bi ;
|
||||
|
||||
C: <linked-error> linked-error
|
||||
|
||||
: ?linked ( message -- message )
|
||||
dup linked-error? [ rethrow ] when ;
|
||||
|
||||
TUPLE: linked-thread < thread supervisor ;
|
||||
|
||||
M: linked-thread error-in-thread
|
||||
[ <linked-error> ] [ supervisor>> ] bi mailbox-put ;
|
||||
|
||||
: <linked-thread> ( quot name mailbox -- thread' )
|
||||
[ linked-thread new-thread ] dip >>supervisor ;
|
||||
|
||||
: spawn-linked-to ( quot name mailbox -- thread )
|
||||
<linked-thread> [ (spawn) ] keep ;
|
||||
|
|
|
|||
|
|
@ -1,27 +1,27 @@
|
|||
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors concurrency.mailboxes kernel continuations ;
|
||||
IN: concurrency.promises
|
||||
|
||||
TUPLE: promise mailbox ;
|
||||
|
||||
: <promise> ( -- promise )
|
||||
<mailbox> promise boa ;
|
||||
|
||||
: promise-fulfilled? ( promise -- ? )
|
||||
mailbox>> mailbox-empty? not ;
|
||||
|
||||
ERROR: promise-already-fulfilled promise ;
|
||||
|
||||
: fulfill ( value promise -- )
|
||||
dup promise-fulfilled? [
|
||||
promise-already-fulfilled
|
||||
] [
|
||||
mailbox>> mailbox-put
|
||||
] if ;
|
||||
|
||||
: ?promise-timeout ( promise timeout -- result )
|
||||
[ mailbox>> ] dip block-if-empty mailbox-peek ;
|
||||
|
||||
: ?promise ( promise -- result )
|
||||
f ?promise-timeout ;
|
||||
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors concurrency.mailboxes kernel continuations ;
|
||||
IN: concurrency.promises
|
||||
|
||||
TUPLE: promise mailbox ;
|
||||
|
||||
: <promise> ( -- promise )
|
||||
<mailbox> promise boa ;
|
||||
|
||||
: promise-fulfilled? ( promise -- ? )
|
||||
mailbox>> mailbox-empty? not ;
|
||||
|
||||
ERROR: promise-already-fulfilled promise ;
|
||||
|
||||
: fulfill ( value promise -- )
|
||||
dup promise-fulfilled? [
|
||||
promise-already-fulfilled
|
||||
] [
|
||||
mailbox>> mailbox-put
|
||||
] if ;
|
||||
|
||||
: ?promise-timeout ( promise timeout -- result )
|
||||
[ mailbox>> ] dip block-if-empty mailbox-peek ;
|
||||
|
||||
: ?promise ( promise -- result )
|
||||
f ?promise-timeout ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue