From 7725d92f26f93f63e5791e9560e5461fecc92aac Mon Sep 17 00:00:00 2001 From: slava Date: Thu, 15 Jun 2006 05:36:23 +0000 Subject: [PATCH] Updating contrib/concurrency/ for latest changes (lightly tested) --- .../concurrency/concurrency-examples.factor | 22 ++++++-------- contrib/concurrency/concurrency-tests.factor | 29 +++++++++---------- contrib/concurrency/concurrency.factor | 20 +++++-------- 3 files changed, 31 insertions(+), 40 deletions(-) diff --git a/contrib/concurrency/concurrency-examples.factor b/contrib/concurrency/concurrency-examples.factor index b1d9d76262..cdffba9cc7 100644 --- a/contrib/concurrency/concurrency-examples.factor +++ b/contrib/concurrency/concurrency-examples.factor @@ -23,8 +23,9 @@ ! ! Examples of using the concurrency library. IN: concurrency-examples -USING: concurrency dlists errors gadgets-theme gadgets-panes io kernel lists -math math-contrib namespaces opengl prettyprint sequences threads ; +USING: concurrency dlists errors gadgets gadgets-labels +gadgets-panes gadgets-theme io kernel math namespaces opengl +prettyprint sequences threads ; : (logger) ( mailbox -- ) #! Using the given mailbox, start a thread which @@ -34,10 +35,10 @@ math math-contrib namespaces opengl prettyprint sequences threads ; : 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 ; + make-mailbox dup [ (logger) ] curry in-thread ; : (pong-server0) ( -- ) - receive uncons "ping" = [ + receive second "ping" = [ "pong" swap send (pong-server0) ] [ "Pong server shutting down" swap send @@ -146,28 +147,23 @@ M: crash-command run-rpc-command ( command -- shutdown? result ) : test-add ( process -- ) [ "add" [ 1 2 3 ] swap send-synchronous . - ] cons spawn drop ; + ] curry spawn drop ; : test-crash ( process -- ) [ "crash" f swap send-synchronous . - ] cons spawn drop ; + ] curry spawn drop ; ! ****************************** ! Experimental code below ! ****************************** -USE: gadgets -USE: gadgets-labels -USE: gadgets-presentations -USE: gadgets-layouts -USE: generic TUPLE: promised-label promise font color ; C: promised-label ( promise -- promised-label ) dup delegate>gadget dup label-theme [ 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-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 ; : test-promise-ui ( -- ) - dup gadget. [ 15 fib unparse swap fulfill ] cons spawn drop ; + dup gadget. [ 15 fib unparse swap fulfill ] curry spawn drop ; diff --git a/contrib/concurrency/concurrency-tests.factor b/contrib/concurrency/concurrency-tests.factor index 1aff65e4b9..099cdac4d5 100644 --- a/contrib/concurrency/concurrency-tests.factor +++ b/contrib/concurrency/concurrency-tests.factor @@ -23,8 +23,7 @@ ! IN: concurrency USING: kernel concurrency concurrency-examples threads vectors - sequences lists namespaces test errors dlists strings - math words ; + sequences namespaces test errors dlists strings math words ; [ "junk" ] [ @@ -81,9 +80,9 @@ USING: kernel concurrency concurrency-examples threads vectors [ V{ 1 2 3 } ] [ 0 make-mailbox - 2dup [ mailbox-get swap push ] cons cons in-thread - 2dup [ mailbox-get swap push ] cons cons 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 ] curry curry in-thread + 2dup [ mailbox-get swap push ] curry curry in-thread 1 over mailbox-put 2 over mailbox-put 3 swap mailbox-put @@ -92,9 +91,9 @@ USING: kernel concurrency concurrency-examples threads vectors [ V{ 1 2 3 } ] [ 0 make-mailbox - 2dup [ [ integer? ] swap mailbox-get? swap push ] cons cons in-thread - 2dup [ [ integer? ] swap mailbox-get? swap push ] cons cons 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 ] curry curry in-thread + 2dup [ [ integer? ] swap mailbox-get? swap push ] curry curry in-thread 1 over mailbox-put 2 over mailbox-put 3 swap mailbox-put @@ -103,10 +102,10 @@ USING: kernel concurrency concurrency-examples threads vectors [ V{ 1 "junk" 3 "junk2" } [ 456 ] ] [ 0 make-mailbox - 2dup [ [ integer? ] swap mailbox-get? swap push ] cons cons in-thread - 2dup [ [ integer? ] swap mailbox-get? swap push ] cons cons in-thread - 2dup [ [ string? ] swap mailbox-get? swap push ] cons cons in-thread - 2dup [ [ string? ] 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 ] curry curry in-thread + 2dup [ [ string? ] swap mailbox-get? swap push ] curry curry in-thread + 2dup [ [ string? ] swap mailbox-get? swap push ] curry curry in-thread 1 over mailbox-put "junk" over mailbox-put [ 456 ] over mailbox-put @@ -174,8 +173,8 @@ USING: kernel concurrency concurrency-examples threads vectors [ V{ 50 50 50 } ] [ 0 - 2dup [ ?promise swap push ] cons cons spawn drop - 2dup [ ?promise swap push ] cons cons spawn drop - 2dup [ ?promise swap push ] cons cons spawn drop + 2dup [ ?promise swap push ] curry curry spawn drop + 2dup [ ?promise swap push ] curry curry spawn drop + 2dup [ ?promise swap push ] curry curry spawn drop 50 swap fulfill ] unit-test diff --git a/contrib/concurrency/concurrency.factor b/contrib/concurrency/concurrency.factor index 5315d4713a..e2a227991f 100644 --- a/contrib/concurrency/concurrency.factor +++ b/contrib/concurrency/concurrency.factor @@ -23,7 +23,7 @@ ! ! Concurrency library for Factor based on Erlang/Termite style ! concurrency. -USING: kernel lists generic threads io namespaces errors words +USING: kernel generic threads io namespaces errors words math sequences hashtables strings vectors dlists ; IN: concurrency @@ -224,7 +224,7 @@ TUPLE: linked-exception error ; #! Same as spawn but if the quotation throws an error that #! is uncaught, that error gets propogated to the process #! performing the spawn-link. - [ catch [ rethrow-linked ] when* ] cons + [ catch [ rethrow-linked ] when* ] curry [ in-thread ] self make-linked-process [ with-process ] over slip ; #! 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 #! will be called with the message on the top of the stack if #! the 'pred' word returned true. - uncons >r dupd execute [ - r> car call - ] [ - r> 2drop - ] if ; + [ first execute ] 2keep rot [ second call ] [ 2drop ] if ; : recv ( forms -- ) #! 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 #! which should be sent back with the reply. >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 -- ) #! Replies to the tagged-message which should have been a result of a @@ -321,7 +317,7 @@ SYMBOL: quit-cc [ (spawn-server) "Exiting process: " write self process-pid print - ] cons spawn ; + ] curry spawn ; : spawn-linked-server ( quot -- process ) #! Similar to 'spawn-server' but the parent process will be linked @@ -329,7 +325,7 @@ SYMBOL: quit-cc [ (spawn-server) "Exiting process: " write self process-pid print - ] cons spawn-link ; + ] curry spawn-link ; : send-reply ( message pred quot -- ) #! 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. #! If not, the process will block until the quotation completes. #! 'quot' must have stack effect ( -- X ). - [ call self send ] cons spawn ; + [ self send ] append spawn ; : ?future ( future -- result ) #! 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 ] ] ] recv ] with-scope - ] cons spawn ; + ] curry spawn ; : ?lazy ( lazy -- result ) #! Given a process spawned using 'lazy', evaluate it and return the result.