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

Updating contrib/concurrency/ for latest changes (lightly tested)

darcs
slava 2006-06-15 05:36:23 +00:00
parent 511abd6a15
commit 7725d92f26
3 changed files with 31 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
contrib/concurrency/concurrency-examples.factor
View File

@ -23,8 +23,9 @@
! !
! Examples of using the concurrency library. ! Examples of using the concurrency library.
IN: concurrency-examples IN: concurrency-examples
USING: concurrency dlists errors gadgets-theme gadgets-panes io kernel lists USING: concurrency dlists errors gadgets gadgets-labels
math math-contrib namespaces opengl prettyprint sequences threads ; gadgets-panes gadgets-theme io kernel math namespaces opengl
prettyprint sequences threads ;
: (logger) ( mailbox -- ) : (logger) ( mailbox -- )
#! Using the given mailbox, start a thread which #! Using the given mailbox, start a thread which
@ -34,10 +35,10 @@ math math-contrib namespaces opengl prettyprint sequences threads ;
: logger ( -- mailbox ) : logger ( -- mailbox )
#! Start a logging thread, which will log messages to the #! Start a logging thread, which will log messages to the
#! console that are put in the returned mailbox. #! console that are put in the returned mailbox.
make-mailbox dup [ (logger) ] cons in-thread ; make-mailbox dup [ (logger) ] curry in-thread ;
: (pong-server0) ( -- ) : (pong-server0) ( -- )
receive uncons "ping" = [ receive second "ping" = [
"pong" swap send (pong-server0) "pong" swap send (pong-server0)
] [ ] [
"Pong server shutting down" swap send "Pong server shutting down" swap send
@ -146,28 +147,23 @@ M: crash-command run-rpc-command ( command -- shutdown? result )
: test-add ( process -- ) : test-add ( process -- )
[ [
"add" [ 1 2 3 ] <rpc-command> swap send-synchronous . "add" [ 1 2 3 ] <rpc-command> swap send-synchronous .
] cons spawn drop ; ] curry spawn drop ;
: test-crash ( process -- ) : test-crash ( process -- )
[ [
"crash" f <rpc-command> swap send-synchronous . "crash" f <rpc-command> swap send-synchronous .
] cons spawn drop ; ] curry spawn drop ;
! ****************************** ! ******************************
! Experimental code below ! Experimental code below
! ****************************** ! ******************************
USE: gadgets
USE: gadgets-labels
USE: gadgets-presentations
USE: gadgets-layouts
USE: generic
TUPLE: promised-label promise font color ; TUPLE: promised-label promise font color ;
C: promised-label ( promise -- promised-label ) C: promised-label ( promise -- promised-label )
dup delegate>gadget dup label-theme dup delegate>gadget dup label-theme
[ set-promised-label-promise ] keep [ set-promised-label-promise ] keep
[ [ dup promised-label-promise ?promise drop relayout ] cons spawn drop ] keep ; [ [ dup promised-label-promise ?promise drop relayout ] curry spawn drop ] keep ;
: promised-label-text ( promised-label -- text ) : promised-label-text ( promised-label -- text )
promised-label-promise dup promise-fulfilled? [ promised-label-promise dup promise-fulfilled? [
@ -196,4 +192,4 @@ M: promised-label set-label-font set-promised-label-font ;
1 sleep dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; 1 sleep dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ;
: test-promise-ui ( -- ) : test-promise-ui ( -- )
<promise> dup <promised-label> gadget. [ 15 fib unparse swap fulfill ] cons spawn drop ; <promise> dup <promised-label> gadget. [ 15 fib unparse swap fulfill ] curry spawn drop ;

29
contrib/concurrency/concurrency-tests.factor
View File

@ -23,8 +23,7 @@
! !
IN: concurrency IN: concurrency
USING: kernel concurrency concurrency-examples threads vectors USING: kernel concurrency concurrency-examples threads vectors
sequences lists namespaces test errors dlists strings sequences namespaces test errors dlists strings math words ;
math words ;
[ "junk" ] [ [ "junk" ] [
<dlist> <dlist>
@ -81,9 +80,9 @@ USING: kernel concurrency concurrency-examples threads vectors
[ V{ 1 2 3 } ] [ [ V{ 1 2 3 } ] [
0 <vector> 0 <vector>
make-mailbox make-mailbox
2dup [ mailbox-get swap push ] cons cons in-thread 2dup [ mailbox-get swap push ] curry curry in-thread
2dup [ mailbox-get swap push ] cons cons in-thread 2dup [ mailbox-get swap push ] curry curry in-thread
2dup [ mailbox-get swap push ] cons cons in-thread 2dup [ mailbox-get swap push ] curry curry 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
@ -92,9 +91,9 @@ USING: kernel concurrency concurrency-examples threads vectors
[ V{ 1 2 3 } ] [ [ V{ 1 2 3 } ] [
0 <vector> 0 <vector>
make-mailbox make-mailbox
2dup [ [ integer? ] swap mailbox-get? swap push ] cons cons in-thread 2dup [ [ integer? ] swap mailbox-get? swap push ] curry curry in-thread
2dup [ [ integer? ] swap mailbox-get? swap push ] cons cons in-thread 2dup [ [ integer? ] swap mailbox-get? swap push ] curry curry in-thread
2dup [ [ integer? ] swap mailbox-get? swap push ] cons cons in-thread 2dup [ [ integer? ] swap mailbox-get? swap push ] curry curry 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
@ -103,10 +102,10 @@ USING: kernel concurrency concurrency-examples threads vectors
[ V{ 1 "junk" 3 "junk2" } [ 456 ] ] [ [ V{ 1 "junk" 3 "junk2" } [ 456 ] ] [
0 <vector> 0 <vector>
make-mailbox make-mailbox
2dup [ [ integer? ] swap mailbox-get? swap push ] cons cons in-thread 2dup [ [ integer? ] swap mailbox-get? swap push ] curry curry in-thread
2dup [ [ integer? ] swap mailbox-get? swap push ] cons cons in-thread 2dup [ [ integer? ] swap mailbox-get? swap push ] curry curry in-thread
2dup [ [ string? ] swap mailbox-get? swap push ] cons cons in-thread 2dup [ [ string? ] swap mailbox-get? swap push ] curry curry in-thread
2dup [ [ string? ] swap mailbox-get? swap push ] cons cons in-thread 2dup [ [ string? ] swap mailbox-get? swap push ] curry curry 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
@ -174,8 +173,8 @@ USING: kernel concurrency concurrency-examples threads vectors
[ V{ 50 50 50 } ] [ [ V{ 50 50 50 } ] [
0 <vector> 0 <vector>
<promise> <promise>
2dup [ ?promise swap push ] cons cons spawn drop 2dup [ ?promise swap push ] curry curry spawn drop
2dup [ ?promise swap push ] cons cons spawn drop 2dup [ ?promise swap push ] curry curry spawn drop
2dup [ ?promise swap push ] cons cons spawn drop 2dup [ ?promise swap push ] curry curry spawn drop
50 swap fulfill 50 swap fulfill
] unit-test ] unit-test

20
contrib/concurrency/concurrency.factor
View File

@ -23,7 +23,7 @@
! !
! Concurrency library for Factor based on Erlang/Termite style ! Concurrency library for Factor based on Erlang/Termite style
! concurrency. ! concurrency.
USING: kernel lists generic threads io namespaces errors words USING: kernel generic threads io namespaces errors words
math sequences hashtables strings vectors dlists ; math sequences hashtables strings vectors dlists ;
IN: concurrency IN: concurrency
@ -224,7 +224,7 @@ TUPLE: linked-exception error ;
#! Same as spawn but if the quotation throws an error that #! Same as spawn but if the quotation throws an error that
#! is uncaught, that error gets propogated to the process #! is uncaught, that error gets propogated to the process
#! performing the spawn-link. #! performing the spawn-link.
[ catch [ rethrow-linked ] when* ] cons [ catch [ rethrow-linked ] when* ] curry
[ in-thread ] self make-linked-process [ with-process ] over slip ; [ in-thread ] self make-linked-process [ with-process ] over slip ;
#! A common operation is to send a message to a process containing #! A common operation is to send a message to a process containing
@ -248,11 +248,7 @@ TUPLE: tagged-message data from tag ;
#! 'match-quot' is a quotation with stack effect ( msg -- ). It #! 'match-quot' is a quotation with stack effect ( msg -- ). It
#! will be called with the message on the top of the stack if #! will be called with the message on the top of the stack if
#! the 'pred' word returned true. #! the 'pred' word returned true.
uncons >r dupd execute [ [ first execute ] 2keep rot [ second call ] [ 2drop ] if ;
r> car call
] [
r> 2drop
] if ;
: recv ( forms -- ) : recv ( forms -- )
#! Get a message from the processes mailbox. Compare it against the #! Get a message from the processes mailbox. Compare it against the
@ -289,7 +285,7 @@ TUPLE: tagged-message data from tag ;
#! is matched up with the request by generating a message tag #! is matched up with the request by generating a message tag
#! which should be sent back with the reply. #! which should be sent back with the reply.
>r tag-message [ tagged-message-tag ] keep r> send >r tag-message [ tagged-message-tag ] keep r> send
unit [ car tag-match? ] cons receive-if tagged-message-data ; unit [ first tag-match? ] curry receive-if tagged-message-data ;
: reply ( tagged-message message -- ) : reply ( tagged-message message -- )
#! Replies to the tagged-message which should have been a result of a #! Replies to the tagged-message which should have been a result of a
@ -321,7 +317,7 @@ SYMBOL: quit-cc
[ [
(spawn-server) (spawn-server)
"Exiting process: " write self process-pid print "Exiting process: " write self process-pid print
] cons spawn ; ] curry spawn ;
: spawn-linked-server ( quot -- process ) : spawn-linked-server ( quot -- process )
#! Similar to 'spawn-server' but the parent process will be linked #! Similar to 'spawn-server' but the parent process will be linked
@ -329,7 +325,7 @@ SYMBOL: quit-cc
[ [
(spawn-server) (spawn-server)
"Exiting process: " write self process-pid print "Exiting process: " write self process-pid print
] cons spawn-link ; ] curry spawn-link ;
: send-reply ( message pred quot -- ) : send-reply ( message pred quot -- )
#! The intent of this word is to provde an easy way to #! The intent of this word is to provde an easy way to
@ -392,7 +388,7 @@ SYMBOL: quit-cc
#! ?future. If the quotation has completed the result will be returned. #! ?future. If the quotation has completed the result will be returned.
#! If not, the process will block until the quotation completes. #! If not, the process will block until the quotation completes.
#! 'quot' must have stack effect ( -- X ). #! 'quot' must have stack effect ( -- X ).
[ call self send ] cons spawn ; [ self send ] append spawn ;
: ?future ( future -- result ) : ?future ( future -- result )
#! Block the process until the future has completed and then place the #! Block the process until the future has completed and then place the
@ -443,7 +439,7 @@ SYMBOL: lazy-quot
[ tagged-message? [ [ drop t ] [ get call ] send-reply ] ] [ tagged-message? [ [ drop t ] [ get call ] send-reply ] ]
] recv ] recv
] with-scope ] with-scope
] cons spawn ; ] curry spawn ;
: ?lazy ( lazy -- result ) : ?lazy ( lazy -- result )
#! Given a process spawned using 'lazy', evaluate it and return the result. #! Given a process spawned using 'lazy', evaluate it and return the result.