steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge up

db4
Erik Charlebois 2010-02-20 00:24:37 -08:00
parent 430ace7b7b
commit 30b586ef5f
3 changed files with 175 additions and 175 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

108
basis/concurrency/mailboxes/mailboxes-tests.factor
View File

@ -1,54 +1,54 @@
USING: concurrency.mailboxes concurrency.count-downs concurrency.conditions USING: concurrency.mailboxes concurrency.count-downs concurrency.conditions
vectors sequences threads tools.test math kernel strings namespaces vectors sequences threads tools.test math kernel strings namespaces
continuations calendar destructors ; continuations calendar destructors ;
IN: concurrency.mailboxes.tests IN: concurrency.mailboxes.tests
{ 1 1 } [ [ integer? ] mailbox-get? ] must-infer-as { 1 1 } [ [ integer? ] mailbox-get? ] must-infer-as
[ V{ 1 2 3 } ] [ [ V{ 1 2 3 } ] [
0 <vector> 0 <vector>
<mailbox> <mailbox>
[ mailbox-get swap push ] in-thread [ mailbox-get swap push ] in-thread
[ mailbox-get swap push ] in-thread [ mailbox-get swap push ] in-thread
[ mailbox-get swap push ] in-thread [ mailbox-get swap push ] in-thread
1 over mailbox-put 1 over mailbox-put
2 over mailbox-put 2 over mailbox-put
3 swap mailbox-put 3 swap mailbox-put
] unit-test ] unit-test
[ V{ 1 2 3 } ] [ [ V{ 1 2 3 } ] [
0 <vector> 0 <vector>
<mailbox> <mailbox>
[ [ integer? ] mailbox-get? swap push ] in-thread [ [ integer? ] mailbox-get? swap push ] in-thread
[ [ integer? ] mailbox-get? swap push ] in-thread [ [ 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 1 over mailbox-put
2 over mailbox-put 2 over mailbox-put
3 swap mailbox-put 3 swap mailbox-put
] unit-test ] unit-test
[ V{ 1 "junk" 3 "junk2" } [ 456 ] ] [ [ V{ 1 "junk" 3 "junk2" } [ 456 ] ] [
0 <vector> 0 <vector>
<mailbox> <mailbox>
[ [ integer? ] mailbox-get? swap push ] in-thread [ [ integer? ] mailbox-get? swap push ] in-thread
[ [ 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
[ [ string? ] mailbox-get? swap push ] in-thread [ [ string? ] mailbox-get? swap push ] in-thread
1 over mailbox-put 1 over mailbox-put
"junk" over mailbox-put "junk" over mailbox-put
[ 456 ] over mailbox-put [ 456 ] over mailbox-put
3 over mailbox-put 3 over mailbox-put
"junk2" over mailbox-put "junk2" over mailbox-put
mailbox-get mailbox-get
] unit-test ] unit-test
[ { "foo" "bar" } ] [ [ { "foo" "bar" } ] [
<mailbox> <mailbox>
"foo" over mailbox-put "foo" over mailbox-put
"bar" over mailbox-put "bar" over mailbox-put
mailbox-get-all mailbox-get-all
] unit-test ] unit-test
[ [
<mailbox> 1 seconds mailbox-get-timeout <mailbox> 1 seconds mailbox-get-timeout
] [ wait-timeout? ] must-fail-with ] [ wait-timeout? ] must-fail-with

188
basis/concurrency/mailboxes/mailboxes.factor
View File

@ -1,94 +1,94 @@
! Copyright (C) 2005, 2010 Chris Double, Slava Pestov. ! Copyright (C) 2005, 2010 Chris Double, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: dlists deques threads sequences continuations namespaces USING: dlists deques threads sequences continuations namespaces
math quotations words kernel arrays assocs init system math quotations words kernel arrays assocs init system
concurrency.conditions accessors debugger debugger.threads concurrency.conditions accessors debugger debugger.threads
locals fry ; locals fry ;
IN: concurrency.mailboxes IN: concurrency.mailboxes
TUPLE: mailbox threads data ; TUPLE: mailbox threads data ;
: <mailbox> ( -- mailbox ) : <mailbox> ( -- mailbox )
mailbox new mailbox new
<dlist> >>threads <dlist> >>threads
<dlist> >>data ; <dlist> >>data ;
: mailbox-empty? ( mailbox -- bool ) : mailbox-empty? ( mailbox -- bool )
data>> deque-empty? ; data>> deque-empty? ;
: mailbox-put ( obj mailbox -- ) : mailbox-put ( obj mailbox -- )
[ data>> push-front ] [ data>> push-front ]
[ threads>> notify-all ] bi yield ; [ threads>> notify-all ] bi yield ;
: wait-for-mailbox ( mailbox timeout -- ) : wait-for-mailbox ( mailbox timeout -- )
[ threads>> ] dip "mailbox" wait ; [ threads>> ] dip "mailbox" wait ;
:: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- ) :: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- )
mailbox data>> pred dlist-any? [ mailbox data>> pred dlist-any? [
mailbox timeout wait-for-mailbox mailbox timeout wait-for-mailbox
mailbox timeout pred block-unless-pred mailbox timeout pred block-unless-pred
] unless ; inline recursive ] unless ; inline recursive
: block-if-empty ( mailbox timeout -- mailbox ) : block-if-empty ( mailbox timeout -- mailbox )
over mailbox-empty? [ over mailbox-empty? [
2dup wait-for-mailbox block-if-empty 2dup wait-for-mailbox block-if-empty
] [ ] [
drop drop
] if ; ] if ;
: mailbox-peek ( mailbox -- obj ) : mailbox-peek ( mailbox -- obj )
data>> peek-back ; data>> peek-back ;
: mailbox-get-timeout ( mailbox timeout -- obj ) : mailbox-get-timeout ( mailbox timeout -- obj )
block-if-empty data>> pop-back ; block-if-empty data>> pop-back ;
: mailbox-get ( mailbox -- obj ) : mailbox-get ( mailbox -- obj )
f mailbox-get-timeout ; f mailbox-get-timeout ;
: mailbox-get-all-timeout ( mailbox timeout -- array ) : mailbox-get-all-timeout ( mailbox timeout -- array )
block-if-empty block-if-empty
[ dup mailbox-empty? not ] [ dup mailbox-empty? not ]
[ dup data>> pop-back ] [ dup data>> pop-back ]
produce nip ; produce nip ;
: mailbox-get-all ( mailbox -- array ) : mailbox-get-all ( mailbox -- array )
f mailbox-get-all-timeout ; f mailbox-get-all-timeout ;
: while-mailbox-empty ( mailbox quot -- ) : while-mailbox-empty ( mailbox quot -- )
[ '[ _ mailbox-empty? ] ] dip while ; inline [ '[ _ mailbox-empty? ] ] dip while ; inline
: mailbox-get-timeout? ( mailbox timeout pred -- obj ) : mailbox-get-timeout? ( mailbox timeout pred -- obj )
[ block-unless-pred ] [ block-unless-pred ]
[ [ drop data>> ] dip delete-node-if ] [ [ drop data>> ] dip delete-node-if ]
3bi ; inline 3bi ; inline
: mailbox-get? ( mailbox pred -- obj ) : mailbox-get? ( mailbox pred -- obj )
f swap mailbox-get-timeout? ; inline f swap mailbox-get-timeout? ; inline
: wait-for-close-timeout ( mailbox timeout -- ) : wait-for-close-timeout ( mailbox timeout -- )
over disposed>> over disposed>>
[ 2drop ] [ 2dup wait-for-mailbox wait-for-close-timeout ] if ; [ 2drop ] [ 2dup wait-for-mailbox wait-for-close-timeout ] if ;
: wait-for-close ( mailbox -- ) : wait-for-close ( mailbox -- )
f wait-for-close-timeout ; f wait-for-close-timeout ;
TUPLE: linked-error error thread ; TUPLE: linked-error error thread ;
M: linked-error error. M: linked-error error.
[ thread>> error-in-thread. ] [ error>> error. ] bi ; [ thread>> error-in-thread. ] [ error>> error. ] bi ;
C: <linked-error> linked-error C: <linked-error> linked-error
: ?linked ( message -- message ) : ?linked ( message -- message )
dup linked-error? [ rethrow ] when ; dup linked-error? [ rethrow ] when ;
TUPLE: linked-thread < thread supervisor ; TUPLE: linked-thread < thread supervisor ;
M: linked-thread error-in-thread M: linked-thread error-in-thread
[ <linked-error> ] [ supervisor>> ] bi mailbox-put ; [ <linked-error> ] [ supervisor>> ] bi mailbox-put ;
: <linked-thread> ( quot name mailbox -- thread' ) : <linked-thread> ( quot name mailbox -- thread' )
[ linked-thread new-thread ] dip >>supervisor ; [ linked-thread new-thread ] dip >>supervisor ;
: spawn-linked-to ( quot name mailbox -- thread ) : spawn-linked-to ( quot name mailbox -- thread )
<linked-thread> [ (spawn) ] keep ; <linked-thread> [ (spawn) ] keep ;

54
basis/concurrency/promises/promises.factor
View File

@ -1,27 +1,27 @@
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. ! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors concurrency.mailboxes kernel continuations ; USING: accessors concurrency.mailboxes kernel continuations ;
IN: concurrency.promises IN: concurrency.promises
TUPLE: promise mailbox ; TUPLE: promise mailbox ;
: <promise> ( -- promise ) : <promise> ( -- promise )
<mailbox> promise boa ; <mailbox> promise boa ;
: promise-fulfilled? ( promise -- ? ) : promise-fulfilled? ( promise -- ? )
mailbox>> mailbox-empty? not ; mailbox>> mailbox-empty? not ;
ERROR: promise-already-fulfilled promise ; ERROR: promise-already-fulfilled promise ;
: fulfill ( value promise -- ) : fulfill ( value promise -- )
dup promise-fulfilled? [ dup promise-fulfilled? [
promise-already-fulfilled promise-already-fulfilled
] [ ] [
mailbox>> mailbox-put mailbox>> mailbox-put
] if ; ] if ;
: ?promise-timeout ( promise timeout -- result ) : ?promise-timeout ( promise timeout -- result )
[ mailbox>> ] dip block-if-empty mailbox-peek ; [ mailbox>> ] dip block-if-empty mailbox-peek ;
: ?promise ( promise -- result ) : ?promise ( promise -- result )
f ?promise-timeout ; f ?promise-timeout ;