237 lines
7.3 KiB
Factor
237 lines
7.3 KiB
Factor
! Copyright (C) 2005 Chris Double. All Rights Reserved.
|
|
!
|
|
! Redistribution and use in source and binary forms, with or without
|
|
! modification, are permitted provided that the following conditions are met:
|
|
!
|
|
! 1. Redistributions of source code must retain the above copyright notice,
|
|
! this list of conditions and the following disclaimer.
|
|
!
|
|
! 2. Redistributions in binary form must reproduce the above copyright notice,
|
|
! this list of conditions and the following disclaimer in the documentation
|
|
! and/or other materials provided with the distribution.
|
|
!
|
|
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
|
|
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
|
|
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
|
|
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
|
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
|
|
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
|
|
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
|
|
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
|
|
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
|
|
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
|
!
|
|
! Examples of using the concurrency library.
|
|
IN: concurrency-examples
|
|
USING: concurrency kernel io lists threads math sequences namespaces unparser prettyprint errors ;
|
|
|
|
: (logger) ( mailbox -- )
|
|
#! Using the given mailbox, start a thread which
|
|
#! logs messages put into the box.
|
|
dup mailbox-get print (logger) ;
|
|
|
|
: logger ( -- mailbox )
|
|
#! Start a logging thread, which will log messages to the
|
|
#! console that are put in the returned mailbox.
|
|
make-mailbox dup [ (logger) ] cons in-thread ;
|
|
|
|
: pong-server ( -- server )
|
|
#! A server that responds to a 'ping' message
|
|
#! by sending a 'pong' message to the caller.
|
|
[
|
|
[
|
|
[ message? [ [ "ping" = ] [ drop "pong" ] send-reply ] ]
|
|
[ message? [ [ "shutdown" = ] [ drop "shutdown" ] send-reply ] ]
|
|
[ message? [ message-data "shutdown" = [ exit-server ] when ] ]
|
|
] recv
|
|
] spawn-server ;
|
|
|
|
: rpc-server ( -- server )
|
|
#! Process RPC requests where the message data
|
|
#! is a list. The first item of the list is the function
|
|
#! to execute. The remainder of the list are the arguments
|
|
#! to that function.
|
|
[
|
|
[
|
|
[ message? [ [ car "add" = ] [ cdr 0 [ + ] reduce ] send-reply ] ]
|
|
[ message? [ [ car "product" = ] [ cdr 1 [ * ] reduce ] send-reply ] ]
|
|
[ message? [ [ car "shutdown" = ] [ drop "shutdown" ] send-reply ] ]
|
|
[ message? [ message-data car "shutdown" = [ exit-server ] when ] ]
|
|
] recv
|
|
] spawn-server ;
|
|
|
|
: original ( -- server )
|
|
#! A server that responds to a clone request. This will
|
|
#! send back to the caller a continuation that when called
|
|
#! will effectively be a clone of the original server.
|
|
[
|
|
"original waiting for message: " write self get process-pid print
|
|
[
|
|
[ message? [ [ "clone" = ] [ drop server-cc ] maybe-send-reply ] ]
|
|
[ message? [ [ "shutdown" = ] [ drop "shutdown" ] send-reply ] ]
|
|
[ message? [ message-data "shutdown" = [ exit-server ] when ] ]
|
|
] recv
|
|
] spawn-server ;
|
|
|
|
: do-clone ( process -- )
|
|
#! Given a server that responder to the 'clone' message, request
|
|
#! a clone and execute it.
|
|
[ "clone" swap send-message call-server-cc ] cons spawn ;
|
|
|
|
TUPLE: update k ;
|
|
|
|
: old-server ( -- server )
|
|
[
|
|
"old-server waiting for message: " write self get process-pid print
|
|
[
|
|
[ message? [ [ "clone" = ] [ drop server-cc ] maybe-send-reply ] ]
|
|
[ message? [ [ "ping" = ] [ drop "gnop" ] send-reply ] ]
|
|
[ update? [ update-k call-server-cc ] ]
|
|
] recv
|
|
] spawn-server ;
|
|
|
|
: new-server ( -- server )
|
|
[
|
|
"new-server waiting for message: " write self get process-pid unparse print
|
|
[
|
|
[ message? [ [ "clone" = ] [ drop server-cc ] maybe-send-reply ] ]
|
|
[ message? [ [ "ping" = ] [ drop "pong" ] send-reply ] ]
|
|
[ update? [ update-k call-server-cc ] ]
|
|
] recv
|
|
] spawn-server ;
|
|
|
|
|
|
: test-server-replacement ( -- )
|
|
old-server
|
|
"Old Server is: " write dup process-pid print
|
|
"Old Server result from ping is: " write "ping" over send-message .
|
|
new-server
|
|
"New Server is: " write dup process-pid print
|
|
"New Server result from ping is: " write "ping" over send-message .
|
|
"Old Server result from ping is: " write "ping" pick send-message .
|
|
"Sending code update to old server..." print
|
|
"clone" over send-message <update> pick send
|
|
"Old Server is: " write dup process-pid print
|
|
"Old Server result from ping is: " write "ping" pick send-message .
|
|
2drop ;
|
|
|
|
! ***********************************
|
|
! Ignore code below...for testing
|
|
! ***********************************
|
|
: start-pong-server ( -- )
|
|
[
|
|
[
|
|
[ message? [ [ "crash" = ] [ drop 1 0 / ] send-reply ] ]
|
|
[ message? [ [ "ping" = ] [ drop "pong" ] send-reply ] ]
|
|
] recv
|
|
] forever ;
|
|
|
|
: fragile-server ( -- server)
|
|
[ start-pong-server ] spawn ;
|
|
|
|
SYMBOL: worker
|
|
|
|
: robust-server ( -- server )
|
|
[
|
|
[
|
|
[
|
|
[ start-pong-server ] spawn-link worker set
|
|
[
|
|
receive dup message? [
|
|
worker get !
|
|
] [
|
|
drop
|
|
] ifte
|
|
] forever
|
|
]
|
|
[
|
|
[
|
|
"Worker crashed, restarting: " write print
|
|
] when*
|
|
]
|
|
catch
|
|
] forever
|
|
] spawn ;
|
|
|
|
SYMBOL: set-next
|
|
|
|
: ring-process ( next -- server )
|
|
#! A process that can receive a single message,
|
|
#! an integer number. That number is decremented then
|
|
#! sent to the 'next' process. If the number is 0 it is
|
|
#! relayed to the next process and this process exits.
|
|
[
|
|
[
|
|
quit-cc set
|
|
[
|
|
receive dup process? [
|
|
"Setting next for " write self get process-pid print
|
|
nip
|
|
] [
|
|
dup 0 = [ ( next 0 -- )
|
|
"0 received for " write self get process-pid print
|
|
swap [ send ] when*
|
|
quit-cc get call
|
|
] [
|
|
dup unparse write " received for " write self get process-pid print
|
|
1 - over [ send ] when*
|
|
] ifte
|
|
] ifte
|
|
] forever
|
|
] callcc0
|
|
"Exiting process " write self get process-pid print
|
|
] cons spawn ;
|
|
|
|
: create-ring ( n -- process )
|
|
#! Create a ring of n processes, returning one
|
|
f ring-process dup rot 1 -
|
|
[
|
|
ring-process
|
|
] times over send ;
|
|
|
|
: fib ( n -- )
|
|
yield
|
|
dup 2 < [
|
|
|
|
] [
|
|
dup 1 - >r 2 - fib r> fib +
|
|
] ifte ;
|
|
|
|
TUPLE: fib-message number ;
|
|
|
|
: fib-server ( -- server )
|
|
[
|
|
"fib-server waiting for message: " write self get process-pid unparse print
|
|
[
|
|
[ message? [ [ fib-message? ] [ fib-message-number fib ] send-reply ] ]
|
|
] recv
|
|
] spawn-server ;
|
|
|
|
: t1
|
|
f ring-process dup ring-process over send ;
|
|
|
|
: abcd
|
|
[
|
|
"here" print
|
|
receive
|
|
"there" print
|
|
drop quit-cc call
|
|
] spawn-server ;
|
|
|
|
: pong-server1 ( -- process)
|
|
[
|
|
receive uncons "ping" = [
|
|
"pong" swap send
|
|
] [
|
|
"Pong server shutdown commenced" swap send
|
|
exit-server
|
|
] ifte
|
|
] spawn-server ;
|
|
|
|
: pong-server2 ( -- process)
|
|
[
|
|
receive
|
|
dup [ "ping" = ] [ drop "pong" ] send-reply
|
|
dup [ "shutdown" = ] [ drop "Pong server shutdown commenced" ] send-reply
|
|
message-data "shutdown" = [ exit-server ] when
|
|
] spawn-server ; |