From 2c6afdfee603d308996a6f826e614c8ef44f7b1a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 18 Feb 2008 05:07:40 -0600 Subject: [PATCH 1/7] Working on new threads --- core/alien/compiler/compiler.factor | 6 +- .../remote-control/remote-control.factor | 4 +- core/bootstrap/image/image.factor | 2 +- core/bootstrap/stage1.factor | 1 + core/compiler/compiler.factor | 4 +- core/{ => concurrency}/threads/authors.txt | 0 core/{ => concurrency}/threads/summary.txt | 0 core/concurrency/threads/threads-docs.factor | 137 +++++++ core/concurrency/threads/threads-tests.factor | 16 + core/concurrency/threads/threads.factor | 172 ++++++++ core/continuations/continuations.factor | 7 +- core/generator/generator.factor | 2 +- core/init/init.factor | 0 core/io/backend/backend.factor | 6 +- core/io/files/files-tests.factor | 4 +- core/io/thread/thread.factor | 14 + core/namespaces/namespaces-docs.factor | 7 +- core/threads/threads-docs.factor | 69 ---- core/threads/threads-tests.factor | 12 - core/threads/threads.factor | 71 ---- extra/bootstrap/tools/tools.factor | 3 +- extra/calendar/model/model.factor | 5 +- extra/concurrency/concurrency.factor | 384 ------------------ .../distributed/distributed.factor | 52 +-- extra/concurrency/exchangers/authors.txt | 1 + .../concurrency/exchangers/exchangers.factor | 21 + extra/concurrency/exchangers/exchangers.txt | 1 + extra/concurrency/{ => futures}/authors.txt | 1 + extra/concurrency/futures/futures.factor | 25 ++ extra/concurrency/futures/summary.txt | 1 + extra/concurrency/locks/authors.txt | 1 + extra/concurrency/locks/locks.factor | 87 ++++ extra/concurrency/locks/summary.txt | 1 + extra/concurrency/messaging/authors.txt | 2 + .../messaging-docs.factor} | 0 .../messaging-tests.factor} | 0 extra/concurrency/messaging/messaging.factor | 121 ++++++ extra/concurrency/messaging/summary.txt | 1 + extra/concurrency/promises/authors.txt | 2 + extra/concurrency/promises/promises.factor | 24 ++ extra/concurrency/promises/summary.txt | 1 + extra/concurrency/semaphores/authors.txt | 1 + .../concurrency/semaphores/semaphores.factor | 20 + extra/concurrency/semaphores/summary.txt | 1 + extra/concurrency/summary.txt | 1 - extra/concurrency/tags.txt | 1 - extra/io/launcher/launcher.factor | 6 +- extra/io/monitors/monitors.factor | 6 +- extra/io/sockets/sockets-docs.factor | 2 +- extra/io/timeouts/timeouts.factor | 9 +- extra/io/unix/backend/backend.factor | 8 +- extra/io/unix/launcher/launcher.factor | 2 +- extra/io/unix/unix-tests.factor | 4 +- extra/io/windows/launcher/launcher.factor | 5 +- extra/io/windows/nt/backend/backend.factor | 15 +- extra/io/windows/nt/files/files.factor | 6 +- extra/io/windows/nt/nt.factor | 2 + extra/io/windows/nt/sockets/sockets.factor | 2 +- extra/tools/interpreter/interpreter.factor | 3 +- extra/tools/threads/threads.factor | 22 + extra/ui/tools/interactor/interactor.factor | 26 +- extra/ui/tools/listener/listener.factor | 5 +- extra/ui/tools/walker/walker.factor | 9 +- extra/ui/ui.factor | 8 +- extra/ui/windows/windows.factor | 8 +- extra/vocabs/monitor/monitor.factor | 20 +- extra/webapps/planet/planet.factor | 4 +- vm/run.h | 6 +- 68 files changed, 804 insertions(+), 666 deletions(-) mode change 100644 => 100755 core/alien/remote-control/remote-control.factor rename core/{ => concurrency}/threads/authors.txt (100%) rename core/{ => concurrency}/threads/summary.txt (100%) create mode 100755 core/concurrency/threads/threads-docs.factor create mode 100755 core/concurrency/threads/threads-tests.factor create mode 100755 core/concurrency/threads/threads.factor mode change 100644 => 100755 core/init/init.factor create mode 100755 core/io/thread/thread.factor mode change 100644 => 100755 core/namespaces/namespaces-docs.factor delete mode 100755 core/threads/threads-docs.factor delete mode 100755 core/threads/threads-tests.factor delete mode 100755 core/threads/threads.factor delete mode 100755 extra/concurrency/concurrency.factor create mode 100644 extra/concurrency/exchangers/authors.txt create mode 100755 extra/concurrency/exchangers/exchangers.factor create mode 100644 extra/concurrency/exchangers/exchangers.txt rename extra/concurrency/{ => futures}/authors.txt (50%) create mode 100755 extra/concurrency/futures/futures.factor create mode 100644 extra/concurrency/futures/summary.txt create mode 100644 extra/concurrency/locks/authors.txt create mode 100755 extra/concurrency/locks/locks.factor create mode 100644 extra/concurrency/locks/summary.txt create mode 100644 extra/concurrency/messaging/authors.txt rename extra/concurrency/{concurrency-docs.factor => messaging/messaging-docs.factor} (100%) rename extra/concurrency/{concurrency-tests.factor => messaging/messaging-tests.factor} (100%) create mode 100755 extra/concurrency/messaging/messaging.factor create mode 100644 extra/concurrency/messaging/summary.txt create mode 100644 extra/concurrency/promises/authors.txt create mode 100755 extra/concurrency/promises/promises.factor create mode 100644 extra/concurrency/promises/summary.txt create mode 100644 extra/concurrency/semaphores/authors.txt create mode 100755 extra/concurrency/semaphores/semaphores.factor create mode 100644 extra/concurrency/semaphores/summary.txt delete mode 100644 extra/concurrency/summary.txt delete mode 100644 extra/concurrency/tags.txt create mode 100755 extra/tools/threads/threads.factor diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index 3a41b80c2a..24408e1e20 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -1,12 +1,12 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays generator generator.registers generator.fixup hashtables kernel math namespaces sequences words inference.state inference.backend inference.dataflow system math.parser classes alien.arrays alien.c-types alien.structs alien.syntax cpu.architecture alien inspector quotations assocs -kernel.private threads continuations.private libc combinators -compiler.errors continuations ; +kernel.private concurrency.threads continuations.private libc +combinators compiler.errors continuations ; IN: alien.compiler ! Common protocol for alien-invoke/alien-callback/alien-indirect diff --git a/core/alien/remote-control/remote-control.factor b/core/alien/remote-control/remote-control.factor old mode 100644 new mode 100755 index b7700c0ff1..f3c84119bf --- a/core/alien/remote-control/remote-control.factor +++ b/core/alien/remote-control/remote-control.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types parser threads words kernel.private -kernel ; +USING: alien alien.c-types parser concurrency.threads words +kernel.private kernel ; IN: alien.remote-control : eval-callback diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 17b56458ce..35dae109cf 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -36,7 +36,7 @@ IN: bootstrap.image : data-base 1024 ; inline -: userenv-size 40 ; inline +: userenv-size 64 ; inline : header-size 10 ; inline diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index 4f5bf6d69e..7c7a03f575 100755 --- a/core/bootstrap/stage1.factor +++ b/core/bootstrap/stage1.factor @@ -31,6 +31,7 @@ vocabs.loader system ; "libc" require "io.streams.c" require + "io.thread" require "vocabs.loader" require "syntax" require diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index f0caec7ad1..3f06f85d10 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -3,8 +3,8 @@ USING: kernel namespaces arrays sequences io inference.backend inference.state generator debugger math.parser prettyprint words compiler.units continuations vocabs assocs alien.compiler dlists -optimizer definitions math compiler.errors threads graphs -generic ; +optimizer definitions math compiler.errors concurrency.threads +graphs generic ; IN: compiler : compiled-usages ( words -- seq ) diff --git a/core/threads/authors.txt b/core/concurrency/threads/authors.txt similarity index 100% rename from core/threads/authors.txt rename to core/concurrency/threads/authors.txt diff --git a/core/threads/summary.txt b/core/concurrency/threads/summary.txt similarity index 100% rename from core/threads/summary.txt rename to core/concurrency/threads/summary.txt diff --git a/core/concurrency/threads/threads-docs.factor b/core/concurrency/threads/threads-docs.factor new file mode 100755 index 0000000000..53acb40794 --- /dev/null +++ b/core/concurrency/threads/threads-docs.factor @@ -0,0 +1,137 @@ +USING: help.markup help.syntax kernel kernel.private io +concurrency.threads.private continuations dlists init +quotations strings assocs heaps ; +IN: concurrency.threads + +ARTICLE: "threads-start/stop" "Starting and stopping threads" +"Spawning new threads:" +{ $subsection spawn } +"Creating and spawning a thread can be factored out into two separate steps:" +{ $subsection } +{ $subsection (spawn) } +"Threads stop either when the quotation given to " { $link spawn } " returns, or when the following word is called:" +{ $subsection stop } +"If the image is saved and started again, all runnable threads are stopped. Vocabularies wishing to have a background thread always running should use " { $link add-init-hook } "." ; + +ARTICLE: "threads-yield" "Yielding and suspending threads" +"Yielding to other threads:" +{ $subsection yield } +{ $subsection sleep } +"Threads can be suspended and woken up at some point in the future when a condition is satisfied:" +{ $subsection suspend } +{ $subsection resume } +{ $subsection resume-with } ; + +ARTICLE: "thread-state" "Thread-local state" +"Threads form a class of objects:" +{ $subsection thread } +"The current thread:" +{ $subsection self } +"Thread-local variables:" +{ $subsection tnamespace } +{ $subsection tget } +{ $subsection tset } +{ $subsection tchange } +"Global hashtable of all threads, keyed by " { $link thread-id } ":" +{ $subsection threads } +"Threads have an identity independent of continuations. If a continuation is refied in one thread and then resumed in another thread, the code running in that continuation will observe a change in the value output by " { $link self } "." ; + +ARTICLE: "thread-impl" "Thread implementation" +"Thread implementation:" +{ $subsection run-queue } +{ $subsection sleep-queue } ; + +ARTICLE: "threads" "Lightweight co-operative threads" +"Factor supports lightweight co-operative threads implemented on top of continuations. A thread will yield while waiting for I/O operations to complete, or when a yield has been explicitly requested." +$nl +"Words for working with threads are in the " { $vocab-link "concurrency.threads" } " vocabulary." +{ $subsection "threads-start/stop" } +{ $subsection "threads-yield" } +{ $subsection "thread-state" } +{ $subsection "thread-impl" } ; + +ABOUT: "threads" + +HELP: thread +{ $class-description "A thread. The slots are as follows:" + { $list + { { $link thread-id } " - a unique identifier assigned to each thread." } + { { $link thread-name } " - the name passed to " { $link spawn } "." } + { { $link thread-quot } " - the initial quotation passed to " { $link spawn } "." } + { { $link thread-continuation } " - if the thread is waiting to run, the saved thread context. If the thread is currently running, will be " { $link f } "." } + { { $link thread-registered? } " - a boolean indicating whether the thread is eligible to run or not. Spawning a thread with " { $link (spawn) } " sets this flag and " { $link stop } " clears it." } + } +} ; + +HELP: self +{ $values { "thread" thread } } +{ $description "Pushes the currently-running thread." } ; + +HELP: +{ $values { "quot" quotation } { "name" string } { "error-handler" quotation } } +{ $description "Low-level thread constructor. The thread runs the quotation when spawned; the name is simply used to identify the thread for debugging purposes. The error handler is called if the thread's quotation throws an unhandled error; it should either print the error or notify another thread." } +{ $notes "In most cases, user code should call " { $link spawn } " instead, however for control over the error handler quotation, threads can be created with " { $link } " then passed to " { $link (spawn) } "." } ; + +HELP: run-queue +{ $values { "queue" dlist } } +{ $var-description "Global variable holding the queue of runnable threads. Calls to " { $link yield } " switch to the thread which has been in the queue for the longest period of time." +$nl +"By convention, threads are queued with " { $link push-front } +" and dequeued with " { $link pop-back } "." } ; + +HELP: resume +{ $values { "thread" thread } } +{ $description "Adds a thread to the end of the run queue. The thread must have previously been suspended by a call to " { $link suspend } "." } ; + +HELP: resume-with +{ $values { "obj" object } { "thread" thread } } +{ $description "Adds a thread to the end of the run queue together with an object to pass to the thread. The thread must have previously been suspended by a call to " { $link suspend } "; the object is returned from the " { $link suspend } " call." } ; + +HELP: sleep-queue +{ $var-description "A " { $link min-heap } " storing the queue of sleeping threads." } ; + +HELP: sleep-time +{ $values { "ms" "a non-negative integer or " { $link f } } } +{ $description "Outputs the time until the next sleeping thread is scheduled to wake up, which could be zero if there are threads in the run queue, or threads which need to wake up right now. If there are no runnable or sleeping threads, outputs " { $link f } "." } ; + +HELP: stop +{ $description "Stops the current thread. The thread may be started again from another thread using " { $link (spawn) } "." } ; + +HELP: yield +{ $description "Adds the current thread to the end of the run queue, and switches to the next runnable thread." } ; + +HELP: sleep +{ $values { "ms" "a non-negative integer" } } +{ $description "Suspends the current thread for " { $snippet "ms" } " milliseconds. It will not get woken up before this time period elapses, but since the multitasker is co-operative, the precise wakeup time is dependent on when other threads yield." } ; + +HELP: suspend +{ $values { "quot" "a quotation with stack effect " { $snippet "( thread -- )" } } { "obj" object } } +{ $description "Suspends the current thread and passes it to the quotation. After the quotation returns, control yields to the next runnable thread and the current thread does not execute again until it is resumed, and so the quotation must arrange for another thread to later resume the suspended thread with a call to " { $link resume } " or " { $link resume-with } "." } ; + +HELP: spawn +{ $values { "quot" quotation } { "name" string } } +{ $description "Spawns a new thread. The thread begins executing the given quotation; the name is for debugging purposes. The new thread begins running immediately and the current thread is added to the end of the run queue." +$nl +"The new thread begins with an empty data stack, an empty catch stack and a name stack containing the global namespace only. This means that the only way to pass data to the new thread is to explicitly construct a quotation containing the data, for example using " { $link curry } " or " { $link compose } "." } +{ $examples + { $code "1 2 [ + . ] 2curry \"Addition thread\" spawn" } +} ; + +HELP: init-threads +{ $description "Called during startup to initialize the threading system. This word should never be called directly." } ; + +HELP: tnamespace +{ $values { "assoc" assoc } } +{ $description "Outputs the current thread's set of thread-local variables." } ; + +HELP: tget +{ $values { "key" object } { "value" object } } +{ $description "Outputs the value of a thread-local variable." } ; + +HELP: tset +{ $values { "value" object } { "key" object } } +{ $description "Sets the value of a thread-local variable." } ; + +HELP: tchange +{ $values { "key" object } { "quot" "a quotation with stack effect " { $snippet "( value -- newvalue )" } } } +{ $description "Applies the quotation to the current value of a thread-local variable, storing the result back to the same variable." } ; diff --git a/core/concurrency/threads/threads-tests.factor b/core/concurrency/threads/threads-tests.factor new file mode 100755 index 0000000000..2bd7e8aa4c --- /dev/null +++ b/core/concurrency/threads/threads-tests.factor @@ -0,0 +1,16 @@ +USING: namespaces io tools.test concurrency.threads kernel ; +IN: temporary + +3 "x" set +namespace [ [ yield 2 "x" set ] bind ] curry "Test" spawn drop +[ 2 ] [ yield "x" get ] unit-test +[ ] [ [ flush ] "flush test" spawn drop flush ] unit-test +[ ] [ [ "Errors, errors" throw ] "error test" spawn drop ] unit-test +yield + +[ ] [ 0.3 sleep ] unit-test +[ "hey" sleep ] must-fail + +[ 3 ] [ + [ 3 swap resume-with ] suspend +] unit-test diff --git a/core/concurrency/threads/threads.factor b/core/concurrency/threads/threads.factor new file mode 100755 index 0000000000..1a11a00b82 --- /dev/null +++ b/core/concurrency/threads/threads.factor @@ -0,0 +1,172 @@ +! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2005 Mackenzie Straight. +! See http://factorcode.org/license.txt for BSD license. +IN: concurrency.threads +USING: arrays hashtables heaps kernel kernel.private math +namespaces sequences vectors continuations continuations.private +dlists assocs system combinators debugger prettyprint io init ; + +SYMBOL: initial-thread + +TUPLE: thread +name quot error-handler +id registered? +continuation +mailbox variables ; + +: self ( -- thread ) 40 getenv ; inline + +! Thread-local storage +: tnamespace ( -- assoc ) self thread-variables ; + +: tget ( key -- value ) tnamespace at ; + +: tset ( value key -- ) tnamespace set-at ; + +: tchange ( key quot -- ) tnamespace change-at ; inline + +SYMBOL: threads + +threads global [ H{ } assoc-like ] change-at + +: thread ( id -- thread ) threads get-global at ; + + ( quot name error-handler -- thread ) + \ thread counter H{ } clone { + set-thread-quot + set-thread-name + set-thread-error-handler + set-thread-id + set-thread-variables + } \ thread construct ; + +PRIVATE> + +SYMBOL: run-queue +SYMBOL: sleep-queue + +: resume ( thread -- ) + check-registered run-queue get-global push-front ; + +: resume-with ( obj thread -- ) + check-registered 2array run-queue get-global push-front ; + +r check-registered r> sleep-queue get-global heap-push ; + +: wake-up? ( heap -- ? ) + dup heap-empty? + [ drop f ] [ heap-peek nip millis <= ] if ; + +: wake-up ( -- ) + sleep-queue get-global + [ dup wake-up? ] [ dup heap-pop drop resume ] [ ] while + drop ; + +: next ( -- ) + walker-hook [ + continue + ] [ + wake-up + run-queue get-global pop-back + dup array? [ first2 ] [ f swap ] if dup set-self + dup thread-continuation + f rot set-thread-continuation + continue-with + ] if* ; + +PRIVATE> + +: sleep-time ( -- ms ) + { + { [ run-queue get-global dlist-empty? not ] [ 0 ] } + { [ sleep-queue get-global heap-empty? ] [ f ] } + { [ t ] [ sleep-queue get-global heap-peek nip millis [-] ] } + } cond ; + +: stop ( -- ) + self unregister-thread next ; + +: suspend ( quot -- obj ) + [ + >r self [ set-thread-continuation ] keep r> call next + ] curry callcc1 ; inline + +: yield ( -- ) [ resume ] suspend drop ; + +: sleep ( ms -- ) + >fixnum millis + [ schedule-sleep ] curry suspend drop ; + +: (spawn) ( thread -- ) + [ + resume [ + dup set-self + dup register-thread + init-namespaces + V{ } set-catchstack + { } set-retainstack + >r { } set-datastack r> + thread-quot [ call stop ] call-clear + ] 1 (throw) + ] suspend 2drop ; + +: spawn ( quot name -- thread ) + [ + global [ + "Error in thread " write + dup thread-id pprint + " (" write + dup thread-name pprint ")" print + "spawned to call " write + thread-quot short. + nl + print-error flush + ] bind + ] + [ (spawn) ] keep ; + +: in-thread ( quot -- ) "Thread" spawn drop ; + + run-queue set-global + sleep-queue set-global + H{ } clone threads set-global + initial-thread global + [ drop f "Initial" [ die ] ] cache + f over set-thread-continuation + f over set-thread-registered? + dup register-thread + set-self ; + +[ self dup thread-error-handler call stop ] +thread-error-hook set-global + +PRIVATE> + +[ init-threads ] "concurrency.threads" add-init-hook diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 81f78f491d..19802da7df 100755 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -113,8 +113,13 @@ GENERIC: compute-restarts ( error -- seq ) PRIVATE> +SYMBOL: thread-error-hook + : rethrow ( error -- * ) - catchstack* empty? [ die ] when + catchstack* empty? [ + thread-error-hook get-global + [ 1 (throw) ] [ die ] if* + ] when dup save-error c> continue-with ; : recover ( try recovery -- ) diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 3514947e3d..c62fc9f8a2 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -5,7 +5,7 @@ effects generator.fixup generator.registers generic hashtables inference inference.backend inference.dataflow io kernel kernel.private layouts math namespaces optimizer optimizer.specializers prettyprint quotations sequences system -threads words vectors ; +concurrency.threads words vectors ; IN: generator SYMBOL: compile-queue diff --git a/core/init/init.factor b/core/init/init.factor old mode 100644 new mode 100755 diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor index 9aa1299871..c38b7355b1 100755 --- a/core/io/backend/backend.factor +++ b/core/io/backend/backend.factor @@ -19,8 +19,8 @@ HOOK: normalize-pathname io-backend ( str -- newstr ) M: object normalize-pathname ; -[ init-io embedded? [ init-stdio ] unless ] -"io.backend" add-init-hook - : set-io-backend ( backend -- ) io-backend set-global init-io init-stdio ; + +[ init-io embedded? [ init-stdio ] unless ] +"io.backend" add-init-hook diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index d0f9737f19..a111070151 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -55,11 +55,11 @@ USING: tools.test io.files io threads kernel continuations ; [ f ] [ "test-blah" resource-path exists? ] unit-test -[ ] [ "test-quux.txt" resource-path [ [ yield "Hi" write ] in-thread ] with-file-writer ] unit-test +[ ] [ "test-quux.txt" resource-path [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test [ ] [ "test-quux.txt" resource-path delete-file ] unit-test -[ ] [ "test-quux.txt" resource-path [ [ yield "Hi" write ] in-thread ] with-file-writer ] unit-test +[ ] [ "test-quux.txt" resource-path [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test [ ] [ "test-quux.txt" "quux-test.txt" [ resource-path ] 2apply rename-file ] unit-test [ t ] [ "quux-test.txt" resource-path exists? ] unit-test diff --git a/core/io/thread/thread.factor b/core/io/thread/thread.factor new file mode 100755 index 0000000000..ec118dcbf7 --- /dev/null +++ b/core/io/thread/thread.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: io.thread +USING: concurrency.threads io.backend namespaces init ; + +: io-thread ( -- ) + sleep-time io-multiplex yield io-thread ; + +: start-io-thread ( -- ) + [ io-thread ] + "I/O wait" spawn + \ io-thread set-global ; + +[ start-io-thread ] "io.thread" add-init-hook diff --git a/core/namespaces/namespaces-docs.factor b/core/namespaces/namespaces-docs.factor old mode 100644 new mode 100755 index f087090f2c..2d4b9a03b2 --- a/core/namespaces/namespaces-docs.factor +++ b/core/namespaces/namespaces-docs.factor @@ -179,8 +179,5 @@ HELP: % { $description "Appends a sequence to the end of the sequence being constructed by " { $link make } "." } ; HELP: init-namespaces -{ $description "Resets the name stack to its initial state, holding a single copy of the global namespace. This word is called during startup and is rarely useful, except in certain situations such as the example below." } -{ $examples - "You can use this word to spawn a new thread which does not inherit the parent thread's dynamic variable bindings:" - { $code "[ init-namestack do-some-work ] in-thread" } -} ; +{ $description "Resets the name stack to its initial state, holding a single copy of the global namespace." } +$low-level-note ; diff --git a/core/threads/threads-docs.factor b/core/threads/threads-docs.factor deleted file mode 100755 index ece90d9a11..0000000000 --- a/core/threads/threads-docs.factor +++ /dev/null @@ -1,69 +0,0 @@ -USING: help.markup help.syntax kernel kernel.private io -threads.private continuations dlists ; -IN: threads - -ARTICLE: "threads" "Threads" -"A limited form of multiprocessing is supported in the form of cooperative threads, which are implemented on top of continuations. A thread will yield while waiting for I/O operations to complete, or when a yield has been explicitly requested." -$nl -"Words for working with threads are in the " { $vocab-link "threads" } " vocabulary." -{ $subsection in-thread } -{ $subsection yield } -{ $subsection sleep } -"Threads stop either when the quotation given to " { $link in-thread } " returns, or when the following word is called:" -{ $subsection stop } -"Continuations can be added to the run queue directly:" -{ $subsection schedule-thread } -{ $subsection schedule-thread-with } -"Thread implementation:" -{ $subsection run-queue } -{ $subsection sleep-queue } ; - -ABOUT: "threads" - -HELP: run-queue -{ $values { "queue" dlist } } -{ $description "Outputs the runnable thread queue. By convention, continuations are queued with " { $link push-front } -" and dequeued with " { $link pop-back } "." } ; - -HELP: schedule-thread -{ $values { "continuation" "a continuation reified by " { $link callcc0 } } } -{ $description "Adds a runnable thread to the end of the run queue." } ; - -HELP: schedule-thread-with -{ $values { "obj" "an object" } { "continuation" "a continuation reified by " { $link callcc1 } } } -{ $description "Adds a runnable thread to the end of the run queue. When the thread runs the object is passed to the continuation using " { $link continue-with } "." } ; - -HELP: sleep-queue -{ $var-description "Sleeping thread queue. This is not actually a queue, but an array of pairs of the shape " { $snippet "{ time continuation }" } "." } ; - -HELP: sleep-time -{ $values { "ms" "a non-negative integer" } } -{ $description "Outputs the time until the next sleeping thread is scheduled to wake up, or a default sleep time if there are no sleeping threads." } ; - -HELP: stop -{ $description "Stops the current thread." } ; - -HELP: yield -{ $description "Adds the current thread to the end of the run queue, and switches to the next runnable thread." } ; - -HELP: sleep -{ $values { "ms" "a non-negative integer" } } -{ $description "Suspends the current thread for " { $snippet "ms" } " milliseconds. It will not get woken up before this time period elapses, but since the multitasker is co-operative, the precise wakeup time is dependent on when other threads yield." } ; - -HELP: in-thread -{ $values { "quot" "a quotation" } } -{ $description "Spawns a new thread. The new thread begins running immediately." -$nl -"The new thread inherits the current data stack and name stack. The call stack initially contains the new quotation only, so when the quotation returns the thread stops. The catch stack contains a default handler which logs errors to the " { $link stdio } " stream." } -{ $examples - { $code "1 2 [ + . ] in-thread" } -} ; - -HELP: idle-thread -{ $description "Runs the idle thread, which services I/O requests and relinquishes control to the operating system until the next Factor thread has to wake up again." -$nl -"If the run queue is empty, the idle thread will sleep until the next sleeping thread is scheduled to wake up, otherwise it yields immediately after checking for any completed I/O requests." } -{ $notes "This word should never be called directly. The idle thread is always running." } ; - -HELP: init-threads -{ $description "Called during startup to initialize the threading system. This word should never be called directly." } ; diff --git a/core/threads/threads-tests.factor b/core/threads/threads-tests.factor deleted file mode 100755 index 379b10ce88..0000000000 --- a/core/threads/threads-tests.factor +++ /dev/null @@ -1,12 +0,0 @@ -USING: namespaces io tools.test threads kernel ; -IN: temporary - -3 "x" set -[ yield 2 "x" set ] in-thread -[ 2 ] [ yield "x" get ] unit-test -[ ] [ [ flush ] in-thread flush ] unit-test -[ ] [ [ "Errors, errors" throw ] in-thread ] unit-test -yield - -[ ] [ 0.3 sleep ] unit-test -[ "hey" sleep ] must-fail diff --git a/core/threads/threads.factor b/core/threads/threads.factor deleted file mode 100755 index c4e159742a..0000000000 --- a/core/threads/threads.factor +++ /dev/null @@ -1,71 +0,0 @@ -! Copyright (C) 2004, 2007 Slava Pestov. -! Copyright (C) 2005 Mackenzie Straight. -! See http://factorcode.org/license.txt for BSD license. -IN: threads -USING: arrays init hashtables heaps io.backend kernel -kernel.private math namespaces sequences vectors io system -continuations debugger dlists ; - - - -: schedule-thread ( continuation -- ) - run-queue push-front ; - -: schedule-thread-with ( obj continuation -- ) - 2array schedule-thread ; - -: stop ( -- ) - walker-hook [ - continue - ] [ - run-queue pop-back dup array? - [ first2 continue-with ] [ continue ] if - ] if* ; - -: yield ( -- ) [ schedule-thread stop ] callcc0 ; - -: sleep ( ms -- ) - >fixnum millis + [ schedule-sleep stop ] curry callcc0 ; - -: in-thread ( quot -- ) - [ - >r schedule-thread r> [ - V{ } set-catchstack - { } set-retainstack - [ [ print-error ] recover stop ] call-clear - ] 1 (throw) - ] curry callcc0 ; - - \ run-queue set-global - sleep-queue set-global - [ idle-thread ] in-thread ; - -[ init-threads ] "threads" add-init-hook -PRIVATE> diff --git a/extra/bootstrap/tools/tools.factor b/extra/bootstrap/tools/tools.factor index 40d77e03be..718f73308c 100755 --- a/extra/bootstrap/tools/tools.factor +++ b/extra/bootstrap/tools/tools.factor @@ -5,10 +5,11 @@ USING: vocabs.loader sequences ; "tools.annotations" "tools.crossref" "tools.deploy" + "tools.disassembler" "tools.memory" "tools.profiler" "tools.test" "tools.time" - "tools.disassembler" + "tools.threads" "editors" } [ require ] each diff --git a/extra/calendar/model/model.factor b/extra/calendar/model/model.factor index 855b0cd815..61ab191b75 100755 --- a/extra/calendar/model/model.factor +++ b/extra/calendar/model/model.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: calendar namespaces models threads init ; +USING: calendar namespaces models concurrency.threads init ; IN: calendar.model SYMBOL: time @@ -9,7 +9,8 @@ SYMBOL: time now time get set-model 1000 sleep (time-thread) ; -: time-thread ( -- ) [ (time-thread) ] in-thread ; +: time-thread ( -- ) + [ (time-thread) ] "Time model update" spawn drop ; f time set-global [ time-thread ] "calendar.model" add-init-hook diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor deleted file mode 100755 index b0abac8f5b..0000000000 --- a/extra/concurrency/concurrency.factor +++ /dev/null @@ -1,384 +0,0 @@ -! Copyright (C) 2005 Chris Double. All Rights Reserved. -! See http://factorcode.org/license.txt for BSD license. -! -! Concurrency library for Factor based on Erlang/Termite style -! concurrency. -USING: vectors dlists threads sequences continuations - namespaces random math quotations words kernel match - arrays io assocs init shuffle system ; -IN: concurrency - -TUPLE: mailbox threads data ; - -TUPLE: thread timeout continuation continued? ; - -: ( timeout continuation -- obj ) - >r dup [ millis + ] when r> - { - set-thread-timeout - set-thread-continuation - } thread construct ; - -: make-mailbox ( -- mailbox ) - V{ } clone mailbox construct-boa ; - -: mailbox-empty? ( mailbox -- bool ) - mailbox-data dlist-empty? ; - -: mailbox-put ( obj mailbox -- ) - [ mailbox-data push-back ] keep - [ mailbox-threads ] keep - V{ } clone swap set-mailbox-threads - [ thread-continuation schedule-thread ] each yield ; - - swap mailbox-threads push stop ] callcc0 - (mailbox-block-unless-pred) - ] if ; inline - -: (mailbox-block-if-empty) ( mailbox timeout -- mailbox2 ) - over mailbox-empty? [ - [ swap mailbox-threads push stop ] callcc0 - (mailbox-block-if-empty) - ] [ - drop - ] if ; -PRIVATE> -: mailbox-get* ( mailbox timeout -- obj ) - (mailbox-block-if-empty) - mailbox-data pop-front ; - -: mailbox-get ( mailbox -- obj ) - f mailbox-get* ; - -: mailbox-get-all* ( mailbox timeout -- array ) - (mailbox-block-if-empty) - [ dup mailbox-empty? ] - [ dup mailbox-data pop-front ] - [ ] unfold nip ; - -: mailbox-get-all ( mailbox -- array ) - f mailbox-get-all* ; - -: while-mailbox-empty ( mailbox quot -- ) - over mailbox-empty? [ - dup >r swap slip r> while-mailbox-empty - ] [ - 2drop - ] if ; inline - -: mailbox-get?* ( pred mailbox timeout -- obj ) - 2over >r >r (mailbox-block-unless-pred) r> r> - mailbox-data delete-node-if ; inline - -: mailbox-get? ( pred mailbox -- obj ) - f mailbox-get?* ; - -TUPLE: process links pid mailbox ; - -C: process - -GENERIC: send ( message process -- ) - - ; - -: make-linked-process ( process -- process ) - #! Return a process set to run on the local node. That process is - #! linked to the process on the stack. It will receive a message if - #! that process terminates. - 1quotation random-256 make-mailbox ; -PRIVATE> - -: self ( -- process ) - \ self get ; - - - -DEFER: register-process -DEFER: unregister-process - - - -: spawn ( quot -- process ) - [ ((spawn)) ] curry (spawn) ; inline - -TUPLE: linked-exception error ; - -C: linked-exception - -: while-no-messages ( quot -- ) - #! Run the quotation in a loop while no messages are in - #! the processes mailbox. The quot should have stack effect - #! ( -- ). - >r self process-mailbox r> while-mailbox-empty ; inline - -M: process send ( message process -- ) - process-mailbox mailbox-put ; - -: receive ( -- message ) - self process-mailbox mailbox-get dup linked-exception? [ - linked-exception-error rethrow - ] when ; - -: receive-if ( pred -- message ) - self process-mailbox mailbox-get? dup linked-exception? [ - linked-exception-error rethrow - ] when ; inline - -: rethrow-linked ( error -- ) - #! Rethrow the error to the linked process - self process-links [ - over swap send - ] each drop ; - - - -: spawn-link ( quot -- process ) - [ [ rethrow-linked ] recover ] curry - [ ((spawn)) ] curry (spawn-link) ; inline - - - -: recv ( forms -- ) - #! Get a message from the processes mailbox. Compare it against the - #! forms to run a quotation if it matches the given message. 'forms' - #! is a list of quotations in the following format: - #! [ pred match-quot ] - #! 'pred' is a word that has stack effect ( msg -- bool ). It is - #! executed with the message on the stack. It should return a - #! boolean if it is a message this form should process. - #! '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. - #! Each form in the list will be matched against the message, - #! even if a prior match succeeded. This means multiple quotations - #! may be run against the message. - receive swap [ dupd (recv) ] each drop ; - -MATCH-VARS: ?from ?tag ; - -r self random-256 r> 3array ; -PRIVATE> - -: send-synchronous ( message process -- reply ) - #! Sends a message to the process synchronously. The - #! message will be wrapped to include the process of the sender - #! and a unique tag. After being sent the sending process will - #! block for a reply tagged with the same unique tag. - >r tag-message dup r> send second _ 2array [ match ] curry - receive-if second ; - - - -: spawn-server ( quot -- process ) - #! Spawn a server that receives messages, calling the - #! quotation on the message. If the quotation returns false - #! the spawned process exits. If it returns true, the process - #! starts from the beginning again. The quotation should have - #! stack effect ( message -- bool ). - [ - (spawn-server) - "Exiting process: " write self process-pid print - ] curry spawn ; inline - -: spawn-linked-server ( quot -- process ) - #! Similar to 'spawn-server' but the parent process will be linked - #! to the child. - [ - (spawn-server) - "Exiting process: " write self process-pid print - ] curry spawn-link ; inline - -: server-cc ( -- cc|process ) - #! Captures the current continuation and returns the value. - #! If that CC is called with a process on the stack it will - #! set 'self' for the current process to it. Otherwise it will - #! return the value. This allows capturing a continuation in a server, - #! and jumping back into it from a spawn and keeping the 'self' - #! variable correct. It's a workaround until I can find out how to - #! stop 'self' from being clobbered back to its old value. - [ ] callcc1 dup process? [ \ self set-global f ] when ; - -: call-server-cc ( server-cc -- ) - #! Calls the server continuation passing the current 'self' - #! so the server continuation gets its new self updated. - self swap call ; - -TUPLE: future value processes ; - -: notify-future ( value future -- ) - tuck set-future-value - dup future-processes [ schedule-thread ] each - f swap set-future-processes ; - -: future ( quot -- future ) - #! Spawn a process to call the quotation and immediately return. - f V{ } clone \ future construct-boa [ - [ - >r [ t 2array ] compose [ f 2array ] recover r> - notify-future - ] 2curry spawn drop - ] keep ; - -: ?future ( future -- result ) - #! Block the process until the future has completed and then - #! place the result on the stack. Return the result - #! immediately if the future has completed. - dup future-value [ - first2 [ rethrow ] unless - ] [ - dup [ future-processes push stop ] curry callcc0 ?future - ] ?if ; - -: parallel-map ( seq quot -- newseq ) - #! Spawn a process to apply quot to each element of seq, - #! joining the results into a sequence at the end. - [ curry future ] curry map [ ?future ] map ; - -: parallel-each ( seq quot -- ) - #! Spawn a process to apply quot to each element of seq, - #! and waits for all processes to complete. - [ f ] compose parallel-map drop ; - -TUPLE: promise fulfilled? value processes ; - -: ( -- ) - f f V{ } clone promise construct-boa ; - -: fulfill ( value promise -- ) - #! Set the future of the promise to the given value. Threads - #! blocking on the promise will then be released. - dup promise-fulfilled? [ - 2drop - ] [ - [ set-promise-value ] keep - [ t swap set-promise-fulfilled? ] keep - [ promise-processes ] keep - V{ } clone swap set-promise-processes - [ thread-continuation schedule-thread ] each yield - ] if ; - - swap promise-processes push stop ] callcc0 - drop - ] if ; -PRIVATE> - -: ?promise* ( promise timeout -- result ) - (maybe-block-promise) promise-value ; - -: ?promise ( promise -- result ) - f ?promise* ; - -! ****************************** -! Experimental code below -! ****************************** - - -: lazy ( quot -- lazy ) - #! Spawn a process that immediately blocks and return it. - #! When '?lazy' is called on the returned process, call the quotation - #! and return the result. The quotation must have stack effect ( -- X ). - [ - receive { - { { ?from ?tag _ } - [ call ?tag over 2array ?from send (lazy) ] } - } match-cond - ] spawn nip ; - -: ?lazy ( lazy -- result ) - #! Given a process spawned using 'lazy', evaluate it and return the result. - f swap send-synchronous ; - - - -: register-process ( name process -- ) - swap remote-processes set-at ; - -: unregister-process ( name -- ) - remote-processes delete-at ; - -: get-process ( name -- process ) - remote-processes at ; - -[ - H{ } clone \ remote-processes set-global - init-main-process - self [ process-pid ] keep register-process -] "process-registry" add-init-hook diff --git a/extra/concurrency/distributed/distributed.factor b/extra/concurrency/distributed/distributed.factor index 83052b803a..042c33306e 100755 --- a/extra/concurrency/distributed/distributed.factor +++ b/extra/concurrency/distributed/distributed.factor @@ -1,43 +1,33 @@ ! Copyright (C) 2005 Chris Double. All Rights Reserved. ! See http://factorcode.org/license.txt for BSD license. -USING: serialize sequences concurrency io io.server qualified -threads arrays namespaces kernel ; +USING: serialize sequences concurrency.messaging +concurrency.threads io io.server qualified arrays +namespaces kernel ; QUALIFIED: io.sockets IN: concurrency.distributed -TUPLE: node hostname port ; - -C: node - : handle-node-client ( -- ) - deserialize first2 get-process send ; + deserialize first2 thread send ; -: node-server ( port -- ) - internet-server - "concurrency.distributed" - [ handle-node-client ] with-server ; +: (start-node) ( addrspecs addrspec -- ) + [ + local-node set-global + "concurrency.distributed" + [ handle-node-client ] with-server + ] 2curry f spawn drop ; -: send-to-node ( msg pid host port -- ) - io.sockets: io.sockets: [ - 2array serialize - ] with-stream ; +SYMBOL: local-node ( -- addrspec ) -: localnode ( -- node ) - \ localnode get ; +: start-node ( port -- ) + dup internet-server host-name rot (start-node) ; -: start-node ( hostname port -- ) - [ node-server ] in-thread - \ localnode set-global ; +TUPLE: remote-thread pid node ; -TUPLE: remote-process node pid ; +M: remote-thread send ( message thread -- ) + { remote-thread-pid remote-thread-node } get-slots + io.sockets: [ 2array serialize ] with-stream ; -C: remote-process - -M: remote-process send ( message process -- ) - #! Send the message via the inter-node protocol - { remote-process-pid remote-process-node } get-slots - { node-hostname node-port } get-slots - send-to-node ; - -M: process (serialize) ( obj -- ) - localnode swap process-pid (serialize) ; +M: thread (serialize) ( obj -- ) + thread-id local-node get-global + remote-thread construct-boa + (serialize) ; diff --git a/extra/concurrency/exchangers/authors.txt b/extra/concurrency/exchangers/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/concurrency/exchangers/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/concurrency/exchangers/exchangers.factor b/extra/concurrency/exchangers/exchangers.factor new file mode 100755 index 0000000000..39f01ae2ca --- /dev/null +++ b/extra/concurrency/exchangers/exchangers.factor @@ -0,0 +1,21 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel concurrency.threads ; +IN: concurrency.exchangers + +! Motivated by +! http://java.sun.com/j2se/1.5.0/docs/api/java/util/concurrent/Exchanger.html + +TUPLE: exchanger thread ; + +: ( -- exchanger ) + f exchanger construct-boa ; + +: exchange ( obj exchanger -- newobj ) + dup exchanger-thread [ + dup exchanger-thread + f rot set-exchanger-thread + resume-with + ] [ + [ set-exchanger-thread ] curry suspend + ] if ; diff --git a/extra/concurrency/exchangers/exchangers.txt b/extra/concurrency/exchangers/exchangers.txt new file mode 100644 index 0000000000..ea69c91e03 --- /dev/null +++ b/extra/concurrency/exchangers/exchangers.txt @@ -0,0 +1 @@ +Thread rendezvous points diff --git a/extra/concurrency/authors.txt b/extra/concurrency/futures/authors.txt similarity index 50% rename from extra/concurrency/authors.txt rename to extra/concurrency/futures/authors.txt index 44b06f94bc..a8fb961d36 100644 --- a/extra/concurrency/authors.txt +++ b/extra/concurrency/futures/authors.txt @@ -1 +1,2 @@ Chris Double +Slava Pestov diff --git a/extra/concurrency/futures/futures.factor b/extra/concurrency/futures/futures.factor new file mode 100755 index 0000000000..fa8aba27fe --- /dev/null +++ b/extra/concurrency/futures/futures.factor @@ -0,0 +1,25 @@ +! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: concurrency.futures + +: future ( quot -- future ) + [ + [ + >r + [ t 2array ] compose + [ f 2array ] recover + r> fulfill + ] 2curry "Future" spawn drop + ] keep ; inline + +: ?future-timeout ( future timeout -- value ) + ?promise-timeout first2 [ rethrow ] unless ; + +: ?future ( future -- value ) + f ?future-timeout ; + +: parallel-map ( seq quot -- newseq ) + [ curry future ] curry map [ ?future ] map ; + +: parallel-each ( seq quot -- ) + [ f ] compose parallel-map drop ; diff --git a/extra/concurrency/futures/summary.txt b/extra/concurrency/futures/summary.txt new file mode 100644 index 0000000000..12de3c6f7e --- /dev/null +++ b/extra/concurrency/futures/summary.txt @@ -0,0 +1 @@ +Deferred computations diff --git a/extra/concurrency/locks/authors.txt b/extra/concurrency/locks/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/concurrency/locks/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/concurrency/locks/locks.factor b/extra/concurrency/locks/locks.factor new file mode 100755 index 0000000000..182bf0a106 --- /dev/null +++ b/extra/concurrency/locks/locks.factor @@ -0,0 +1,87 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: dlists kernel concurrency.threads continuations math ; +IN: concurrency.locks + +! Simple critical sections +TUPLE: lock threads owner ; + +: lock construct-boa ; + +: notify-1 ( dlist -- ) + dup dlist-empty? [ pop-back resume ] [ drop ] if ; + +r >r over r> call over r> curry [ ] cleanup ; inline + +PRIVATE> + +: with-lock ( lock quot -- ) + [ acquire-lock ] [ release-lock ] do-lock ; inline + +: with-reentrant-lock ( lock quot -- ) + over lock-owner self eq? + [ nip call ] [ with-lock ] if ; inline + +! Many-reader/single-writer locks +TUPLE: rw-lock readers writers reader# writer ; + +: ( -- lock ) + 0 f rw-lock construct-boa ; + + or + [ dup wait-for-write-lock ] when + self over set-rw-lock-writer ; + +: release-write-lock ( lock -- ) + f over set-rw-lock-writer + dup rw-lock-readers dlist-empty? + [ notify-writer ] [ rw-lock-readers notify-all ] if ; + +: do-recursive-rw-lock ( lock quot quot' -- ) + >r over rw-lock-writer self eq? [ nip call ] r> if ; inline + +PRIVATE> + +: with-read-lock ( lock quot -- ) + [ + [ acquire-read-lock ] [ release-read-lock ] do-lock + ] do-recursive-rw-lock ; inline + +: with-write-lock ( lock quot -- ) + [ + [ acquire-write-lock ] [ release-write-lock ] do-lock + ] do-recursive-rw-lock ; inline diff --git a/extra/concurrency/locks/summary.txt b/extra/concurrency/locks/summary.txt new file mode 100644 index 0000000000..2ac51cd59b --- /dev/null +++ b/extra/concurrency/locks/summary.txt @@ -0,0 +1 @@ +Traditional locks and many reader/single writer locks diff --git a/extra/concurrency/messaging/authors.txt b/extra/concurrency/messaging/authors.txt new file mode 100644 index 0000000000..a8fb961d36 --- /dev/null +++ b/extra/concurrency/messaging/authors.txt @@ -0,0 +1,2 @@ +Chris Double +Slava Pestov diff --git a/extra/concurrency/concurrency-docs.factor b/extra/concurrency/messaging/messaging-docs.factor similarity index 100% rename from extra/concurrency/concurrency-docs.factor rename to extra/concurrency/messaging/messaging-docs.factor diff --git a/extra/concurrency/concurrency-tests.factor b/extra/concurrency/messaging/messaging-tests.factor similarity index 100% rename from extra/concurrency/concurrency-tests.factor rename to extra/concurrency/messaging/messaging-tests.factor diff --git a/extra/concurrency/messaging/messaging.factor b/extra/concurrency/messaging/messaging.factor new file mode 100755 index 0000000000..bd625ff499 --- /dev/null +++ b/extra/concurrency/messaging/messaging.factor @@ -0,0 +1,121 @@ +! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +! +! Concurrency library for Factor based on Erlang/Termite style +! concurrency. +IN: concurrency.messaging +USING: dlists concurrency.threads sequences continuations +namespaces random math quotations words kernel arrays assocs +init system ; + +TUPLE: mailbox threads data ; + +: ( -- mailbox ) + mailbox construct-boa ; + +: mailbox-empty? ( mailbox -- bool ) + mailbox-data dlist-empty? ; + +: notify-all ( dlist -- ) + [ second resume ] dlist-slurp yield ; + +: mailbox-put ( obj mailbox -- ) + [ mailbox-data push-front ] keep + mailbox-threads notify-all ; + + + +: mailbox-peek ( mailbox -- obj ) + mailbox-data peek-front ; + +: mailbox-get-timeout ( mailbox timeout -- obj ) + block-if-empty mailbox-data pop-front ; + +: mailbox-get ( mailbox -- obj ) + f mailbox-timeout-get ; + +: mailbox-get-all-timeout ( mailbox timeout -- array ) + (mailbox-block-if-empty) + [ dup mailbox-empty? ] + [ dup mailbox-data pop-back ] + [ ] unfold nip ; + +: mailbox-get-all ( mailbox -- array ) + f mailbox-timeout-get-all ; + +: while-mailbox-empty ( mailbox quot -- ) + over mailbox-empty? [ + dup >r swap slip r> while-mailbox-empty + ] [ + 2drop + ] if ; inline + +: mailbox-timeout-get? ( pred mailbox timeout -- obj ) + [ (mailbox-block-unless-pred) ] 3keep drop + mailbox-data delete-node-if ; inline + +: mailbox-get? ( pred mailbox -- obj ) + f mailbox-timeout-get? ; + +TUPLE: linked error thread ; + +: self linked construct-boa ; + +GENERIC: send ( message thread -- ) + +M: thread send ( message thread -- ) + thread-mailbox mailbox-put ; + +: ?linked dup linked? [ rethrow ] when ; + +: mailbox self thread-mailbox ; + +: receive ( -- message ) + mailbox mailbox-get ?linked ; + +: receive-if ( pred -- message ) + mailbox mailbox-get? ?linked ; inline + +: rethrow-linked ( error supervisor -- ) + >r r> send ; + +: spawn-linked ( quot name -- thread ) + self [ rethrow-linked ] curry [ (spawn) ] keep ; + +TUPLE: synchronous data sender tag ; + +: ( data -- sync ) + self random-256 synchronous construct-boa ; + +TUPLE: reply data tag ; + +: ( data synchronous -- reply ) + synchronous-tag \ reply construct-boa ; + +: send-synchronous ( message thread -- reply ) + >r dup r> send + [ over reply? [ reply-tag = ] [ 2drop f ] if ] curry + receive-if reply-data ; + +: reply-synchronous ( message synchronous -- ) + [ ] keep synchronous-sender reply ; diff --git a/extra/concurrency/messaging/summary.txt b/extra/concurrency/messaging/summary.txt new file mode 100644 index 0000000000..a41b7edb49 --- /dev/null +++ b/extra/concurrency/messaging/summary.txt @@ -0,0 +1 @@ +Erlang/Termite-style message-passing concurrency diff --git a/extra/concurrency/promises/authors.txt b/extra/concurrency/promises/authors.txt new file mode 100644 index 0000000000..a8fb961d36 --- /dev/null +++ b/extra/concurrency/promises/authors.txt @@ -0,0 +1,2 @@ +Chris Double +Slava Pestov diff --git a/extra/concurrency/promises/promises.factor b/extra/concurrency/promises/promises.factor new file mode 100755 index 0000000000..ecaa722b11 --- /dev/null +++ b/extra/concurrency/promises/promises.factor @@ -0,0 +1,24 @@ +! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: concurrency.promises + +TUPLE: promise mailbox ; + +: ( -- promise ) + promise construct-boa ; + +: promise-fulfilled? ( promise -- ? ) + promise-mailbox mailbox-empty? not ; + +: fulfill ( value promise -- ) + dup promise-fulfilled? [ + "Promise already fulfilled" throw + ] [ + promise-mailbox mailbox-put + ] if ; + +: ?promise-timeout ( promise timeout -- result ) + >r promise-mailbox r> block-if-empty mailbox-peek ; + +: ?promise ( promise -- result ) + f ?promise-timeout ; diff --git a/extra/concurrency/promises/summary.txt b/extra/concurrency/promises/summary.txt new file mode 100644 index 0000000000..96c70cb31a --- /dev/null +++ b/extra/concurrency/promises/summary.txt @@ -0,0 +1 @@ +Thread-safe write-once variables diff --git a/extra/concurrency/semaphores/authors.txt b/extra/concurrency/semaphores/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/concurrency/semaphores/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/concurrency/semaphores/semaphores.factor b/extra/concurrency/semaphores/semaphores.factor new file mode 100755 index 0000000000..7bfaf4c1ce --- /dev/null +++ b/extra/concurrency/semaphores/semaphores.factor @@ -0,0 +1,20 @@ +IN: concurrency.semaphores + +TUPLE: semaphore count threads ; + +: ( -- semaphore ) + 0 semaphore construct-boa ; + +: wait-to-acquire ( semaphore -- ) + [ semaphore-threads push-front ] suspend drop ; + +: acquire ( semaphore -- ) + dup semaphore-count zero? [ + wait-to-acquire + ] [ + dup semaphore-count 1- swap set-semaphore-count + ] if ; + +: release ( semaphore -- ) + dup semaphore-count 1+ over set-semaphore-count + semaphore-threads notify-1 ; diff --git a/extra/concurrency/semaphores/summary.txt b/extra/concurrency/semaphores/summary.txt new file mode 100644 index 0000000000..15883d541f --- /dev/null +++ b/extra/concurrency/semaphores/summary.txt @@ -0,0 +1 @@ +Counting semaphores diff --git a/extra/concurrency/summary.txt b/extra/concurrency/summary.txt deleted file mode 100644 index 7f48dd43b4..0000000000 --- a/extra/concurrency/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Erlang-style concurrency diff --git a/extra/concurrency/tags.txt b/extra/concurrency/tags.txt deleted file mode 100644 index f4274299b1..0000000000 --- a/extra/concurrency/tags.txt +++ /dev/null @@ -1 +0,0 @@ -extensions diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index dce893dcaf..be4445f842 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io io.backend io.timeouts system kernel namespaces strings hashtables sequences assocs combinators vocabs.loader -init threads continuations math ; +init concurrency.threads continuations math ; IN: io.launcher ! Non-blocking process exit notification facility @@ -83,7 +83,7 @@ HOOK: run-process* io-backend ( desc -- handle ) : wait-for-process ( process -- status ) [ dup process-handle - [ dup [ processes get at push stop ] curry callcc0 ] when + [ dup [ processes get at push ] curry suspend drop ] when dup process-killed? [ "Process was killed" throw ] [ process-status ] if ] with-timeout ; @@ -134,5 +134,5 @@ TUPLE: process-stream process ; : notify-exit ( status process -- ) [ set-process-status ] keep - [ processes get delete-at* drop [ schedule-thread ] each ] keep + [ processes get delete-at* drop [ resume ] each ] keep f swap set-process-handle ; diff --git a/extra/io/monitors/monitors.factor b/extra/io/monitors/monitors.factor index eff27614ae..2f54ea59fe 100755 --- a/extra/io/monitors/monitors.factor +++ b/extra/io/monitors/monitors.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.backend kernel continuations namespaces sequences -assocs hashtables sorting arrays threads ; +assocs hashtables sorting arrays concurrency.threads ; IN: io.monitors add-io-task ] if ; : (wait-to-write) ( port -- ) diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 5adf0d7453..51773515bf 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -124,4 +124,4 @@ M: unix-io process-stream* wait-for-processes [ 250 sleep ] when wait-loop ; : start-wait-thread ( -- ) - [ wait-loop ] in-thread ; + [ wait-loop ] "Process reaper" spawn drop ; diff --git a/extra/io/unix/unix-tests.factor b/extra/io/unix/unix-tests.factor index e1c3108952..4005fb6c09 100755 --- a/extra/io/unix/unix-tests.factor +++ b/extra/io/unix/unix-tests.factor @@ -18,7 +18,7 @@ IN: temporary ] with-stream "unix-domain-socket-test" resource-path delete-file -] in-thread +] "Test" spawn drop yield @@ -69,7 +69,7 @@ yield "unix-domain-datagram-test" resource-path delete-file ] with-scope -] in-thread +] "Test" spawn drop yield diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index cc3278dadc..4da8ed4046 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -4,7 +4,8 @@ USING: alien alien.c-types arrays continuations destructors io io.windows io.windows.nt.pipes libc io.nonblocking io.streams.duplex windows.types math windows.kernel32 windows namespaces io.launcher kernel sequences windows.errors assocs -splitting system threads init strings combinators io.backend ; +splitting system concurrency.threads init strings combinators +io.backend ; IN: io.windows.launcher TUPLE: CreateProcess-args @@ -150,6 +151,6 @@ M: windows-io kill-process* ( handle -- ) wait-loop ; : start-wait-thread ( -- ) - [ wait-loop ] in-thread ; + [ wait-loop ] "Process wait" spawn drop ; [ start-wait-thread ] "io.windows.launcher" add-init-hook diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index 597bc99be2..09d23e74e4 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -1,14 +1,15 @@ USING: alien alien.c-types arrays assocs combinators continuations destructors io io.backend io.nonblocking io.windows libc kernel math namespaces sequences -threads tuples.lib windows windows.errors windows.kernel32 -strings splitting io.files qualified ascii combinators.lib ; +concurrency.threads tuples.lib windows windows.errors +windows.kernel32 strings splitting io.files qualified ascii +combinators.lib ; QUALIFIED: windows.winsock IN: io.windows.nt.backend SYMBOL: io-hash -TUPLE: io-callback port continuation ; +TUPLE: io-callback port thread ; C: io-callback @@ -52,8 +53,8 @@ M: windows-nt-io add-completion ( handle -- ) [ swap dup alien? [ "bad overlapped in save-callback" throw ] unless - io-hash get-global set-at stop - ] callcc0 2drop ; + io-hash get-global set-at + ] suspend 3drop ; : wait-for-overlapped ( ms -- overlapped ? ) >r master-completion-port get-global r> ! port ms @@ -77,11 +78,11 @@ M: windows-nt-io add-completion ( handle -- ) ] [ (win32-error-string) swap lookup-callback [ io-callback-port set-port-error ] keep - ] if io-callback-continuation schedule-thread f + ] if io-callback-thread resume f ] if ] [ lookup-callback - io-callback-continuation schedule-thread f + io-callback-thread resume f ] if ; : drain-overlapped ( timeout -- ) diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index f2be11855b..d33465ae76 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -1,8 +1,8 @@ USING: continuations destructors io.buffers io.files io.backend io.timeouts io.nonblocking io.windows io.windows.nt.backend -kernel libc math threads windows windows.kernel32 alien.c-types -alien.arrays sequences combinators combinators.lib sequences.lib -ascii splitting alien strings assocs ; +kernel libc math concurrency.threads windows windows.kernel32 +alien.c-types alien.arrays sequences combinators combinators.lib +sequences.lib ascii splitting alien strings assocs ; IN: io.windows.nt.files M: windows-nt-io cwd diff --git a/extra/io/windows/nt/nt.factor b/extra/io/windows/nt/nt.factor index da7e83baca..be57a398a2 100755 --- a/extra/io/windows/nt/nt.factor +++ b/extra/io/windows/nt/nt.factor @@ -12,3 +12,5 @@ USE: io.windows.mmap USE: io.backend T{ windows-nt-io } set-io-backend + +"vocabs.monitor" require diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor index eef7476dd5..9f82350f54 100755 --- a/extra/io/windows/nt/sockets/sockets.factor +++ b/extra/io/windows/nt/sockets/sockets.factor @@ -2,7 +2,7 @@ USING: alien alien.accessors alien.c-types byte-arrays continuations destructors io.nonblocking io.timeouts io.sockets io.sockets.impl io namespaces io.streams.duplex io.windows io.windows.nt.backend windows.winsock kernel libc math sequences -threads tuples.lib ; +concurrency.threads tuples.lib ; IN: io.windows.nt.sockets : malloc-int ( object -- object ) diff --git a/extra/tools/interpreter/interpreter.factor b/extra/tools/interpreter/interpreter.factor index 02c0af89ac..17a3412e93 100755 --- a/extra/tools/interpreter/interpreter.factor +++ b/extra/tools/interpreter/interpreter.factor @@ -3,7 +3,8 @@ USING: arrays assocs classes combinators sequences.private continuations continuations.private generic hashtables io kernel kernel.private math namespaces namespaces.private prettyprint -quotations sequences splitting strings threads vectors words ; +quotations sequences splitting strings concurrency.threads +vectors words ; IN: tools.interpreter : walk ( quot -- ) \ break add* call ; diff --git a/extra/tools/threads/threads.factor b/extra/tools/threads/threads.factor new file mode 100755 index 0000000000..0690042a3e --- /dev/null +++ b/extra/tools/threads/threads.factor @@ -0,0 +1,22 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: tools.threads +USING: concurrency.threads kernel prettyprint prettyprint.config +io io.styles sequences assocs namespaces sorting ; + +: thread. ( thread -- ) + dup thread-id pprint-cell + dup thread-name pprint-cell + thread-continuation "Waiting" "Running" ? [ write ] with-cell ; + +: threads. ( -- ) + standard-table-style [ + [ + { "ID" "Name" "State" } + [ [ write ] with-cell ] each + ] with-row + + threads get-global >alist sort-keys values [ + [ thread. ] with-row + ] each + ] tabular-output ; diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor index e667b1206b..791b68246b 100755 --- a/extra/ui/tools/interactor/interactor.factor +++ b/extra/ui/tools/interactor/interactor.factor @@ -3,20 +3,20 @@ USING: arrays assocs combinators continuations documents ui.tools.workspace hashtables io io.styles kernel math math.vectors models namespaces parser prettyprint quotations -sequences sequences.lib strings threads listener tuples -ui.commands ui.gadgets ui.gadgets.editors +sequences sequences.lib strings concurrency.threads listener +tuples ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.presentations ui.gadgets.worlds ui.gestures definitions ; IN: ui.tools.interactor TUPLE: interactor history output -continuation quot busy? +thread quot busy? help ; : interactor-use ( interactor -- seq ) use swap - interactor-continuation continuation-name + interactor-thread thread-continuation continuation-name assoc-stack ; : init-caret-help ( interactor -- ) @@ -37,10 +37,6 @@ M: interactor graft* dup dup interactor-help add-connection f swap set-interactor-busy? ; -M: interactor ungraft* - dup dup interactor-help remove-connection - delegate ungraft* ; - : word-at-loc ( loc interactor -- word ) over [ [ gadget-model T{ one-word-elt } elt-string ] keep @@ -70,7 +66,7 @@ M: interactor model-changed : interactor-continue ( obj interactor -- ) t over set-interactor-busy? - interactor-continuation schedule-thread-with ; + interactor-thread resume-with ; : clear-input ( interactor -- ) gadget-model clear-doc ; @@ -88,14 +84,16 @@ M: interactor model-changed : evaluate-input ( interactor -- ) dup interactor-busy? [ - [ - [ control-value ] keep interactor-continue - ] in-thread + dup control-value over interactor-continue ] unless drop ; : interactor-yield ( interactor -- obj ) - f over set-interactor-busy? - [ set-interactor-continuation stop ] curry callcc1 ; + dup gadget-graft-state first [ + f over set-interactor-busy? + [ set-interactor-thread ] curry suspend + ] [ + drop f + ] if ; M: interactor stream-readln [ interactor-yield ] keep interactor-finish ?first ; diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor index 3a3ba5f1af..0f6a45de52 100755 --- a/extra/ui/tools/listener/listener.factor +++ b/extra/ui/tools/listener/listener.factor @@ -6,7 +6,7 @@ kernel models namespaces parser quotations sequences ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.labelled ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.operations vocabs words -prettyprint listener debugger threads ; +prettyprint listener debugger concurrency.threads ; IN: ui.tools.listener TUPLE: listener-gadget input output stack ; @@ -134,8 +134,7 @@ M: stack-display tool-scroller ] with-stream* ; : restart-listener ( listener -- ) - [ >r clear r> init-namespaces listener-thread ] in-thread - drop ; + [ listener-thread ] curry "Listener" spawn drop ; : init-listener ( listener -- ) f swap set-listener-gadget-stack ; diff --git a/extra/ui/tools/walker/walker.factor b/extra/ui/tools/walker/walker.factor index a23345d214..e80d87d591 100755 --- a/extra/ui/tools/walker/walker.factor +++ b/extra/ui/tools/walker/walker.factor @@ -2,10 +2,11 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs ui.tools.listener ui.tools.traceback ui.tools.workspace inspector kernel models namespaces -prettyprint quotations sequences threads tools.interpreter -ui.commands ui.gadgets ui.gadgets.labelled ui.gadgets.tracks -ui.gestures ui.gadgets.buttons ui.gadgets.panes -prettyprint.config prettyprint.backend continuations ; +prettyprint quotations sequences concurrency.threads +tools.interpreter ui.commands ui.gadgets ui.gadgets.labelled +ui.gadgets.tracks ui.gestures ui.gadgets.buttons +ui.gadgets.panes prettyprint.config prettyprint.backend +continuations ; IN: ui.tools.walker TUPLE: walker model interpreter history ; diff --git a/extra/ui/ui.factor b/extra/ui/ui.factor index c214eee8d5..c38ce2b44a 100755 --- a/extra/ui/ui.factor +++ b/extra/ui/ui.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2006, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs io kernel math models namespaces -prettyprint dlists sequences threads sequences words timers -debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks -ui.gestures ui.backend ui.render continuations init -combinators hashtables ; +prettyprint dlists sequences concurrency.threads sequences words +timers debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks +ui.gestures ui.backend ui.render continuations init combinators +hashtables ; IN: ui ! Assoc mapping aliens to gadgets diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index c831a959d0..4f5b9bd6a8 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -4,10 +4,10 @@ USING: alien alien.c-types arrays assocs ui ui.gadgets ui.backend ui.clipboards ui.gadgets.worlds ui.gestures io kernel math math.vectors namespaces prettyprint sequences strings vectors words windows.kernel32 windows.gdi32 windows.user32 -windows.opengl32 windows.messages windows.types -windows.nt windows threads timers libc combinators continuations -command-line shuffle opengl ui.render unicode.case ascii -math.bitfields ; +windows.opengl32 windows.messages windows.types windows.nt +windows concurrency.threads timers libc combinators +continuations command-line shuffle opengl ui.render unicode.case +ascii math.bitfields ; IN: ui.windows TUPLE: windows-ui-backend ; diff --git a/extra/vocabs/monitor/monitor.factor b/extra/vocabs/monitor/monitor.factor index e5b9a8c3a1..f22002ee6a 100755 --- a/extra/vocabs/monitor/monitor.factor +++ b/extra/vocabs/monitor/monitor.factor @@ -1,18 +1,18 @@ -USING: threads io.files io.monitors init kernel tools.browser -continuations ; +USING: concurrency.threads io.files io.monitors init kernel +tools.browser ; IN: vocabs.monitor ! Use file system change monitoring to flush the tags/authors ! cache -: update-thread ( monitor -- ) - dup next-change 2drop reset-cache update-thread ; +: (monitor-thread) ( monitor -- ) + dup next-change 2drop reset-cache (monitor-thread) ; -: start-update-thread +: monitor-thread ( -- ) + "" resource-path t (monitor-thread) ; + +: start-monitor-thread #! Silently ignore errors during monitor creation since #! monitors are not supported on all platforms. - [ - [ "" resource-path t ] [ drop f ] recover - [ update-thread ] when* - ] in-thread ; + [ monitor-thread ] "Vocabulary monitor" spawn drop ; -[ start-update-thread ] "tools.browser" add-init-hook +[ start-monitor-thread ] "vocabs.monitor" add-init-hook diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index 3e008d049d..456855c1fa 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -100,7 +100,7 @@ SYMBOL: last-update : update-thread ( -- ) millis last-update set-global - [ update-cached-postings ] in-thread + [ update-cached-postings ] "RSS feed update slave" spawn drop 10 60 * 1000 * sleep update-thread ; @@ -109,7 +109,7 @@ SYMBOL: last-update "webapps.planet" [ update-thread ] with-logging - ] in-thread ; + ] "RSS feed update master" spawn drop ; "planet" "planet-factor" "extra/webapps/planet" web-app diff --git a/vm/run.h b/vm/run.h index 86cf1c0e1f..1fcb4bedb4 100755 --- a/vm/run.h +++ b/vm/run.h @@ -1,4 +1,4 @@ -#define USER_ENV 40 +#define USER_ENV 64 typedef enum { NAMESTACK_ENV, /* used by library only */ @@ -54,7 +54,9 @@ typedef enum { STDERR_ENV = 38, /* stderr FILE* handle */ - STAGE2_ENV = 39 /* have we bootstrapped? */ + STAGE2_ENV = 39, /* have we bootstrapped? */ + + CURRENT_THREAD_ENV = 40 } F_ENVTYPE; #define FIRST_SAVE_ENV BOOT_ENV From 9edb5875e3ffc62013f48d61dfc8aea1fbdb9b3b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 18 Feb 2008 07:30:16 -0600 Subject: [PATCH 2/7] Less drastic changes --- core/alien/compiler/compiler.factor | 4 +- .../remote-control/remote-control.factor | 4 +- core/compiler/compiler.factor | 4 +- core/generator/generator.factor | 2 +- core/io/thread/thread.factor | 8 +- core/{concurrency => }/threads/authors.txt | 0 core/{concurrency => }/threads/summary.txt | 0 .../threads/threads-docs.factor | 8 +- .../threads/threads-tests.factor | 2 +- core/{concurrency => }/threads/threads.factor | 16 ++- extra/alarms/alarms.factor | 10 +- extra/benchmark/ring/ring.factor | 6 +- extra/benchmark/sockets/sockets.factor | 4 +- extra/calendar/model/model.factor | 2 +- extra/channels/channels-tests.factor | 0 extra/channels/channels.factor | 0 extra/channels/examples/examples.factor | 10 +- extra/channels/remote/remote.factor | 9 +- extra/channels/sniffer/bsd/bsd.factor | 11 +- extra/cocoa/application/application.factor | 4 +- .../distributed/distributed-docs.factor | 16 +-- .../distributed/distributed.factor | 2 +- .../concurrency/exchangers/exchangers.factor | 2 +- extra/concurrency/locks/locks.factor | 2 +- .../messaging/messaging-docs.factor | 109 ++++++------------ .../messaging/messaging-tests.factor | 2 +- extra/concurrency/messaging/messaging.factor | 23 ++-- extra/crypto/random.factor | 2 +- extra/io/launcher/launcher.factor | 2 +- extra/io/monitors/monitors.factor | 2 +- extra/io/server/server.factor | 10 +- extra/io/sockets/sockets-docs.factor | 2 +- extra/io/timeouts/timeouts.factor | 2 +- extra/io/unix/backend/backend.factor | 7 +- extra/io/unix/bsd/bsd.factor | 4 +- extra/io/unix/kqueue/kqueue.factor | 3 +- extra/io/unix/launcher/launcher.factor | 6 +- extra/io/unix/linux/linux.factor | 4 +- extra/io/unix/sockets/sockets.factor | 10 +- extra/io/unix/unix-tests.factor | 6 +- extra/io/windows/launcher/launcher.factor | 7 +- extra/io/windows/nt/backend/backend.factor | 2 +- extra/io/windows/nt/files/files.factor | 2 +- extra/io/windows/nt/sockets/sockets.factor | 2 +- extra/logging/logging.factor | 2 +- extra/logging/server/server.factor | 21 ++-- extra/pack/pack.factor | 2 +- extra/space-invaders/space-invaders.factor | 9 +- extra/tools/interpreter/interpreter.factor | 2 +- extra/tools/threads/threads.factor | 2 +- extra/ui/tools/interactor/interactor.factor | 12 +- extra/ui/tools/listener/listener.factor | 2 +- extra/ui/tools/walker/walker.factor | 2 +- extra/ui/ui.factor | 2 +- extra/ui/windows/windows.factor | 2 +- extra/vocabs/monitor/monitor.factor | 16 ++- extra/webapps/planet/planet.factor | 8 +- 57 files changed, 192 insertions(+), 223 deletions(-) rename core/{concurrency => }/threads/authors.txt (100%) rename core/{concurrency => }/threads/summary.txt (100%) rename core/{concurrency => }/threads/threads-docs.factor (97%) rename core/{concurrency => }/threads/threads-tests.factor (85%) rename core/{concurrency => }/threads/threads.factor (93%) mode change 100644 => 100755 extra/alarms/alarms.factor mode change 100644 => 100755 extra/benchmark/ring/ring.factor mode change 100644 => 100755 extra/channels/channels-tests.factor mode change 100644 => 100755 extra/channels/channels.factor mode change 100644 => 100755 extra/channels/remote/remote.factor mode change 100644 => 100755 extra/channels/sniffer/bsd/bsd.factor mode change 100644 => 100755 extra/cocoa/application/application.factor mode change 100644 => 100755 extra/concurrency/distributed/distributed-docs.factor mode change 100644 => 100755 extra/concurrency/messaging/messaging-docs.factor mode change 100644 => 100755 extra/crypto/random.factor mode change 100644 => 100755 extra/pack/pack.factor diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index 24408e1e20..48e8d7e307 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -5,8 +5,8 @@ hashtables kernel math namespaces sequences words inference.state inference.backend inference.dataflow system math.parser classes alien.arrays alien.c-types alien.structs alien.syntax cpu.architecture alien inspector quotations assocs -kernel.private concurrency.threads continuations.private libc -combinators compiler.errors continuations ; +kernel.private threads continuations.private libc combinators +compiler.errors continuations ; IN: alien.compiler ! Common protocol for alien-invoke/alien-callback/alien-indirect diff --git a/core/alien/remote-control/remote-control.factor b/core/alien/remote-control/remote-control.factor index f3c84119bf..b7700c0ff1 100755 --- a/core/alien/remote-control/remote-control.factor +++ b/core/alien/remote-control/remote-control.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types parser concurrency.threads words -kernel.private kernel ; +USING: alien alien.c-types parser threads words kernel.private +kernel ; IN: alien.remote-control : eval-callback diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index 3f06f85d10..f0caec7ad1 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -3,8 +3,8 @@ USING: kernel namespaces arrays sequences io inference.backend inference.state generator debugger math.parser prettyprint words compiler.units continuations vocabs assocs alien.compiler dlists -optimizer definitions math compiler.errors concurrency.threads -graphs generic ; +optimizer definitions math compiler.errors threads graphs +generic ; IN: compiler : compiled-usages ( words -- seq ) diff --git a/core/generator/generator.factor b/core/generator/generator.factor index c62fc9f8a2..3514947e3d 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -5,7 +5,7 @@ effects generator.fixup generator.registers generic hashtables inference inference.backend inference.dataflow io kernel kernel.private layouts math namespaces optimizer optimizer.specializers prettyprint quotations sequences system -concurrency.threads words vectors ; +threads words vectors ; IN: generator SYMBOL: compile-queue diff --git a/core/io/thread/thread.factor b/core/io/thread/thread.factor index ec118dcbf7..53ab5193c6 100755 --- a/core/io/thread/thread.factor +++ b/core/io/thread/thread.factor @@ -1,14 +1,14 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: io.thread -USING: concurrency.threads io.backend namespaces init ; +USING: threads io.backend namespaces init ; : io-thread ( -- ) - sleep-time io-multiplex yield io-thread ; + sleep-time io-multiplex yield ; : start-io-thread ( -- ) - [ io-thread ] - "I/O wait" spawn + [ io-thread t ] + "I/O wait" spawn-server \ io-thread set-global ; [ start-io-thread ] "io.thread" add-init-hook diff --git a/core/concurrency/threads/authors.txt b/core/threads/authors.txt similarity index 100% rename from core/concurrency/threads/authors.txt rename to core/threads/authors.txt diff --git a/core/concurrency/threads/summary.txt b/core/threads/summary.txt similarity index 100% rename from core/concurrency/threads/summary.txt rename to core/threads/summary.txt diff --git a/core/concurrency/threads/threads-docs.factor b/core/threads/threads-docs.factor similarity index 97% rename from core/concurrency/threads/threads-docs.factor rename to core/threads/threads-docs.factor index 53acb40794..0a9e1b0bac 100755 --- a/core/concurrency/threads/threads-docs.factor +++ b/core/threads/threads-docs.factor @@ -1,7 +1,7 @@ USING: help.markup help.syntax kernel kernel.private io -concurrency.threads.private continuations dlists init -quotations strings assocs heaps ; -IN: concurrency.threads +threads.private continuations dlists init quotations strings +assocs heaps ; +IN: threads ARTICLE: "threads-start/stop" "Starting and stopping threads" "Spawning new threads:" @@ -44,7 +44,7 @@ ARTICLE: "thread-impl" "Thread implementation" ARTICLE: "threads" "Lightweight co-operative threads" "Factor supports lightweight co-operative threads implemented on top of continuations. A thread will yield while waiting for I/O operations to complete, or when a yield has been explicitly requested." $nl -"Words for working with threads are in the " { $vocab-link "concurrency.threads" } " vocabulary." +"Words for working with threads are in the " { $vocab-link "threads" } " vocabulary." { $subsection "threads-start/stop" } { $subsection "threads-yield" } { $subsection "thread-state" } diff --git a/core/concurrency/threads/threads-tests.factor b/core/threads/threads-tests.factor similarity index 85% rename from core/concurrency/threads/threads-tests.factor rename to core/threads/threads-tests.factor index 2bd7e8aa4c..49139a7807 100755 --- a/core/concurrency/threads/threads-tests.factor +++ b/core/threads/threads-tests.factor @@ -1,4 +1,4 @@ -USING: namespaces io tools.test concurrency.threads kernel ; +USING: namespaces io tools.test threads kernel ; IN: temporary 3 "x" set diff --git a/core/concurrency/threads/threads.factor b/core/threads/threads.factor similarity index 93% rename from core/concurrency/threads/threads.factor rename to core/threads/threads.factor index 1a11a00b82..04487e16b4 100755 --- a/core/concurrency/threads/threads.factor +++ b/core/threads/threads.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! Copyright (C) 2005 Mackenzie Straight. ! See http://factorcode.org/license.txt for BSD license. -IN: concurrency.threads +IN: threads USING: arrays hashtables heaps kernel kernel.private math namespaces sequences vectors continuations continuations.private dlists assocs system combinators debugger prettyprint io init ; @@ -53,6 +53,8 @@ threads global [ H{ } assoc-like ] change-at : set-self ( thread -- ) 40 setenv ; inline +PRIVATE> + : ( quot name error-handler -- thread ) \ thread counter H{ } clone { set-thread-quot @@ -62,8 +64,6 @@ threads global [ H{ } assoc-like ] change-at set-thread-variables } \ thread construct ; -PRIVATE> - SYMBOL: run-queue SYMBOL: sleep-queue @@ -149,7 +149,13 @@ PRIVATE> ] [ (spawn) ] keep ; -: in-thread ( quot -- ) "Thread" spawn drop ; +: spawn-server ( quot name -- thread ) + >r [ [ ] [ ] while ] curry r> spawn ; + +: in-thread ( quot -- ) + >r datastack namestack r> + [ >r set-namestack set-datastack r> call ] 3curry + "Thread" spawn drop ; -[ init-threads ] "concurrency.threads" add-init-hook +[ init-threads ] "threads" add-init-hook diff --git a/extra/alarms/alarms.factor b/extra/alarms/alarms.factor old mode 100644 new mode 100755 index 4540b7b2aa..40eda02fac --- a/extra/alarms/alarms.factor +++ b/extra/alarms/alarms.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays calendar combinators concurrency generic -init kernel math namespaces sequences threads ; +USING: arrays calendar combinators concurrency.messaging +threads generic init kernel math namespaces sequences ; IN: alarms TUPLE: alarm time quot ; @@ -36,7 +36,7 @@ SYMBOL: alarm-looper [ alarm-time <=> 0 <= ] with subset ; : call-alarm ( alarm -- ) - alarm-quot spawn drop ; + alarm-quot "Alarm invocation" spawn drop ; : do-alarms ( -- ) expired-alarms [ call-alarm ] each @@ -49,7 +49,7 @@ SYMBOL: alarm-looper : start-alarm-receiver ( -- ) [ alarm-receive-loop - ] spawn alarm-receiver set-global ; + ] "Alarm receiver" spawn alarm-receiver set-global ; : alarm-loop ( -- ) alarms get-global empty? [ @@ -59,7 +59,7 @@ SYMBOL: alarm-looper : start-alarm-looper ( -- ) [ alarm-loop - ] spawn alarm-looper set-global ; + ] "Alarm looper" spawn alarm-looper set-global ; : send-alarm ( str alarm -- ) over set-delegate diff --git a/extra/benchmark/ring/ring.factor b/extra/benchmark/ring/ring.factor old mode 100644 new mode 100755 index b0d02c4239..f1b7d6c9cc --- a/extra/benchmark/ring/ring.factor +++ b/extra/benchmark/ring/ring.factor @@ -1,4 +1,5 @@ -USING: concurrency kernel tools.time math sequences ; +USING: threads concurrency.messaging kernel +tools.time math sequences ; IN: benchmark.ring SYMBOL: done @@ -7,7 +8,7 @@ SYMBOL: done receive 2dup swap send done eq? [ tunnel ] unless ; : create-ring ( processes -- target ) - self swap [ [ tunnel ] spawn nip ] times ; + self swap [ [ tunnel ] "Tunnel" spawn nip ] times ; : send-messages ( messages target -- ) dupd [ send ] curry each [ receive drop ] times ; @@ -22,4 +23,3 @@ SYMBOL: done 1000 1000 ring-bench ; MAIN: main-ring-bench - diff --git a/extra/benchmark/sockets/sockets.factor b/extra/benchmark/sockets/sockets.factor index a621331968..40012e1638 100755 --- a/extra/benchmark/sockets/sockets.factor +++ b/extra/benchmark/sockets/sockets.factor @@ -1,5 +1,5 @@ -USING: io.sockets io.server io kernel math threads debugger -concurrency tools.time prettyprint ; +USING: io.sockets io.server io kernel math threads +debugger tools.time prettyprint ; IN: benchmark.sockets : simple-server ( -- ) diff --git a/extra/calendar/model/model.factor b/extra/calendar/model/model.factor index 61ab191b75..be98c7491e 100755 --- a/extra/calendar/model/model.factor +++ b/extra/calendar/model/model.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: calendar namespaces models concurrency.threads init ; +USING: calendar namespaces models threads init ; IN: calendar.model SYMBOL: time diff --git a/extra/channels/channels-tests.factor b/extra/channels/channels-tests.factor old mode 100644 new mode 100755 diff --git a/extra/channels/channels.factor b/extra/channels/channels.factor old mode 100644 new mode 100755 diff --git a/extra/channels/examples/examples.factor b/extra/channels/examples/examples.factor index 87b755614a..dda2a4921b 100755 --- a/extra/channels/examples/examples.factor +++ b/extra/channels/examples/examples.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. ! ! Examples of using channels -USING: kernel concurrency channels math namespaces locals -sequences ; +USING: kernel threads channels math namespaces +locals sequences ; IN: channels.examples : (counter) ( channel n -- ) @@ -13,7 +13,7 @@ IN: channels.examples 2 (counter) ; : counter-test ( -- n1 n2 n3 ) - [ counter ] spawn drop + dup [ counter ] curry "Counter" spawn drop [ from ] keep [ from ] keep from ; : filter ( send prime recv -- ) @@ -34,11 +34,11 @@ IN: channels.examples : sieve ( prime -- ) #! Send prime numbers to 'prime' channel - [ counter ] spawn drop + dup [ counter ] curry "Counter" spawn drop (sieve) ; : sieve-test ( -- seq ) - [ sieve ] spawn drop + dup [ sieve ] curry "Sieve" spawn drop V{ } clone swap [ from swap push ] 2keep [ from swap push ] 2keep diff --git a/extra/channels/remote/remote.factor b/extra/channels/remote/remote.factor old mode 100644 new mode 100755 index 4f483b8775..40a6df350b --- a/extra/channels/remote/remote.factor +++ b/extra/channels/remote/remote.factor @@ -3,7 +3,8 @@ ! ! Remote Channels USING: kernel init namespaces assocs arrays random -sequences channels match concurrency concurrency.distributed ; +sequences channels match concurrency.messaging +concurrency.distributed ; IN: channels.remote : start-channel-node ( -- ) - "remote-channels" get-process [ - [ channel-process ] spawn "remote-channels" swap register-process + "remote-channels" get-process [ + "remote-channels" + [ channel-process ] "Remote channels" spawn + register-process ] unless ; TUPLE: remote-channel node id ; diff --git a/extra/channels/sniffer/bsd/bsd.factor b/extra/channels/sniffer/bsd/bsd.factor old mode 100644 new mode 100755 index 0ba267bb03..f986f11484 --- a/extra/channels/sniffer/bsd/bsd.factor +++ b/extra/channels/sniffer/bsd/bsd.factor @@ -2,12 +2,15 @@ ! See http://factorcode.org/license.txt for BSD license. ! ! Wrap a sniffer in a channel -USING: kernel channels channels.sniffer.backend concurrency io -io.sniffer.backend io.sniffer.bsd io.unix.backend ; +USING: kernel channels channels.sniffer.backend +threads io io.sniffer.backend io.sniffer.bsd +io.unix.backend ; IN: channels.sniffer.bsd M: unix-io sniff-channel ( -- channel ) "/dev/bpf0" "en1" [ - (sniff-channel) - ] spawn drop nip ; + [ + (sniff-channel) + ] 3curry spawn drop + ] keep ; diff --git a/extra/cocoa/application/application.factor b/extra/cocoa/application/application.factor old mode 100644 new mode 100755 index 709d318e63..0cf020a087 --- a/extra/cocoa/application/application.factor +++ b/extra/cocoa/application/application.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2006, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: alien io kernel namespaces core-foundation cocoa.messages -cocoa cocoa.classes cocoa.runtime sequences threads debugger -init inspector kernel.private ; +cocoa cocoa.classes cocoa.runtime sequences threads +debugger init inspector kernel.private ; IN: cocoa.application : ( str -- alien ) -> autorelease ; diff --git a/extra/concurrency/distributed/distributed-docs.factor b/extra/concurrency/distributed/distributed-docs.factor old mode 100644 new mode 100755 index 23af641600..8f82d1aebf --- a/extra/concurrency/distributed/distributed-docs.factor +++ b/extra/concurrency/distributed/distributed-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax concurrency ; +USING: help.markup help.syntax concurrency.messaging ; IN: concurrency.distributed HELP: @@ -7,19 +7,9 @@ HELP: { "remote-process" "the constructed remote-process object" } } { $description "Constructs a proxy to a process running on another node. It can be used to send messages to the process it is acting as a proxy for." } -{ $see-also spawn send } ; - - -HELP: -{ $values { "hostname" "the hostname of the node as a string" } - { "port" "the integer port number of the node" } - { "node" "the constructed node object" } -} -{ $description "Processes run on nodes. Each node has a hostname and a port." } -{ $see-also localnode } ; +{ $see-also spawn send } ; HELP: localnode { $values { "node" "a node object" } } -{ $description "Return the node the process is currently running on." } -{ $see-also } ; +{ $description "Return the node the process is currently running on." } ; diff --git a/extra/concurrency/distributed/distributed.factor b/extra/concurrency/distributed/distributed.factor index 042c33306e..30587b35ac 100755 --- a/extra/concurrency/distributed/distributed.factor +++ b/extra/concurrency/distributed/distributed.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005 Chris Double. All Rights Reserved. ! See http://factorcode.org/license.txt for BSD license. USING: serialize sequences concurrency.messaging -concurrency.threads io io.server qualified arrays +threads io io.server qualified arrays namespaces kernel ; QUALIFIED: io.sockets IN: concurrency.distributed diff --git a/extra/concurrency/exchangers/exchangers.factor b/extra/concurrency/exchangers/exchangers.factor index 39f01ae2ca..e2c701c7a9 100755 --- a/extra/concurrency/exchangers/exchangers.factor +++ b/extra/concurrency/exchangers/exchangers.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel concurrency.threads ; +USING: kernel threads ; IN: concurrency.exchangers ! Motivated by diff --git a/extra/concurrency/locks/locks.factor b/extra/concurrency/locks/locks.factor index 182bf0a106..3a792768a7 100755 --- a/extra/concurrency/locks/locks.factor +++ b/extra/concurrency/locks/locks.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: dlists kernel concurrency.threads continuations math ; +USING: dlists kernel threads continuations math ; IN: concurrency.locks ! Simple critical sections diff --git a/extra/concurrency/messaging/messaging-docs.factor b/extra/concurrency/messaging/messaging-docs.factor old mode 100644 new mode 100755 index 16a2e65a90..a22014a106 --- a/extra/concurrency/messaging/messaging-docs.factor +++ b/extra/concurrency/messaging/messaging-docs.factor @@ -1,93 +1,80 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: help.syntax help.markup concurrency.private match ; -IN: concurrency +USING: help.syntax help.markup concurrency.messaging.private +threads ; +IN: concurrency.messaging -HELP: make-mailbox -{ $values { "mailbox" "a mailbox object" } +HELP: +{ $values { "mailbox" mailbox } } { $description "A mailbox is an object that can be used for safe thread communication. Items can be put in the mailbox and retrieved in a FIFO order. If the mailbox is empty when a get operation is performed then the thread will block until another thread places something in the mailbox. If multiple threads are waiting on the same mailbox, only one of the waiting threads will be unblocked to process the get operation." } { $see-also mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ; HELP: mailbox-empty? -{ $values { "mailbox" "a mailbox object" } - { "bool" "a boolean value" } +{ $values { "mailbox" mailbox } + { "bool" "a boolean" } } { $description "Return true if the mailbox is empty." } -{ $see-also make-mailbox mailbox-put mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ; +{ $see-also mailbox-put mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ; HELP: mailbox-put { $values { "obj" "an object" } - { "mailbox" "a mailbox object" } + { "mailbox" mailbox } } { $description "Put the object into the mailbox. Any threads that have a blocking get on the mailbox are resumed. Only one of those threads will successfully get the object, the rest will immediately block waiting for the next item in the mailbox." } -{ $see-also make-mailbox mailbox-empty? mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ; +{ $see-also mailbox-empty? mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ; -HELP: (mailbox-block-unless-pred) +HELP: block-unless-pred { $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } } - { "mailbox" "a mailbox object" } + { "mailbox" mailbox } { "timeout" "a timeout in milliseconds" } } -{ $description "Block the thread if there are no items in the mailbox that return true when the predicate is called with the item on the stack. The predicate must have stack effect " { $snippet "( X -- bool )" } "." } -{ $see-also make-mailbox mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ; +{ $description "Block the thread if there are no items in the mailbox that return true when the predicate is called with the item on the stack." } +{ $see-also mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ; -HELP: (mailbox-block-if-empty) -{ $values { "mailbox" "a mailbox object" } +HELP: block-if-empty +{ $values { "mailbox" mailbox } { "mailbox2" "same object as 'mailbox'" } { "timeout" "a timeout in milliseconds" } } { $description "Block the thread if the mailbox is empty." } -{ $see-also make-mailbox mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ; +{ $see-also mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ; HELP: mailbox-get -{ $values { "mailbox" "a mailbox object" } +{ $values { "mailbox" mailbox } { "obj" "an object" } } { $description "Get the first item put into the mailbox. If it is empty the thread blocks until an item is put into it. The thread then resumes, leaving the item on the stack." } -{ $see-also make-mailbox mailbox-empty? mailbox-put while-mailbox-empty mailbox-get-all mailbox-get? } ; +{ $see-also mailbox-empty? mailbox-put while-mailbox-empty mailbox-get-all mailbox-get? } ; HELP: mailbox-get-all -{ $values { "mailbox" "a mailbox object" } +{ $values { "mailbox" mailbox } { "array" "an array" } } { $description "Blocks the thread if the mailbox is empty, otherwise removes all objects in the mailbox and returns an array containing the objects." } -{ $see-also make-mailbox mailbox-empty? mailbox-put while-mailbox-empty mailbox-get-all mailbox-get? } ; +{ $see-also mailbox-empty? mailbox-put while-mailbox-empty mailbox-get-all mailbox-get? } ; HELP: while-mailbox-empty -{ $values { "mailbox" "a mailbox object" } +{ $values { "mailbox" mailbox } { "quot" "a quotation with stack effect " { $snippet "( -- )" } } } -{ $description "Repeatedly call the quotation while there are no items in the mailbox. Quotation should have stack effect " { $snippet "( -- )" } "." } -{ $see-also make-mailbox mailbox-empty? mailbox-put mailbox-get mailbox-get-all mailbox-get? } ; +{ $description "Repeatedly call the quotation while there are no items in the mailbox." } +{ $see-also mailbox-empty? mailbox-put mailbox-get mailbox-get-all mailbox-get? } ; HELP: mailbox-get? { $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } } - { "mailbox" "a mailbox object" } + { "mailbox" mailbox } { "obj" "an object" } } -{ $description "Get the first item in the mailbox which satisfies the predicate. 'pred' will be called repeatedly for each item in the mailbox. When 'pred' returns true that item will be returned. If nothing in the mailbox satisfies the predicate then the thread will block until something does. 'pred' must have stack effect " { $snippet "( X -- bool }" } "." } -{ $see-also make-mailbox mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty } ; - -HELP: -{ $values { "links" "an array of processes" } - { "pid" "the process id" } - { "mailbox" "a mailbox object" } -} -{ $description "Constructs a process object. A process is a lightweight thread with a mailbox that can be used to communicate with other processes. Each process has a unique process id." } -{ $see-also spawn send receive } ; - -HELP: self -{ $values { "process" "a process object" } -} -{ $description "Returns the currently running process object." } -{ $see-also send receive receive-if } ; +{ $description "Get the first item in the mailbox which satisfies the predicate. 'pred' will be called repeatedly for each item in the mailbox. When 'pred' returns true that item will be returned. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } +{ $see-also mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty } ; HELP: send { $values { "message" "an object" } { "process" "a process object" } } { $description "Send the message to the process by placing it in the processes mailbox. This is an asynchronous operation and will return immediately. The receving process will act on the message the next time it retrieves that item from its mailbox (usually using the " { $link receive } " word. The message can be any Factor object. For destinations that are instances of remote-process the message must be a serializable Factor type." } -{ $see-also receive receive-if } ; +{ $see-also receive receive-if } ; HELP: receive { $values { "message" "an object" } @@ -99,27 +86,16 @@ HELP: receive-if { $values { "pred" "a predicate with stack effect " { $snippet "( X -- bool )" } } { "message" "an object" } } -{ $description "Return the first message from the current processes mailbox that satisfies the predicate. To satisfy the predicate, 'pred' is called with the item on the stack and the predicate should leave a boolean indicating whether it was satisfied or not. The predicate must have stack effect " { $snippet "( X -- bool )" } ". If nothing in the mailbox satisfies the predicate then the process will block until something does." } +{ $description "Return the first message from the current processes mailbox that satisfies the predicate. To satisfy the predicate, 'pred' is called with the item on the stack and the predicate should leave a boolean indicating whether it was satisfied or not. If nothing in the mailbox satisfies the predicate then the process will block until something does." } { $see-also send receive } ; -HELP: spawn -{ $values { "quot" "a predicate with stack effect " { $snippet "( -- )" } } - { "process" "a process object" } -} -{ $description "Start a process which runs the given quotation." } -{ $see-also send receive receive-if self spawn-link } ; - -HELP: spawn-link +HELP: spawn-linked { $values { "quot" "a predicate with stack effect " { $snippet "( -- )" } } { "process" "a process object" } } { $description "Start a process which runs the given quotation. If that quotation throws an error which is not caught then the error will get propagated to the process that spawned it. This can be used to set up 'supervisor' processes that restart child processes that crash due to uncaught errors.\n" } { $see-also spawn } ; -ARTICLE: { "concurrency" "loading" } "Loading" -"The Factor module system can be used to load the Concurrency library:" -{ $code "USING: concurrency ;" } ; - ARTICLE: { "concurrency" "processes" } "Processes" "A process is basically a thread with a message queue. Other processes can place items on this queue by sending the process a message. A process can check its queue for messages, blocking if none are pending, and process them as they are queued.\n\nFactor processes are very lightweight. Each process can take as little as 900 bytes of memory. This library has been tested running hundreds of thousands of simple processes.\n\nThe messages that are sent from process to process are any Factor value. Factor tuples are ideal for this sort of thing as you can send a tuple to a process and the predicate dispatch mechanism can be used to perform actions depending on what the type of the tuple is.\n\nProcesses are usually created using " { $link spawn } ". This word takes a quotation on the stack and starts a process that will execute that quotation asynchronously. When the quotation completes the process will die. 'spawn' leaves on the stack the process object that was started. This object can be used to send messages to the process using " { $link send } ".\n\n'send' will return immediately after placing the message in the target processes message queue.\n\nA process can get a message from its queue using " { $link receive } ". This will get the most recent message and leave it on the stack. If there are no messages in the queue the process will 'block' until a message is available. When a process is blocked it takes no CPU time at all." { $code "[ receive print ] spawn\n\"Hello Process!\" swap send" } @@ -130,14 +106,9 @@ ARTICLE: { "concurrency" "self" } "Self" "A process can get access to its own process object using " { $link self } " so it can pass it to other processes. This allows the other processes to send messages back. A simple example of using this gets the current process' 'self' and spawns a process which sends a message to it. We then receive the message from the original process:" { $code "self [ \"Hello!\" swap send ] spawn 2drop receive .\n => \"Hello!\"" } ; -ARTICLE: { "concurrency" "servers" } "Servers" -"A common idiom is to create 'server' processes that act on messages that are sent to it. These follow a basic pattern of blocking until a message is received, processing that message then looping back to blocking for a message.\n\nThe following example shows a very simple server that expects an array as its message. The first item of the array should be the senders process object. If the second item is 'ping' then the server sends 'pong' back to the caller. If the second item is anything else then the server exits:" -{ $code ": pong-server ( -- )\n receive {\n { { ?from \"ping\" } [ \"pong\" ?from send pong-server ] }\n { { ?from _ } [ \"server shutdown\" ?from send ] }\n } match-cond ;\n\n[ pong-server ] spawn" } -"Handling the deconstructing of messages and dispatching based on the message can be a bit of a chore. Especially in servers that take a number of different messages. The approach taken above is to use the 'match' library which allows easy deconstructing of messages using " { $link match-cond } "." ; - ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous Sends" -{ $link send } " sends a message asynchronously, and the sending process continues immediately. The 'pong server' example shown previously all sent messages to the server and waited for a reply back from the server. This pattern of synchronous sending is made easier with " { $link send-synchronous } ".\n\nThis word will send a message to the given process and immediately block until a reply is received for this particular message send. It leaves the reply on the stack. Note that it doesn't wait for just any reply, it waits for a reply specifically to this send.\n\nTo do this it wraps the requested message inside a tagged message format using " { $link tag-message } ":" -{ $code "\"My Message\" tag-message .\n => { ...from... ...tag... \"My Message\" }" } +{ $link send } " sends a message asynchronously, and the sending process continues immediately. The 'pong server' example shown previously all sent messages to the server and waited for a reply back from the server. This pattern of synchronous sending is made easier with " { $link send-synchronous } ".\n\nThis word will send a message to the given process and immediately block until a reply is received for this particular message send. It leaves the reply on the stack. Note that it doesn't wait for just any reply, it waits for a reply specifically to this send.\n\nTo do this it wraps the requested message inside a tagged message format using " { $link } ":" +{ $code "\"My Message\" .\n => T{ synchronous f \"My Message\" ...from... ...tag... }" } "The message is wrapped in array where the first item is the sending process object, the second is a unique tag, and the third is the original message. Server processes can use the 'from' to reply to the process that originally sent the message. The tag is used in the receiving server to include the value in the reply. After the send-synchronous call the current process will block waiting for a reply that has the exact same tag. In this way you can be sure that the reply you got was for the specific message sent. Here is the pong-server recoded to use 'send-synchronous':" { $code ": pong-server ( -- )\n receive {\n { { ?from ?tag \"ping\" } [ ?tag \"pong\" 2array ?from send pong-server ] }\n { { ?from _ } [ ?tag \"server shutdown\" 2array ?from send ] }\n } match-cond ;\n\n[ pong-server ] spawn \"ping\" swap send-synchronous .\n => \"pong\"" } "Notice that the code to send the reply back to the original caller wraps the reply in an array where the first item is the tag originally sent. 'send-synchronous' only returns if it receives a reply containing that specific tag." ; @@ -145,27 +116,15 @@ ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous Sends" ARTICLE: { "concurrency" "exceptions" } "Exceptions" "A process can handle exceptions using the standard Factor exception handling mechanism. If an exception is uncaught the process will terminate. For example:" { $code "[ 1 0 / \"This will not print\" print ] spawn" } -"Processes can be linked so that a parent process can receive the exception that caused the child process to terminate. In this way 'supervisor' processes can be created that are notified when child processes terminate and possibly restart them.\n\nThe easiest way to form this link is using " { $link spawn-link } ". This will create a unidirectional link, such that if an uncaught exception causes the child to terminate, the parent process can catch it:" +"Processes can be linked so that a parent process can receive the exception that caused the child process to terminate. In this way 'supervisor' processes can be created that are notified when child processes terminate and possibly restart them.\n\nThe easiest way to form this link is using " { $link spawn-linked } ". This will create a unidirectional link, such that if an uncaught exception causes the child to terminate, the parent process can catch it:" { $code "[\n [ 1 0 / \"This will not print\" print ] spawn-link drop\n receive\n] [ \"Exception caught.\" print ] recover" } "Exceptions are only raised in the parent when the parent does a " { $link receive } " or " { $link receive-if } ". This is because the exception is sent from the child to the parent as a message." ; -ARTICLE: { "concurrency" "futures" } "Futures" -"A future is a placeholder for the result of a computation that is being calculated in a process. When the process has completed the computation the future can be queried to find out the result. If the computation has not completed when the future is queried them the process will block until the result is completed. A future is created using " { $link future } ".\n\nThe quotation will be run in a spawned process, and a future object is immediately returned. This future object can be resolved using " { $link ?future } ".\n\nFutures are useful for starting calculations that take a long time to run but aren't needed until later in the process. When the process needs the value it can use '?future' to get the result or block until the result is available. For example:" -{ $code "[ 30 fib ] future\n...do stuff...\n?future" } ; - -ARTICLE: { "concurrency" "promises" } "Promises" -"A promise is similar to a future but it is not produced by calculating something in the background. It represents a promise to provide a value sometime later. A process can request the value of a promise and will block if the promise is not fulfilled. Later, another process can fulfill the promise, providing a value. All threads waiting on the promise will then resume with that value on the stack. Use " { $link } " to create a promise, " { $link fulfill } " to set it to a value, and " { $link ?promise } " to retrieve the value, or block until the promise is fulfilled:" -{ $code "\n[ ?promise \"Promise fulfilled: \" write print ] spawn drop\n[ ?promise \"Promise fulfilled: \" write print ] spawn drop\n[ ?promise \"Promise fulfilled: \" write print ] spawn drop\n\"hello\" swap fulfill\n => Promise fulfilled: hello\n Promise fulfilled: hello\n Promise fulfilled: hello" } ; - ARTICLE: { "concurrency" "concurrency" } "Concurrency" "The concurrency library is based upon the style of concurrency used in systems like Erlang and Termite. It is built on top of the standard Factor lightweight thread system.\nA concurrency oriented program is one in which multiple processes run simultaneously in a single Factor image or across multiple running Factor instances. The processes can communicate with each other by asynchronous message sends. Although processes can share data via Factor's mutable data structures it is not recommended as the use of shared state concurrency is often a cause of problems." -{ $subsection { "concurrency" "loading" } } { $subsection { "concurrency" "processes" } } { $subsection { "concurrency" "self" } } -{ $subsection { "concurrency" "servers" } } { $subsection { "concurrency" "synchronous-sends" } } -{ $subsection { "concurrency" "exceptions" } } -{ $subsection { "concurrency" "futures" } } -{ $subsection { "concurrency" "promises" } } ; +{ $subsection { "concurrency" "exceptions" } } ; ABOUT: { "concurrency" "concurrency" } diff --git a/extra/concurrency/messaging/messaging-tests.factor b/extra/concurrency/messaging/messaging-tests.factor index 8908506d51..30b88cf16a 100755 --- a/extra/concurrency/messaging/messaging-tests.factor +++ b/extra/concurrency/messaging/messaging-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005 Chris Double. All Rights Reserved. ! See http://factorcode.org/license.txt for BSD license. ! -USING: kernel concurrency threads vectors arrays sequences +USING: kernel threads vectors arrays sequences namespaces tools.test continuations dlists strings math words match quotations concurrency.private ; IN: temporary diff --git a/extra/concurrency/messaging/messaging.factor b/extra/concurrency/messaging/messaging.factor index bd625ff499..220be64364 100755 --- a/extra/concurrency/messaging/messaging.factor +++ b/extra/concurrency/messaging/messaging.factor @@ -4,14 +4,14 @@ ! Concurrency library for Factor based on Erlang/Termite style ! concurrency. IN: concurrency.messaging -USING: dlists concurrency.threads sequences continuations +USING: dlists threads sequences continuations namespaces random math quotations words kernel arrays assocs init system ; TUPLE: mailbox threads data ; : ( -- mailbox ) - mailbox construct-boa ; + \ mailbox construct-boa ; : mailbox-empty? ( mailbox -- bool ) mailbox-data dlist-empty? ; @@ -52,16 +52,16 @@ PRIVATE> block-if-empty mailbox-data pop-front ; : mailbox-get ( mailbox -- obj ) - f mailbox-timeout-get ; + f mailbox-get-timeout ; : mailbox-get-all-timeout ( mailbox timeout -- array ) - (mailbox-block-if-empty) + block-if-empty [ dup mailbox-empty? ] [ dup mailbox-data pop-back ] [ ] unfold nip ; : mailbox-get-all ( mailbox -- array ) - f mailbox-timeout-get-all ; + f mailbox-get-all-timeout ; : while-mailbox-empty ( mailbox quot -- ) over mailbox-empty? [ @@ -71,7 +71,7 @@ PRIVATE> ] if ; inline : mailbox-timeout-get? ( pred mailbox timeout -- obj ) - [ (mailbox-block-unless-pred) ] 3keep drop + [ block-unless-pred ] 3keep drop mailbox-data delete-node-if ; inline : mailbox-get? ( pred mailbox -- obj ) @@ -83,12 +83,17 @@ TUPLE: linked error thread ; GENERIC: send ( message thread -- ) +: mailbox-of ( thread -- mailbox ) + dup thread-mailbox [ ] [ + dup rot set-thread-mailbox + ] ?if ; + M: thread send ( message thread -- ) - thread-mailbox mailbox-put ; + mailbox-of mailbox-put ; : ?linked dup linked? [ rethrow ] when ; -: mailbox self thread-mailbox ; +: mailbox self mailbox-of ; : receive ( -- message ) mailbox mailbox-get ?linked ; @@ -118,4 +123,4 @@ TUPLE: reply data tag ; receive-if reply-data ; : reply-synchronous ( message synchronous -- ) - [ ] keep synchronous-sender reply ; + [ ] keep synchronous-sender send ; diff --git a/extra/crypto/random.factor b/extra/crypto/random.factor old mode 100644 new mode 100755 index 74dd2dba13..f2d3b0555a --- a/extra/crypto/random.factor +++ b/extra/crypto/random.factor @@ -1,5 +1,5 @@ USING: kernel math math-contrib sequences namespaces errors -hashtables words arrays parser compiler syntax io threads ; +hashtables words arrays parser compiler syntax io ; IN: crypto : make-bits ( quot numbits -- n | quot: -- 0/1 ) 0 -rot [ drop dup call rot 1 shift bitor swap ] each drop ; diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index be4445f842..9b31c78833 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io io.backend io.timeouts system kernel namespaces strings hashtables sequences assocs combinators vocabs.loader -init concurrency.threads continuations math ; +init threads continuations math ; IN: io.launcher ! Non-blocking process exit notification facility diff --git a/extra/io/monitors/monitors.factor b/extra/io/monitors/monitors.factor index 2f54ea59fe..274d81a271 100755 --- a/extra/io/monitors/monitors.factor +++ b/extra/io/monitors/monitors.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.backend kernel continuations namespaces sequences -assocs hashtables sorting arrays concurrency.threads ; +assocs hashtables sorting arrays threads ; IN: io.monitors r accept r> [ with-client ] 2curry - concurrency:spawn drop + "Client" spawn drop ] 2keep accept-loop ; inline : server-loop ( server quot -- ) @@ -42,7 +42,7 @@ SYMBOL: servers : with-server ( seq service quot -- ) [ V{ } clone servers set - [ spawn-server ] curry concurrency:parallel-each + [ spawn-server ] curry parallel-each ] curry with-logging ; inline : stop-server ( -- ) @@ -65,5 +65,5 @@ SYMBOL: servers : with-datagrams ( seq service quot -- ) [ - [ swap spawn-datagrams ] curry concurrency:parallel-each + [ swap spawn-datagrams ] curry parallel-each ] curry with-logging ; inline diff --git a/extra/io/sockets/sockets-docs.factor b/extra/io/sockets/sockets-docs.factor index 1d40be7b67..9136c3ca22 100755 --- a/extra/io/sockets/sockets-docs.factor +++ b/extra/io/sockets/sockets-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax io io.backend concurrency.threads +USING: help.markup help.syntax io io.backend threads strings byte-arrays continuations ; IN: io.sockets diff --git a/extra/io/timeouts/timeouts.factor b/extra/io/timeouts/timeouts.factor index d4106286fd..0bae855399 100755 --- a/extra/io/timeouts/timeouts.factor +++ b/extra/io/timeouts/timeouts.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov, Doug Coleman ! See http://factorcode.org/license.txt for BSD license. USING: kernel math system dlists namespaces assocs init -concurrency.threads io.streams.duplex ; +threads io.streams.duplex ; IN: io.timeouts TUPLE: lapse entry timeout cutoff ; diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 722f38a5af..33f694a018 100755 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien generic assocs kernel kernel.private math -io.nonblocking sequences strings structs sbufs threads unix -vectors io.buffers io.backend io.streams.duplex math.parser -continuations system libc qualified namespaces io.timeouts ; +io.nonblocking sequences strings structs sbufs +threads unix vectors io.buffers io.backend +io.streams.duplex math.parser continuations system libc +qualified namespaces io.timeouts ; QUALIFIED: io IN: io.unix.backend diff --git a/extra/io/unix/bsd/bsd.factor b/extra/io/unix/bsd/bsd.factor index 0ab9f4ed2a..89b0757da5 100755 --- a/extra/io/unix/bsd/bsd.factor +++ b/extra/io/unix/bsd/bsd.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. IN: io.unix.bsd USING: io.backend io.unix.backend io.unix.kqueue io.unix.select -io.launcher io.unix.launcher namespaces kernel assocs threads -continuations ; +io.launcher io.unix.launcher namespaces kernel assocs +threads continuations ; ! On Mac OS X, we use select() for the top-level ! multiplexer, and we hang a kqueue off of it for process exit diff --git a/extra/io/unix/kqueue/kqueue.factor b/extra/io/unix/kqueue/kqueue.factor index 19005df404..04bb70d57d 100755 --- a/extra/io/unix/kqueue/kqueue.factor +++ b/extra/io/unix/kqueue/kqueue.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types kernel io.nonblocking io.unix.backend sequences assocs unix unix.kqueue unix.process math namespaces -combinators threads vectors io.launcher io.unix.launcher ; +combinators threads vectors io.launcher +io.unix.launcher ; IN: io.unix.kqueue TUPLE: kqueue-mx events ; diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 51773515bf..0393b13c7f 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -120,8 +120,6 @@ M: unix-io process-stream* ] if ] if ; -: wait-loop ( -- ) - wait-for-processes [ 250 sleep ] when wait-loop ; - : start-wait-thread ( -- ) - [ wait-loop ] "Process reaper" spawn drop ; + [ wait-for-processes [ 250 sleep ] when t ] + "Process reaper" spawn-server drop ; diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor index 70f8038baf..c38d8c1283 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -3,8 +3,8 @@ USING: kernel io.backend io.monitors io.monitors.private io.files io.buffers io.nonblocking io.timeouts io.unix.backend io.unix.select io.unix.launcher unix.linux.inotify assocs -namespaces threads continuations init math alien.c-types alien -vocabs.loader ; +namespaces threads continuations init math +alien.c-types alien vocabs.loader ; IN: io.unix.linux TUPLE: linux-io ; diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index 59a9a8ac2e..930240419a 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -4,11 +4,11 @@ ! We need to fiddle with the exact search order here, since ! unix::accept shadows streams::accept. IN: io.unix.sockets -USING: alien alien.c-types generic io -kernel math namespaces io.nonblocking parser threads unix -sequences byte-arrays io.sockets io.binary io.unix.backend -io.streams.duplex io.sockets.impl math.parser continuations -libc combinators ; +USING: alien alien.c-types generic io kernel math namespaces +io.nonblocking parser threads unix sequences +byte-arrays io.sockets io.binary io.unix.backend +io.streams.duplex io.sockets.impl math.parser continuations libc +combinators ; : pending-init-error ( port -- ) #! We close it here to avoid a resource leak; callers of diff --git a/extra/io/unix/unix-tests.factor b/extra/io/unix/unix-tests.factor index 4005fb6c09..515077f22b 100755 --- a/extra/io/unix/unix-tests.factor +++ b/extra/io/unix/unix-tests.factor @@ -1,6 +1,6 @@ -USING: io.files io.sockets io kernel threads namespaces -tools.test continuations strings byte-arrays sequences -prettyprint system ; +USING: io.files io.sockets io kernel threads +namespaces tools.test continuations strings byte-arrays +sequences prettyprint system ; IN: temporary ! Unix domain stream sockets diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 4da8ed4046..6f79388016 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -4,7 +4,7 @@ USING: alien alien.c-types arrays continuations destructors io io.windows io.windows.nt.pipes libc io.nonblocking io.streams.duplex windows.types math windows.kernel32 windows namespaces io.launcher kernel sequences windows.errors assocs -splitting system concurrency.threads init strings combinators +splitting system threads init strings combinators io.backend ; IN: io.windows.launcher @@ -147,10 +147,9 @@ M: windows-io kill-process* ( handle -- ) : wait-loop ( -- ) processes get dup assoc-empty? [ drop t ] [ wait-for-processes ] if - [ 250 sleep ] when - wait-loop ; + [ 250 sleep ] when ; : start-wait-thread ( -- ) - [ wait-loop ] "Process wait" spawn drop ; + [ wait-loop t ] "Process wait" spawn-server drop ; [ start-wait-thread ] "io.windows.launcher" add-init-hook diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index 09d23e74e4..caf6a31ea0 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -1,7 +1,7 @@ USING: alien alien.c-types arrays assocs combinators continuations destructors io io.backend io.nonblocking io.windows libc kernel math namespaces sequences -concurrency.threads tuples.lib windows windows.errors +threads tuples.lib windows windows.errors windows.kernel32 strings splitting io.files qualified ascii combinators.lib ; QUALIFIED: windows.winsock diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index d33465ae76..3541243016 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -1,6 +1,6 @@ USING: continuations destructors io.buffers io.files io.backend io.timeouts io.nonblocking io.windows io.windows.nt.backend -kernel libc math concurrency.threads windows windows.kernel32 +kernel libc math threads windows windows.kernel32 alien.c-types alien.arrays sequences combinators combinators.lib sequences.lib ascii splitting alien strings assocs ; IN: io.windows.nt.files diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor index 9f82350f54..eef7476dd5 100755 --- a/extra/io/windows/nt/sockets/sockets.factor +++ b/extra/io/windows/nt/sockets/sockets.factor @@ -2,7 +2,7 @@ USING: alien alien.accessors alien.c-types byte-arrays continuations destructors io.nonblocking io.timeouts io.sockets io.sockets.impl io namespaces io.streams.duplex io.windows io.windows.nt.backend windows.winsock kernel libc math sequences -concurrency.threads tuples.lib ; +threads tuples.lib ; IN: io.windows.nt.sockets : malloc-int ( object -- object ) diff --git a/extra/logging/logging.factor b/extra/logging/logging.factor index 1503e00163..5846515dca 100755 --- a/extra/logging/logging.factor +++ b/extra/logging/logging.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: logging.server sequences namespaces concurrency +USING: logging.server sequences namespaces concurrency.messaging words kernel arrays shuffle tools.annotations prettyprint.config prettyprint debugger io.streams.string splitting continuations effects arrays.lib parser strings diff --git a/extra/logging/server/server.factor b/extra/logging/server/server.factor index 05029df1d0..e31391e5d5 100755 --- a/extra/logging/server/server.factor +++ b/extra/logging/server/server.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces kernel io calendar sequences io.files io.sockets continuations prettyprint assocs math.parser -words debugger math combinators concurrency arrays init -math.ranges strings ; +words debugger math combinators concurrency.messaging +threads arrays init math.ranges strings ; IN: logging.server : log-root ( -- string ) @@ -85,17 +85,16 @@ SYMBOL: log-files log-root directory [ drop rotate-log ] assoc-each ; : log-server-loop ( -- ) - [ - receive unclip { - { "log-message" [ (log-message) ] } - { "rotate-logs" [ drop (rotate-logs) ] } - { "close-logs" [ drop (close-logs) ] } - } case - ] [ error. (close-logs) ] recover - log-server-loop ; + receive unclip { + { "log-message" [ (log-message) ] } + { "rotate-logs" [ drop (rotate-logs) ] } + { "close-logs" [ drop (close-logs) ] } + } case log-server-loop ; : log-server ( -- ) - [ log-server-loop ] spawn "log-server" set-global ; + [ [ log-server-loop ] [ error. (close-logs) ] recover t ] + "Log server" spawn-server + "log-server" set-global ; [ H{ } clone log-files set-global diff --git a/extra/pack/pack.factor b/extra/pack/pack.factor old mode 100644 new mode 100755 index b9b1f6f314..a2958d5bea --- a/extra/pack/pack.factor +++ b/extra/pack/pack.factor @@ -1,7 +1,7 @@ USING: alien alien.c-types arrays assocs byte-arrays inference inference.transforms io io.binary io.streams.string kernel math math.parser namespaces parser prettyprint -quotations sequences strings threads vectors +quotations sequences strings vectors words macros math.functions ; IN: pack diff --git a/extra/space-invaders/space-invaders.factor b/extra/space-invaders/space-invaders.factor index 57c6b23d19..d992df4d8f 100755 --- a/extra/space-invaders/space-invaders.factor +++ b/extra/space-invaders/space-invaders.factor @@ -3,7 +3,7 @@ ! USING: cpu.8080 cpu.8080.emulator openal math alien.c-types sequences kernel shuffle arrays io.files combinators ui.gestures -ui.gadgets ui.render opengl.gl system threads concurrency match +ui.gadgets ui.render opengl.gl system threads match ui byte-arrays combinators.lib ; IN: space-invaders @@ -353,9 +353,10 @@ M: space-invaders update-video ( value addr cpu -- ) ] if ; M: invaders-gadget graft* ( gadget -- ) - dup invaders-gadget-cpu init-sounds - [ f swap set-invaders-gadget-quit? ] keep - [ millis swap invaders-process ] spawn 2drop ; + dup invaders-gadget-cpu init-sounds + f over set-invaders-gadget-quit? + [ millis swap invaders-process ] curry + "Space invaders" spawn drop ; M: invaders-gadget ungraft* ( gadget -- ) t swap set-invaders-gadget-quit? ; diff --git a/extra/tools/interpreter/interpreter.factor b/extra/tools/interpreter/interpreter.factor index 17a3412e93..3be832aec8 100755 --- a/extra/tools/interpreter/interpreter.factor +++ b/extra/tools/interpreter/interpreter.factor @@ -3,7 +3,7 @@ USING: arrays assocs classes combinators sequences.private continuations continuations.private generic hashtables io kernel kernel.private math namespaces namespaces.private prettyprint -quotations sequences splitting strings concurrency.threads +quotations sequences splitting strings threads vectors words ; IN: tools.interpreter diff --git a/extra/tools/threads/threads.factor b/extra/tools/threads/threads.factor index 0690042a3e..aca9e8e649 100755 --- a/extra/tools/threads/threads.factor +++ b/extra/tools/threads/threads.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: tools.threads -USING: concurrency.threads kernel prettyprint prettyprint.config +USING: threads kernel prettyprint prettyprint.config io io.styles sequences assocs namespaces sorting ; : thread. ( thread -- ) diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor index 791b68246b..e16560b708 100755 --- a/extra/ui/tools/interactor/interactor.factor +++ b/extra/ui/tools/interactor/interactor.factor @@ -3,7 +3,7 @@ USING: arrays assocs combinators continuations documents ui.tools.workspace hashtables io io.styles kernel math math.vectors models namespaces parser prettyprint quotations -sequences sequences.lib strings concurrency.threads listener +sequences sequences.lib strings threads listener tuples ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.presentations ui.gadgets.worlds ui.gestures definitions ; @@ -88,12 +88,12 @@ M: interactor model-changed ] unless drop ; : interactor-yield ( interactor -- obj ) - dup gadget-graft-state first [ + ! dup gadget-graft-state first [ f over set-interactor-busy? - [ set-interactor-thread ] curry suspend - ] [ - drop f - ] if ; + [ set-interactor-thread ] curry suspend ; + ! ] [ + ! drop f + ! ] if ; M: interactor stream-readln [ interactor-yield ] keep interactor-finish ?first ; diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor index 0f6a45de52..e4a7e6e0e8 100755 --- a/extra/ui/tools/listener/listener.factor +++ b/extra/ui/tools/listener/listener.factor @@ -6,7 +6,7 @@ kernel models namespaces parser quotations sequences ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.labelled ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.operations vocabs words -prettyprint listener debugger concurrency.threads ; +prettyprint listener debugger threads ; IN: ui.tools.listener TUPLE: listener-gadget input output stack ; diff --git a/extra/ui/tools/walker/walker.factor b/extra/ui/tools/walker/walker.factor index e80d87d591..d27fa3bb04 100755 --- a/extra/ui/tools/walker/walker.factor +++ b/extra/ui/tools/walker/walker.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs ui.tools.listener ui.tools.traceback ui.tools.workspace inspector kernel models namespaces -prettyprint quotations sequences concurrency.threads +prettyprint quotations sequences threads tools.interpreter ui.commands ui.gadgets ui.gadgets.labelled ui.gadgets.tracks ui.gestures ui.gadgets.buttons ui.gadgets.panes prettyprint.config prettyprint.backend diff --git a/extra/ui/ui.factor b/extra/ui/ui.factor index c38ce2b44a..e152ea2fa4 100755 --- a/extra/ui/ui.factor +++ b/extra/ui/ui.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs io kernel math models namespaces -prettyprint dlists sequences concurrency.threads sequences words +prettyprint dlists sequences threads sequences words timers debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render continuations init combinators hashtables ; diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index 4f5b9bd6a8..bdb06042ed 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -5,7 +5,7 @@ ui.backend ui.clipboards ui.gadgets.worlds ui.gestures io kernel math math.vectors namespaces prettyprint sequences strings vectors words windows.kernel32 windows.gdi32 windows.user32 windows.opengl32 windows.messages windows.types windows.nt -windows concurrency.threads timers libc combinators +windows threads timers libc combinators continuations command-line shuffle opengl ui.render unicode.case ascii math.bitfields ; IN: ui.windows diff --git a/extra/vocabs/monitor/monitor.factor b/extra/vocabs/monitor/monitor.factor index f22002ee6a..d3e4a44896 100755 --- a/extra/vocabs/monitor/monitor.factor +++ b/extra/vocabs/monitor/monitor.factor @@ -1,18 +1,22 @@ -USING: concurrency.threads io.files io.monitors init kernel -tools.browser ; +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: threads io.files io.monitors init kernel +tools.browser namespaces continuations ; IN: vocabs.monitor ! Use file system change monitoring to flush the tags/authors ! cache -: (monitor-thread) ( monitor -- ) - dup next-change 2drop reset-cache (monitor-thread) ; +SYMBOL: vocab-monitor : monitor-thread ( -- ) - "" resource-path t (monitor-thread) ; + vocab-monitor get-global next-change 2drop reset-cache ; : start-monitor-thread #! Silently ignore errors during monitor creation since #! monitors are not supported on all platforms. - [ monitor-thread ] "Vocabulary monitor" spawn drop ; + [ + "" resource-path t vocab-monitor set-global + [ monitor-thread t ] "Vocabulary monitor" spawn-server drop + ] [ drop ] recover ; [ start-monitor-thread ] "vocabs.monitor" add-init-hook diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index 456855c1fa..e4820c0d59 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -1,7 +1,7 @@ -USING: sequences rss arrays concurrency kernel sorting -html.elements io assocs namespaces math threads vocabs html -furnace http.server.templating calendar math.parser splitting -continuations debugger system http.server.responders +USING: sequences rss arrays concurrency.futures kernel sorting +html.elements io assocs namespaces math threads +vocabs html furnace http.server.templating calendar math.parser +splitting continuations debugger system http.server.responders xml.writer prettyprint logging ; IN: webapps.planet From cd8ab4ba8d5a42870048b9b31ff36d0938a642c2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 18 Feb 2008 09:08:59 -0600 Subject: [PATCH 3/7] Updating libraries --- extra/benchmark/sockets/sockets.factor | 2 +- extra/calendar/model/model.factor | 2 +- extra/channels/channels.factor | 2 +- extra/channels/remote/remote.factor | 30 ++++++------ extra/channels/sniffer/sniffer.factor | 4 +- .../combinators/combinators.factor | 13 +++++ .../concurrency/conditions/conditions.factor | 13 +++++ .../count-downs/count-downs.factor | 32 ++++++++++++ .../distributed/distributed-docs.factor | 14 ++---- .../distributed/distributed.factor | 19 ++++--- extra/concurrency/futures/futures.factor | 20 +++----- extra/concurrency/locks/locks.factor | 49 ++++++++----------- extra/concurrency/messaging/messaging.factor | 37 +++++++++----- extra/concurrency/promises/promises.factor | 5 +- .../concurrency/semaphores/semaphores.factor | 3 ++ extra/io/server/server.factor | 2 +- extra/webapps/planet/planet.factor | 6 +-- 17 files changed, 155 insertions(+), 98 deletions(-) create mode 100755 extra/concurrency/combinators/combinators.factor create mode 100755 extra/concurrency/conditions/conditions.factor create mode 100755 extra/concurrency/count-downs/count-downs.factor diff --git a/extra/benchmark/sockets/sockets.factor b/extra/benchmark/sockets/sockets.factor index 40012e1638..36529facaa 100755 --- a/extra/benchmark/sockets/sockets.factor +++ b/extra/benchmark/sockets/sockets.factor @@ -1,5 +1,5 @@ USING: io.sockets io.server io kernel math threads -debugger tools.time prettyprint ; +debugger tools.time prettyprint concurrency.combinators ; IN: benchmark.sockets : simple-server ( -- ) diff --git a/extra/calendar/model/model.factor b/extra/calendar/model/model.factor index be98c7491e..aa295e0f75 100755 --- a/extra/calendar/model/model.factor +++ b/extra/calendar/model/model.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: calendar namespaces models threads init ; +USING: calendar namespaces models threads kernel init ; IN: calendar.model SYMBOL: time diff --git a/extra/channels/channels.factor b/extra/channels/channels.factor index 07b5d2f5d5..01f810b8e3 100755 --- a/extra/channels/channels.factor +++ b/extra/channels/channels.factor @@ -19,7 +19,7 @@ GENERIC: from ( channel -- value ) [ channel-senders push stop ] curry callcc0 ; : (to) ( value receivers -- ) - delete-random schedule-thread-with yield ; + delete-random resume-with yield ; : notify ( continuation channel -- channel ) [ channel-receivers push ] keep ; diff --git a/extra/channels/remote/remote.factor b/extra/channels/remote/remote.factor index 40a6df350b..b5a497b1fa 100755 --- a/extra/channels/remote/remote.factor +++ b/extra/channels/remote/remote.factor @@ -4,7 +4,7 @@ ! Remote Channels USING: kernel init namespaces assocs arrays random sequences channels match concurrency.messaging -concurrency.distributed ; +concurrency.distributed threads ; IN: channels.remote : start-channel-node ( -- ) "remote-channels" get-process [ - "remote-channels" - [ channel-process ] "Remote channels" spawn - register-process + "remote-channels" + [ channel-process ] "Remote channels" spawn-server + register-process ] unless ; TUPLE: remote-channel node id ; @@ -52,12 +52,12 @@ TUPLE: remote-channel node id ; C: remote-channel M: remote-channel to ( value remote-channel -- ) - dup >r [ \ to , remote-channel-id , , ] { } make r> + [ [ \ to , remote-channel-id , , ] { } make ] keep remote-channel-node "remote-channels" send-synchronous no-channel = [ no-channel throw ] when ; M: remote-channel from ( remote-channel -- value ) - dup >r [ \ from , remote-channel-id , ] { } make r> + [ [ \ from , remote-channel-id , ] { } make ] keep remote-channel-node "remote-channels" send-synchronous dup no-channel = [ no-channel throw ] when* ; diff --git a/extra/channels/sniffer/sniffer.factor b/extra/channels/sniffer/sniffer.factor index 1502201225..cbf31c71e3 100755 --- a/extra/channels/sniffer/sniffer.factor +++ b/extra/channels/sniffer/sniffer.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. ! ! Wrap a sniffer in a channel -USING: kernel channels concurrency io io.backend -io.sniffer io.sniffer.backend system vocabs.loader ; +USING: kernel channels io io.backend io.sniffer +io.sniffer.backend system vocabs.loader ; : (sniff-channel) ( stream channel -- ) 4096 pick stream-read-partial over to (sniff-channel) ; diff --git a/extra/concurrency/combinators/combinators.factor b/extra/concurrency/combinators/combinators.factor new file mode 100755 index 0000000000..5e19baf393 --- /dev/null +++ b/extra/concurrency/combinators/combinators.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: concurrency.futures concurrency.count-downs sequences +kernel ; +IN: concurrency.combinators + +: parallel-map ( seq quot -- newseq ) + [ curry future ] curry map dup [ ?future ] change-each ; + inline + +: parallel-each ( seq quot -- ) + "Parallel each" pick length + [ [ spawn-stage ] 2curry each ] keep await ; inline diff --git a/extra/concurrency/conditions/conditions.factor b/extra/concurrency/conditions/conditions.factor new file mode 100755 index 0000000000..f94cfe6cca --- /dev/null +++ b/extra/concurrency/conditions/conditions.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: dlists threads kernel arrays sequences ; +IN: concurrency.conditions + +: notify-1 ( dlist -- ) + dup dlist-empty? [ pop-back resume ] [ drop ] if ; + +: notify-all ( dlist -- ) + [ second resume ] dlist-slurp yield ; + +: wait ( queue timeout -- queue timeout ) + [ 2array swap push-front ] suspend 3drop ; inline diff --git a/extra/concurrency/count-downs/count-downs.factor b/extra/concurrency/count-downs/count-downs.factor new file mode 100755 index 0000000000..122076eeb1 --- /dev/null +++ b/extra/concurrency/count-downs/count-downs.factor @@ -0,0 +1,32 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: dlists kernel math concurrency.promises +concurrency.messaging ; +IN: concurrency.count-downs + +! http://java.sun.com/j2se/1.5.0/docs/api/java/util/concurrent/CountDownLatch.html + +TUPLE: count-down n promise ; + +: ( n -- count-down ) + count-down construct-boa ; + +: count-down ( count-down -- ) + dup count-down-n dup zero? [ + "Count down already done" throw + ] [ + 1- dup pick set-count-down-n + zero? [ + t swap count-down-promise fulfill + ] [ drop ] if + ] if ; + +: await-timeout ( count-down timeout -- ) + >r count-down-promise r> ?promise-timeout drop ; + +: spawn-stage ( quot name count-down -- ) + count-down-promise + promise-mailbox spawn-linked-to drop ; + +: await ( count-down -- ) + f await-timeout ; diff --git a/extra/concurrency/distributed/distributed-docs.factor b/extra/concurrency/distributed/distributed-docs.factor index 8f82d1aebf..ad9e392771 100755 --- a/extra/concurrency/distributed/distributed-docs.factor +++ b/extra/concurrency/distributed/distributed-docs.factor @@ -1,15 +1,7 @@ USING: help.markup help.syntax concurrency.messaging ; IN: concurrency.distributed -HELP: -{ $values { "node" "a node object" } - { "pid" "a process id" } - { "remote-process" "the constructed remote-process object" } +HELP: local-node +{ $values { "addrspec" "an address specifier" } } -{ $description "Constructs a proxy to a process running on another node. It can be used to send messages to the process it is acting as a proxy for." } -{ $see-also spawn send } ; - -HELP: localnode -{ $values { "node" "a node object" } -} -{ $description "Return the node the process is currently running on." } ; +{ $description "Return the node the current thread is running on." } ; diff --git a/extra/concurrency/distributed/distributed.factor b/extra/concurrency/distributed/distributed.factor index 30587b35ac..2c54a872f7 100755 --- a/extra/concurrency/distributed/distributed.factor +++ b/extra/concurrency/distributed/distributed.factor @@ -6,8 +6,10 @@ namespaces kernel ; QUALIFIED: io.sockets IN: concurrency.distributed +SYMBOL: local-node ( -- addrspec ) + : handle-node-client ( -- ) - deserialize first2 thread send ; + deserialize first2 get-process send ; : (start-node) ( addrspecs addrspec -- ) [ @@ -16,18 +18,19 @@ IN: concurrency.distributed [ handle-node-client ] with-server ] 2curry f spawn drop ; -SYMBOL: local-node ( -- addrspec ) - : start-node ( port -- ) - dup internet-server host-name rot (start-node) ; + dup internet-server io.sockets:host-name + rot io.sockets: (start-node) ; -TUPLE: remote-thread pid node ; +TUPLE: remote-process id node ; -M: remote-thread send ( message thread -- ) - { remote-thread-pid remote-thread-node } get-slots +C: remote-process + +M: remote-process send ( message thread -- ) + { remote-process-id remote-process-node } get-slots io.sockets: [ 2array serialize ] with-stream ; M: thread (serialize) ( obj -- ) thread-id local-node get-global - remote-thread construct-boa + (serialize) ; diff --git a/extra/concurrency/futures/futures.factor b/extra/concurrency/futures/futures.factor index fa8aba27fe..0a05d2d78e 100755 --- a/extra/concurrency/futures/futures.factor +++ b/extra/concurrency/futures/futures.factor @@ -1,25 +1,17 @@ ! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USING: concurrency.promises concurrency.messaging kernel arrays +continuations ; IN: concurrency.futures : future ( quot -- future ) [ - [ - >r - [ t 2array ] compose - [ f 2array ] recover - r> fulfill - ] 2curry "Future" spawn drop + [ [ >r call r> fulfill ] 2curry "Future" ] keep + promise-mailbox spawn-linked-to drop ] keep ; inline : ?future-timeout ( future timeout -- value ) - ?promise-timeout first2 [ rethrow ] unless ; + ?promise-timeout ; : ?future ( future -- value ) - f ?future-timeout ; - -: parallel-map ( seq quot -- newseq ) - [ curry future ] curry map [ ?future ] map ; - -: parallel-each ( seq quot -- ) - [ f ] compose parallel-map drop ; + ?promise ; diff --git a/extra/concurrency/locks/locks.factor b/extra/concurrency/locks/locks.factor index 3a792768a7..50a62e3f6f 100755 --- a/extra/concurrency/locks/locks.factor +++ b/extra/concurrency/locks/locks.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: dlists kernel threads continuations math ; +USING: dlists kernel threads continuations math +concurrency.conditions ; IN: concurrency.locks ! Simple critical sections @@ -8,31 +9,26 @@ TUPLE: lock threads owner ; : lock construct-boa ; -: notify-1 ( dlist -- ) - dup dlist-empty? [ pop-back resume ] [ drop ] if ; - r lock-threads r> wait ] when drop self swap set-lock-owner ; : release-lock ( lock -- ) f over set-lock-owner lock-threads notify-1 ; -: do-lock ( lock quot acquire release -- ) - >r >r over r> call over r> curry [ ] cleanup ; inline +: do-lock ( lock timeout quot acquire release -- ) + >r >r pick r> call over r> curry [ ] cleanup ; inline PRIVATE> -: with-lock ( lock quot -- ) +: with-lock ( lock timeout quot -- ) [ acquire-lock ] [ release-lock ] do-lock ; inline -: with-reentrant-lock ( lock quot -- ) +: with-reentrant-lock ( lock timeout quot -- ) over lock-owner self eq? [ nip call ] [ with-lock ] if ; inline @@ -44,44 +40,39 @@ TUPLE: rw-lock readers writers reader# writer ; r rw-lock-readers r> wait ] when drop dup rw-lock-reader# 1+ swap set-rw-lock-reader# ; : notify-writer ( lock -- ) - lock-writers notify-1 ; + rw-lock-writers notify-1 ; : release-read-lock ( lock -- ) dup rw-lock-reader# 1- dup pick set-rw-lock-reader# - zero? [ notify-writers ] [ drop ] if ; - -: wait-for-write-lock ( lock -- ) - [ swap lock-writers push-front ] suspend drop ; + zero? [ notify-writer ] [ drop ] if ; : acquire-write-lock ( lock -- ) dup rw-lock-writer over rw-lock-reader# 0 > or - [ dup wait-for-write-lock ] when - self over set-rw-lock-writer ; + [ 2dup >r rw-lock-writers r> wait ] when drop + self swap set-rw-lock-writer ; : release-write-lock ( lock -- ) f over set-rw-lock-writer dup rw-lock-readers dlist-empty? [ notify-writer ] [ rw-lock-readers notify-all ] if ; -: do-recursive-rw-lock ( lock quot quot' -- ) - >r over rw-lock-writer self eq? [ nip call ] r> if ; inline +: do-recursive-rw-lock ( lock timeout quot quot' -- ) + >r pick rw-lock-writer self eq? [ 2nip call ] r> if ; inline PRIVATE> -: with-read-lock ( lock quot -- ) +: with-read-lock ( lock timeout quot -- ) [ [ acquire-read-lock ] [ release-read-lock ] do-lock ] do-recursive-rw-lock ; inline -: with-write-lock ( lock quot -- ) +: with-write-lock ( lock timeout quot -- ) [ [ acquire-write-lock ] [ release-write-lock ] do-lock ] do-recursive-rw-lock ; inline diff --git a/extra/concurrency/messaging/messaging.factor b/extra/concurrency/messaging/messaging.factor index 220be64364..e7a860495f 100755 --- a/extra/concurrency/messaging/messaging.factor +++ b/extra/concurrency/messaging/messaging.factor @@ -6,7 +6,7 @@ IN: concurrency.messaging USING: dlists threads sequences continuations namespaces random math quotations words kernel arrays assocs -init system ; +init system concurrency.conditions ; TUPLE: mailbox threads data ; @@ -16,29 +16,22 @@ TUPLE: mailbox threads data ; : mailbox-empty? ( mailbox -- bool ) mailbox-data dlist-empty? ; -: notify-all ( dlist -- ) - [ second resume ] dlist-slurp yield ; - : mailbox-put ( obj mailbox -- ) [ mailbox-data push-front ] keep mailbox-threads notify-all ; r r> send ; +: spawn-linked-to ( quot name mailbox -- thread ) + [ >r r> mailbox-put ] curry + [ (spawn) ] keep ; + : spawn-linked ( quot name -- thread ) - self [ rethrow-linked ] curry [ (spawn) ] keep ; + mailbox spawn-linked-to ; TUPLE: synchronous data sender tag ; @@ -124,3 +121,21 @@ TUPLE: reply data tag ; : reply-synchronous ( message synchronous -- ) [ ] keep synchronous-sender send ; + + + +: register-process ( name process -- ) + swap remote-processes set-at ; + +: unregister-process ( name -- ) + remote-processes delete-at ; + +: get-process ( name -- process ) + dup remote-processes at [ ] [ thread ] ?if ; + +\ remote-processes global [ H{ } assoc-like ] change-at diff --git a/extra/concurrency/promises/promises.factor b/extra/concurrency/promises/promises.factor index ecaa722b11..6610a8c7ed 100755 --- a/extra/concurrency/promises/promises.factor +++ b/extra/concurrency/promises/promises.factor @@ -1,5 +1,7 @@ ! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USING: concurrency.messaging concurrency.messaging.private +kernel ; IN: concurrency.promises TUPLE: promise mailbox ; @@ -18,7 +20,8 @@ TUPLE: promise mailbox ; ] if ; : ?promise-timeout ( promise timeout -- result ) - >r promise-mailbox r> block-if-empty mailbox-peek ; + >r promise-mailbox r> block-if-empty + mailbox-peek ?linked ; : ?promise ( promise -- result ) f ?promise-timeout ; diff --git a/extra/concurrency/semaphores/semaphores.factor b/extra/concurrency/semaphores/semaphores.factor index 7bfaf4c1ce..4afa02307a 100755 --- a/extra/concurrency/semaphores/semaphores.factor +++ b/extra/concurrency/semaphores/semaphores.factor @@ -1,3 +1,6 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: dlists kernel threads math ; IN: concurrency.semaphores TUPLE: semaphore count threads ; diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index f988b1eeab..160af21661 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -3,7 +3,7 @@ USING: io io.sockets io.files logging continuations kernel math math.parser namespaces parser sequences strings prettyprint debugger quotations calendar -threads concurrency.futures ; +threads concurrency.combinators ; IN: io.server diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index e4820c0d59..062f6dbce2 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -1,6 +1,6 @@ -USING: sequences rss arrays concurrency.futures kernel sorting -html.elements io assocs namespaces math threads -vocabs html furnace http.server.templating calendar math.parser +USING: sequences rss arrays concurrency.combinators kernel +sorting html.elements io assocs namespaces math threads vocabs +html furnace http.server.templating calendar math.parser splitting continuations debugger system http.server.responders xml.writer prettyprint logging ; IN: webapps.planet From 5f23beffe0d69b1a9608fb35077301d351f6c88c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 18 Feb 2008 16:18:59 -0600 Subject: [PATCH 4/7] Move some unmaintained libaries to unmaintained --- {extra => unmaintained}/cryptlib/authors.txt | 0 .../cryptlib/cryptlib-tests.factor | 0 {extra => unmaintained}/cryptlib/cryptlib.factor | 0 {extra => unmaintained}/cryptlib/libcl/libcl.factor | 0 {extra => unmaintained}/cryptlib/notes.txt | 0 .../cryptlib/streams/streams.factor | 0 {extra => unmaintained}/cryptlib/streams/tags.txt | 0 {extra => unmaintained}/cryptlib/summary.txt | 0 {extra => unmaintained}/cryptlib/tags.txt | 0 {extra => unmaintained}/cryptlib/test/keys.p15 | Bin .../cryptlib/test/large_data.txt | 0 {extra => unmaintained}/id3/authors.txt | 0 {extra => unmaintained}/id3/id3-docs.factor | 0 {extra => unmaintained}/id3/id3.factor | 0 {extra => unmaintained}/id3/summary.txt | 0 {extra => unmaintained}/mad/api/api.factor | 0 {extra => unmaintained}/mad/api/authors.txt | 0 {extra => unmaintained}/mad/authors.txt | 0 {extra => unmaintained}/mad/mad-tests.factor | 0 {extra => unmaintained}/mad/mad.factor | 0 {extra => unmaintained}/mad/player/authors.txt | 0 {extra => unmaintained}/mad/player/player.factor | 0 {extra => unmaintained}/mad/summary.txt | 0 .../network-clipboard/authors.txt | 0 .../network-clipboard/network-clipboard.factor | 2 +- {extra => unmaintained}/prolog/authors.txt | 0 {extra => unmaintained}/prolog/prolog.factor | 0 {extra => unmaintained}/prolog/summary.txt | 0 {extra => unmaintained}/prolog/tags.txt | 0 29 files changed, 1 insertion(+), 1 deletion(-) rename {extra => unmaintained}/cryptlib/authors.txt (100%) rename {extra => unmaintained}/cryptlib/cryptlib-tests.factor (100%) rename {extra => unmaintained}/cryptlib/cryptlib.factor (100%) rename {extra => unmaintained}/cryptlib/libcl/libcl.factor (100%) rename {extra => unmaintained}/cryptlib/notes.txt (100%) rename {extra => unmaintained}/cryptlib/streams/streams.factor (100%) rename {extra => unmaintained}/cryptlib/streams/tags.txt (100%) rename {extra => unmaintained}/cryptlib/summary.txt (100%) rename {extra => unmaintained}/cryptlib/tags.txt (100%) rename {extra => unmaintained}/cryptlib/test/keys.p15 (100%) rename {extra => unmaintained}/cryptlib/test/large_data.txt (100%) rename {extra => unmaintained}/id3/authors.txt (100%) rename {extra => unmaintained}/id3/id3-docs.factor (100%) rename {extra => unmaintained}/id3/id3.factor (100%) rename {extra => unmaintained}/id3/summary.txt (100%) rename {extra => unmaintained}/mad/api/api.factor (100%) rename {extra => unmaintained}/mad/api/authors.txt (100%) rename {extra => unmaintained}/mad/authors.txt (100%) rename {extra => unmaintained}/mad/mad-tests.factor (100%) rename {extra => unmaintained}/mad/mad.factor (100%) rename {extra => unmaintained}/mad/player/authors.txt (100%) rename {extra => unmaintained}/mad/player/player.factor (100%) rename {extra => unmaintained}/mad/summary.txt (100%) rename {extra => unmaintained}/network-clipboard/authors.txt (100%) rename {extra => unmaintained}/network-clipboard/network-clipboard.factor (98%) rename {extra => unmaintained}/prolog/authors.txt (100%) rename {extra => unmaintained}/prolog/prolog.factor (100%) rename {extra => unmaintained}/prolog/summary.txt (100%) rename {extra => unmaintained}/prolog/tags.txt (100%) diff --git a/extra/cryptlib/authors.txt b/unmaintained/cryptlib/authors.txt similarity index 100% rename from extra/cryptlib/authors.txt rename to unmaintained/cryptlib/authors.txt diff --git a/extra/cryptlib/cryptlib-tests.factor b/unmaintained/cryptlib/cryptlib-tests.factor similarity index 100% rename from extra/cryptlib/cryptlib-tests.factor rename to unmaintained/cryptlib/cryptlib-tests.factor diff --git a/extra/cryptlib/cryptlib.factor b/unmaintained/cryptlib/cryptlib.factor similarity index 100% rename from extra/cryptlib/cryptlib.factor rename to unmaintained/cryptlib/cryptlib.factor diff --git a/extra/cryptlib/libcl/libcl.factor b/unmaintained/cryptlib/libcl/libcl.factor similarity index 100% rename from extra/cryptlib/libcl/libcl.factor rename to unmaintained/cryptlib/libcl/libcl.factor diff --git a/extra/cryptlib/notes.txt b/unmaintained/cryptlib/notes.txt similarity index 100% rename from extra/cryptlib/notes.txt rename to unmaintained/cryptlib/notes.txt diff --git a/extra/cryptlib/streams/streams.factor b/unmaintained/cryptlib/streams/streams.factor similarity index 100% rename from extra/cryptlib/streams/streams.factor rename to unmaintained/cryptlib/streams/streams.factor diff --git a/extra/cryptlib/streams/tags.txt b/unmaintained/cryptlib/streams/tags.txt similarity index 100% rename from extra/cryptlib/streams/tags.txt rename to unmaintained/cryptlib/streams/tags.txt diff --git a/extra/cryptlib/summary.txt b/unmaintained/cryptlib/summary.txt similarity index 100% rename from extra/cryptlib/summary.txt rename to unmaintained/cryptlib/summary.txt diff --git a/extra/cryptlib/tags.txt b/unmaintained/cryptlib/tags.txt similarity index 100% rename from extra/cryptlib/tags.txt rename to unmaintained/cryptlib/tags.txt diff --git a/extra/cryptlib/test/keys.p15 b/unmaintained/cryptlib/test/keys.p15 similarity index 100% rename from extra/cryptlib/test/keys.p15 rename to unmaintained/cryptlib/test/keys.p15 diff --git a/extra/cryptlib/test/large_data.txt b/unmaintained/cryptlib/test/large_data.txt similarity index 100% rename from extra/cryptlib/test/large_data.txt rename to unmaintained/cryptlib/test/large_data.txt diff --git a/extra/id3/authors.txt b/unmaintained/id3/authors.txt similarity index 100% rename from extra/id3/authors.txt rename to unmaintained/id3/authors.txt diff --git a/extra/id3/id3-docs.factor b/unmaintained/id3/id3-docs.factor similarity index 100% rename from extra/id3/id3-docs.factor rename to unmaintained/id3/id3-docs.factor diff --git a/extra/id3/id3.factor b/unmaintained/id3/id3.factor similarity index 100% rename from extra/id3/id3.factor rename to unmaintained/id3/id3.factor diff --git a/extra/id3/summary.txt b/unmaintained/id3/summary.txt similarity index 100% rename from extra/id3/summary.txt rename to unmaintained/id3/summary.txt diff --git a/extra/mad/api/api.factor b/unmaintained/mad/api/api.factor similarity index 100% rename from extra/mad/api/api.factor rename to unmaintained/mad/api/api.factor diff --git a/extra/mad/api/authors.txt b/unmaintained/mad/api/authors.txt similarity index 100% rename from extra/mad/api/authors.txt rename to unmaintained/mad/api/authors.txt diff --git a/extra/mad/authors.txt b/unmaintained/mad/authors.txt similarity index 100% rename from extra/mad/authors.txt rename to unmaintained/mad/authors.txt diff --git a/extra/mad/mad-tests.factor b/unmaintained/mad/mad-tests.factor similarity index 100% rename from extra/mad/mad-tests.factor rename to unmaintained/mad/mad-tests.factor diff --git a/extra/mad/mad.factor b/unmaintained/mad/mad.factor similarity index 100% rename from extra/mad/mad.factor rename to unmaintained/mad/mad.factor diff --git a/extra/mad/player/authors.txt b/unmaintained/mad/player/authors.txt similarity index 100% rename from extra/mad/player/authors.txt rename to unmaintained/mad/player/authors.txt diff --git a/extra/mad/player/player.factor b/unmaintained/mad/player/player.factor similarity index 100% rename from extra/mad/player/player.factor rename to unmaintained/mad/player/player.factor diff --git a/extra/mad/summary.txt b/unmaintained/mad/summary.txt similarity index 100% rename from extra/mad/summary.txt rename to unmaintained/mad/summary.txt diff --git a/extra/network-clipboard/authors.txt b/unmaintained/network-clipboard/authors.txt similarity index 100% rename from extra/network-clipboard/authors.txt rename to unmaintained/network-clipboard/authors.txt diff --git a/extra/network-clipboard/network-clipboard.factor b/unmaintained/network-clipboard/network-clipboard.factor similarity index 98% rename from extra/network-clipboard/network-clipboard.factor rename to unmaintained/network-clipboard/network-clipboard.factor index 238089d6f8..72307f5f7f 100755 --- a/extra/network-clipboard/network-clipboard.factor +++ b/unmaintained/network-clipboard/network-clipboard.factor @@ -49,7 +49,7 @@ M: string host-name ; [ host? ] \ send-clipboard H{ } define-operation -: ask-text ( text host -- ) +: ask-text ( text host -- text ) clipboard-port [ write flush contents ] with-client ; diff --git a/extra/prolog/authors.txt b/unmaintained/prolog/authors.txt similarity index 100% rename from extra/prolog/authors.txt rename to unmaintained/prolog/authors.txt diff --git a/extra/prolog/prolog.factor b/unmaintained/prolog/prolog.factor similarity index 100% rename from extra/prolog/prolog.factor rename to unmaintained/prolog/prolog.factor diff --git a/extra/prolog/summary.txt b/unmaintained/prolog/summary.txt similarity index 100% rename from extra/prolog/summary.txt rename to unmaintained/prolog/summary.txt diff --git a/extra/prolog/tags.txt b/unmaintained/prolog/tags.txt similarity index 100% rename from extra/prolog/tags.txt rename to unmaintained/prolog/tags.txt From d657821f3efa094feb32d7542ba94fd9ae5f1d26 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 18 Feb 2008 16:20:18 -0600 Subject: [PATCH 5/7] Tested and documented all new concurrency features --- core/threads/threads-docs.factor | 15 +- core/threads/threads.factor | 51 +++--- extra/bunny/model/model.factor | 2 +- extra/channels/examples/examples.factor | 2 +- extra/channels/remote/remote.factor | 4 +- .../combinators/combinators-docs.factor | 25 +++ .../combinators/combinators-tests.factor | 24 +++ .../combinators/combinators.factor | 8 +- extra/concurrency/combinators/summary.txt | 1 + .../concurrency/conditions/conditions.factor | 6 +- extra/concurrency/conditions/summary.txt | 1 + .../count-downs/count-downs-docs.factor | 24 +++ .../count-downs/count-downs-tests.factor | 16 ++ .../count-downs/count-downs.factor | 25 ++- extra/concurrency/count-downs/summary.txt | 1 + .../distributed/distributed-docs.factor | 15 +- .../exchangers/exchangers-docs.factor | 22 +++ .../exchangers/exchangers-tests.factor | 30 ++++ .../concurrency/exchangers/exchangers.factor | 15 +- extra/concurrency/exchangers/exchangers.txt | 1 - extra/concurrency/exchangers/summary.txt | 1 + extra/concurrency/futures/futures-docs.factor | 29 +++ .../concurrency/futures/futures-tests.factor | 25 +++ extra/concurrency/locks/locks-docs.factor | 60 +++++++ extra/concurrency/locks/locks-tests.factor | 159 +++++++++++++++++ extra/concurrency/locks/locks.factor | 42 +++-- .../messaging/messaging-docs.factor | 113 +++++++----- .../messaging/messaging-tests.factor | 165 ++++++------------ extra/concurrency/messaging/messaging.factor | 26 +-- .../concurrency/promises/promises-docs.factor | 36 ++++ .../promises/promises-tests.factor | 12 ++ .../semaphores/semaphores-docs.factor | 45 +++++ .../concurrency/semaphores/semaphores.factor | 16 +- extra/help/handbook/handbook.factor | 33 +++- extra/smtp/server/server.factor | 2 +- extra/tools/browser/browser.factor | 1 + extra/tools/threads/threads.factor | 2 +- vm/run.h | 6 +- 38 files changed, 823 insertions(+), 238 deletions(-) mode change 100644 => 100755 extra/bunny/model/model.factor create mode 100755 extra/concurrency/combinators/combinators-docs.factor create mode 100755 extra/concurrency/combinators/combinators-tests.factor create mode 100755 extra/concurrency/combinators/summary.txt create mode 100755 extra/concurrency/conditions/summary.txt create mode 100755 extra/concurrency/count-downs/count-downs-docs.factor create mode 100755 extra/concurrency/count-downs/count-downs-tests.factor create mode 100755 extra/concurrency/count-downs/summary.txt create mode 100755 extra/concurrency/exchangers/exchangers-docs.factor create mode 100755 extra/concurrency/exchangers/exchangers-tests.factor delete mode 100644 extra/concurrency/exchangers/exchangers.txt create mode 100755 extra/concurrency/exchangers/summary.txt create mode 100755 extra/concurrency/futures/futures-docs.factor create mode 100755 extra/concurrency/futures/futures-tests.factor create mode 100755 extra/concurrency/locks/locks-docs.factor create mode 100755 extra/concurrency/locks/locks-tests.factor create mode 100755 extra/concurrency/promises/promises-docs.factor create mode 100755 extra/concurrency/promises/promises-tests.factor create mode 100755 extra/concurrency/semaphores/semaphores-docs.factor diff --git a/core/threads/threads-docs.factor b/core/threads/threads-docs.factor index 0a9e1b0bac..6a5bd57751 100755 --- a/core/threads/threads-docs.factor +++ b/core/threads/threads-docs.factor @@ -6,6 +6,7 @@ IN: threads ARTICLE: "threads-start/stop" "Starting and stopping threads" "Spawning new threads:" { $subsection spawn } +{ $subsection spawn-server } "Creating and spawning a thread can be factored out into two separate steps:" { $subsection } { $subsection (spawn) } @@ -42,7 +43,9 @@ ARTICLE: "thread-impl" "Thread implementation" { $subsection sleep-queue } ; ARTICLE: "threads" "Lightweight co-operative threads" -"Factor supports lightweight co-operative threads implemented on top of continuations. A thread will yield while waiting for I/O operations to complete, or when a yield has been explicitly requested." +"Factor supports lightweight co-operative threads implemented on top of continuations. A thread will yield while waiting for input/output operations to complete, or when a yield has been explicitly requested." +$nl +"Factor threads are very lightweight. Each thread can take as little as 900 bytes of memory. This library has been tested running hundreds of thousands of simple threads." $nl "Words for working with threads are in the " { $vocab-link "threads" } " vocabulary." { $subsection "threads-start/stop" } @@ -112,11 +115,19 @@ HELP: spawn { $values { "quot" quotation } { "name" string } } { $description "Spawns a new thread. The thread begins executing the given quotation; the name is for debugging purposes. The new thread begins running immediately and the current thread is added to the end of the run queue." $nl -"The new thread begins with an empty data stack, an empty catch stack and a name stack containing the global namespace only. This means that the only way to pass data to the new thread is to explicitly construct a quotation containing the data, for example using " { $link curry } " or " { $link compose } "." } +"The new thread begins with an empty data stack, an empty catch stack, and a name stack containing the global namespace only. This means that the only way to pass data to the new thread is to explicitly construct a quotation containing the data, for example using " { $link curry } " or " { $link compose } "." } { $examples { $code "1 2 [ + . ] 2curry \"Addition thread\" spawn" } } ; +HELP: spawn-server +{ $values { "quot" "a quotation with stack effect " { $snippet "( -- ? )" } } { "name" string } } +{ $description "Convenience wrapper around " { $link spawn } " which repeatedly calls the quotation in a new thread until it outputs " { $link f } "." } +{ $examples + "A thread that runs forever:" + { $code "[ do-foo-bar t ] \"Foo bar server\" spawn-server" } +} ; + HELP: init-threads { $description "Called during startup to initialize the threading system. This word should never be called directly." } ; diff --git a/core/threads/threads.factor b/core/threads/threads.factor index 04487e16b4..553cd6fc03 100755 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -17,19 +17,24 @@ mailbox variables ; : self ( -- thread ) 40 getenv ; inline ! Thread-local storage -: tnamespace ( -- assoc ) self thread-variables ; +: tnamespace ( -- assoc ) + self dup thread-variables + [ ] [ H{ } clone dup rot set-thread-variables ] ?if ; -: tget ( key -- value ) tnamespace at ; +: tget ( key -- value ) + self thread-variables at ; -: tset ( value key -- ) tnamespace set-at ; +: tset ( value key -- ) + tnamespace set-at ; -: tchange ( key quot -- ) tnamespace change-at ; inline +: tchange ( key quot -- ) + tnamespace change-at ; inline -SYMBOL: threads +: threads 41 getenv ; threads global [ H{ } assoc-like ] change-at -: thread ( id -- thread ) threads get-global at ; +: thread ( id -- thread ) threads at ; : ( quot name error-handler -- thread ) - \ thread counter H{ } clone { + \ thread counter { set-thread-quot set-thread-name set-thread-error-handler set-thread-id - set-thread-variables } \ thread construct ; -SYMBOL: run-queue -SYMBOL: sleep-queue +: run-queue 42 getenv ; + +: sleep-queue 43 getenv ; : resume ( thread -- ) - check-registered run-queue get-global push-front ; + check-registered run-queue push-front ; : resume-with ( obj thread -- ) - check-registered 2array run-queue get-global push-front ; + check-registered 2array run-queue push-front ; r check-registered r> sleep-queue get-global heap-push ; + >r check-registered r> sleep-queue heap-push ; : wake-up? ( heap -- ? ) dup heap-empty? [ drop f ] [ heap-peek nip millis <= ] if ; : wake-up ( -- ) - sleep-queue get-global + sleep-queue [ dup wake-up? ] [ dup heap-pop drop resume ] [ ] while drop ; @@ -92,7 +97,7 @@ SYMBOL: sleep-queue continue ] [ wake-up - run-queue get-global pop-back + run-queue pop-back dup array? [ first2 ] [ f swap ] if dup set-self dup thread-continuation f rot set-thread-continuation @@ -103,9 +108,9 @@ PRIVATE> : sleep-time ( -- ms ) { - { [ run-queue get-global dlist-empty? not ] [ 0 ] } - { [ sleep-queue get-global heap-empty? ] [ f ] } - { [ t ] [ sleep-queue get-global heap-peek nip millis [-] ] } + { [ run-queue dlist-empty? not ] [ 0 ] } + { [ sleep-queue heap-empty? ] [ f ] } + { [ t ] [ sleep-queue heap-peek nip millis [-] ] } } cond ; : stop ( -- ) @@ -160,9 +165,9 @@ PRIVATE> run-queue set-global - sleep-queue set-global - H{ } clone threads set-global + H{ } clone 41 setenv + 42 setenv + 43 setenv initial-thread global [ drop f "Initial" [ die ] ] cache f over set-thread-continuation diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor old mode 100644 new mode 100755 index 7c77ed98af..2d731dd830 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -17,7 +17,7 @@ IN: bunny.model } cond (parse-model) ] when* ; -: parse-model ( stream -- vs is ) +: parse-model ( -- vs is ) 100000 100000 (parse-model) ; : n ( vs triple -- n ) diff --git a/extra/channels/examples/examples.factor b/extra/channels/examples/examples.factor index dda2a4921b..993b1db1a4 100755 --- a/extra/channels/examples/examples.factor +++ b/extra/channels/examples/examples.factor @@ -28,7 +28,7 @@ IN: channels.examples [let | p [ c from ] newc [ ] | p prime to - [ newc p c filter ] spawn drop + [ newc p c filter ] "Filter" spawn drop prime newc (sieve) ] ; diff --git a/extra/channels/remote/remote.factor b/extra/channels/remote/remote.factor index b5a497b1fa..437a668a73 100755 --- a/extra/channels/remote/remote.factor +++ b/extra/channels/remote/remote.factor @@ -32,7 +32,7 @@ SYMBOL: no-channel receive [ { { { to ?id ?value } - [ ?value ?id get-channel [ to f ] [ no-channel ] if* ] } + [ ?value ?id get-channel dup [ to f ] [ 2drop no-channel ] if ] } { { from ?id } [ ?id get-channel [ from ] [ no-channel ] if* ] } } match-cond @@ -43,7 +43,7 @@ PRIVATE> : start-channel-node ( -- ) "remote-channels" get-process [ "remote-channels" - [ channel-process ] "Remote channels" spawn-server + [ channel-process t ] "Remote channels" spawn-server register-process ] unless ; diff --git a/extra/concurrency/combinators/combinators-docs.factor b/extra/concurrency/combinators/combinators-docs.factor new file mode 100755 index 0000000000..0db235d9e6 --- /dev/null +++ b/extra/concurrency/combinators/combinators-docs.factor @@ -0,0 +1,25 @@ +USING: help.markup help.syntax sequences ; +IN: concurrency.combinators + +HELP: parallel-map +{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- newelt )" } } { "newseq" sequence } } +{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", collecting the results at the end." } +{ $errors "Throws an error if one of the iterations throws an error." } ; + +HELP: parallel-each +{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } } +{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", blocking until all quotations complete." } +{ $errors "Throws an error if one of the iterations throws an error." } ; + +HELP: parallel-subset +{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "newseq" sequence } } +{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", collecting the elements for which the quotation yielded a true value." } +{ $errors "Throws an error if one of the iterations throws an error." } ; + +ARTICLE: "concurrency.combinators" "Concurrent combinators" +"The " { $vocab-link "concurrency.combinators" } " vocabulary provides concurrent variants of " { $link each } ", " { $link map } " and " { $link subset } ":" +{ $subsection parallel-each } +{ $subsection parallel-map } +{ $subsection parallel-subset } ; + +ABOUT: "concurrency.combinators" diff --git a/extra/concurrency/combinators/combinators-tests.factor b/extra/concurrency/combinators/combinators-tests.factor new file mode 100755 index 0000000000..ed59034835 --- /dev/null +++ b/extra/concurrency/combinators/combinators-tests.factor @@ -0,0 +1,24 @@ +IN: temporary +USING: concurrency.combinators tools.test random kernel math +concurrency.messaging threads sequences ; + +[ [ drop ] parallel-each ] must-infer +[ [ ] parallel-map ] must-infer +[ [ ] parallel-subset ] must-infer + +[ { 1 4 9 } ] [ { 1 2 3 } [ sq ] parallel-map ] unit-test + +[ { 1 4 9 } ] [ { 1 2 3 } [ 1000 random sleep sq ] parallel-map ] unit-test + +[ { 1 2 3 } [ dup 2 mod 0 = [ "Even" throw ] when ] parallel-map ] +[ linked-error "Even" = ] must-fail-with + +[ V{ 0 3 6 9 } ] +[ 10 [ 3 mod zero? ] parallel-subset ] unit-test + +[ 10 ] +[ + V{ } clone + 10 over [ push ] curry parallel-each + length +] unit-test diff --git a/extra/concurrency/combinators/combinators.factor b/extra/concurrency/combinators/combinators.factor index 5e19baf393..76c3cfa77d 100755 --- a/extra/concurrency/combinators/combinators.factor +++ b/extra/concurrency/combinators/combinators.factor @@ -9,5 +9,9 @@ IN: concurrency.combinators inline : parallel-each ( seq quot -- ) - "Parallel each" pick length - [ [ spawn-stage ] 2curry each ] keep await ; inline + over length + [ [ >r curry r> spawn-stage ] 2curry each ] keep await ; + inline + +: parallel-subset ( seq quot -- newseq ) + over >r pusher >r each r> r> like ; inline diff --git a/extra/concurrency/combinators/summary.txt b/extra/concurrency/combinators/summary.txt new file mode 100755 index 0000000000..ae64ac5c9c --- /dev/null +++ b/extra/concurrency/combinators/summary.txt @@ -0,0 +1 @@ +Parallel sequence operations diff --git a/extra/concurrency/conditions/conditions.factor b/extra/concurrency/conditions/conditions.factor index f94cfe6cca..b93658b9f1 100755 --- a/extra/concurrency/conditions/conditions.factor +++ b/extra/concurrency/conditions/conditions.factor @@ -1,13 +1,13 @@ -! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. +! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: dlists threads kernel arrays sequences ; IN: concurrency.conditions : notify-1 ( dlist -- ) - dup dlist-empty? [ pop-back resume ] [ drop ] if ; + dup dlist-empty? [ drop ] [ pop-back second resume ] if ; : notify-all ( dlist -- ) [ second resume ] dlist-slurp yield ; -: wait ( queue timeout -- queue timeout ) +: wait ( queue timeout -- ) [ 2array swap push-front ] suspend 3drop ; inline diff --git a/extra/concurrency/conditions/summary.txt b/extra/concurrency/conditions/summary.txt new file mode 100755 index 0000000000..7441ca5d5f --- /dev/null +++ b/extra/concurrency/conditions/summary.txt @@ -0,0 +1 @@ +Low-level wait/notify support diff --git a/extra/concurrency/count-downs/count-downs-docs.factor b/extra/concurrency/count-downs/count-downs-docs.factor new file mode 100755 index 0000000000..5da10f7b57 --- /dev/null +++ b/extra/concurrency/count-downs/count-downs-docs.factor @@ -0,0 +1,24 @@ +USING: help.markup help.syntax sequences ; +IN: concurrency.count-downs + +HELP: +{ $values { "n" "a non-negative integer" } { "count-down" count-down } } +{ $description "Creates a new count-down latch." } +{ $errors "Throws an error if the count is lower than zero." } ; + +HELP: count-down +{ $values { "count-down" count-down } } +{ $description "Decrements a count-down latch. If it reaches zero, all threads blocking on " { $link await } " are notified." } +{ $errors "Throws an error if an attempt is made to decrement the count lower than zero." } ; + +HELP: await +{ $values { "count-down" count-down } } +{ $description "Waits until the count-down value reaches zero." } ; + +ARTICLE: "concurrency.count-downs" "Count-down latches" +"The " { $vocab-link "concurrency.count-downs" } " vocabulary implements the " { $emphasis "count-down latch" } " data type, whichis a wrapper for a non-negative integer value which tends towards zero. A thread can either decrement the value, or wait for it to become zero." +{ $subsection } +{ $subsection count-down } +{ $subsection await } ; + +ABOUT: "concurrency.count-downs" diff --git a/extra/concurrency/count-downs/count-downs-tests.factor b/extra/concurrency/count-downs/count-downs-tests.factor new file mode 100755 index 0000000000..f6bd64234f --- /dev/null +++ b/extra/concurrency/count-downs/count-downs-tests.factor @@ -0,0 +1,16 @@ +USING: concurrency.count-downs threads kernel tools.test ; +IN: temporary` + +[ ] [ 0 await ] unit-test + +[ 1 dup count-down count-down ] must-fail + +[ ] [ + 1 + 3 + 2dup [ await count-down ] 2curry "Master" spawn drop + dup [ count-down ] curry "Slave" spawn drop + dup [ count-down ] curry "Slave" spawn drop + dup [ count-down ] curry "Slave" spawn drop + drop await +] unit-test diff --git a/extra/concurrency/count-downs/count-downs.factor b/extra/concurrency/count-downs/count-downs.factor index 122076eeb1..61dd366c77 100755 --- a/extra/concurrency/count-downs/count-downs.factor +++ b/extra/concurrency/count-downs/count-downs.factor @@ -8,25 +8,32 @@ IN: concurrency.count-downs TUPLE: count-down n promise ; +: count-down-check ( count-down -- ) + dup count-down-n zero? [ + t swap count-down-promise fulfill + ] [ drop ] if ; + : ( n -- count-down ) - count-down construct-boa ; + dup 0 < [ "Invalid count for count down" throw ] when + \ count-down construct-boa + dup count-down-check ; : count-down ( count-down -- ) dup count-down-n dup zero? [ "Count down already done" throw ] [ - 1- dup pick set-count-down-n - zero? [ - t swap count-down-promise fulfill - ] [ drop ] if + 1- over set-count-down-n + count-down-check ] if ; : await-timeout ( count-down timeout -- ) >r count-down-promise r> ?promise-timeout drop ; -: spawn-stage ( quot name count-down -- ) - count-down-promise - promise-mailbox spawn-linked-to drop ; - : await ( count-down -- ) f await-timeout ; + +: spawn-stage ( quot count-down -- ) + [ [ count-down ] curry compose ] keep + "Count down stage" + swap count-down-promise + promise-mailbox spawn-linked-to drop ; diff --git a/extra/concurrency/count-downs/summary.txt b/extra/concurrency/count-downs/summary.txt new file mode 100755 index 0000000000..1992a149af --- /dev/null +++ b/extra/concurrency/count-downs/summary.txt @@ -0,0 +1 @@ +Count-down latches diff --git a/extra/concurrency/distributed/distributed-docs.factor b/extra/concurrency/distributed/distributed-docs.factor index ad9e392771..4fae6ddbcc 100755 --- a/extra/concurrency/distributed/distributed-docs.factor +++ b/extra/concurrency/distributed/distributed-docs.factor @@ -1,7 +1,20 @@ -USING: help.markup help.syntax concurrency.messaging ; +USING: help.markup help.syntax concurrency.messaging threads ; IN: concurrency.distributed HELP: local-node { $values { "addrspec" "an address specifier" } } { $description "Return the node the current thread is running on." } ; + +HELP: start-node +{ $values { "port" "a port number between 0 and 65535" } } +{ $description "Starts a node server for receiving messages from remote Factor instances." } ; + +ARTICLE: "concurrency.distributed" "Distributed message passing" +"The " { $vocab-link "concurrency.distributed" } " implements transparent distributed message passing." +{ $subsection start-node } +"Instances of " { $link thread } " can be sent to remote processes, at which point they are converted to objects holding the thread ID and the current node's host name:" +{ $subsection remote-process } +"The " { $vocab-link "serialize" } " vocabulary is used to convert Factor objects to byte arrays for transfer over a socket." ; + +ABOUT: "concurrency.distributed" diff --git a/extra/concurrency/exchangers/exchangers-docs.factor b/extra/concurrency/exchangers/exchangers-docs.factor new file mode 100755 index 0000000000..6df3729e41 --- /dev/null +++ b/extra/concurrency/exchangers/exchangers-docs.factor @@ -0,0 +1,22 @@ +USING: help.markup help.syntax sequences kernel ; +IN: concurrency.exchangers + +HELP: exchanger +{ $class-description "The class of object exchange points." } ; + +HELP: +{ $values { "exchanger" exchanger } } +{ $description "Creates a new object exchange point." } ; + +HELP: exchange +{ $values { "obj" object } { "exchanger" exchanger } { "newobj" object } } +{ $description "Waits for another thread to call " { $link exchange } " on the same exchanger. The thread's call to " { $link exchange } " returns with " { $snippet "obj" } " on the stack, and the object passed to " { $link exchange } " by the other thread is left on the current's thread stack as " { $snippet "newobj" } "." } ; + +ARTICLE: "concurrency.exchangers" "Object exchange points" +"The " { $vocab-link "concurrency.exchangers" } " vocabulary implements " { $emphasis "object exchange points" } ", which are rendezvous points where two threads can exchange objects." +{ $subsection exchanger } +{ $subsection } +{ $subsection exchange } +"One use-case is two threads, where one thread reads data into a buffer and another thread processes the data. The reader thread can begin by reading the data, then passing the buffer through an exchanger, then recursing. The processing thread can begin by creating an empty buffer, and exchanging it through the exchanger. It then processes the result and recurses." ; + +ABOUT: "concurrency.exchangers" diff --git a/extra/concurrency/exchangers/exchangers-tests.factor b/extra/concurrency/exchangers/exchangers-tests.factor new file mode 100755 index 0000000000..3e7f67b9f0 --- /dev/null +++ b/extra/concurrency/exchangers/exchangers-tests.factor @@ -0,0 +1,30 @@ +IN: temporary +USING: sequences tools.test concurrency.exchangers +concurrency.count-downs concurrency.promises locals kernel +threads ; + +:: exchanger-test | | + [let | + ex [ ] + c [ 2 ] + v1! [ f ] + v2! [ f ] + pr [ ] | + + [ + c await + v1 ", " v2 3append pr fulfill + ] "Awaiter" spawn drop + + [ + "Goodbye world" ex exchange v1! c count-down + ] "Exchanger 1" spawn drop + + [ + "Hello world" ex exchange v2! c count-down + ] "Exchanger 2" spawn drop + + pr ?promise + ] ; + +[ "Hello world, Goodbye world" ] [ exchanger-test ] unit-test diff --git a/extra/concurrency/exchangers/exchangers.factor b/extra/concurrency/exchangers/exchangers.factor index e2c701c7a9..f857cb62f2 100755 --- a/extra/concurrency/exchangers/exchangers.factor +++ b/extra/concurrency/exchangers/exchangers.factor @@ -6,16 +6,21 @@ IN: concurrency.exchangers ! Motivated by ! http://java.sun.com/j2se/1.5.0/docs/api/java/util/concurrent/Exchanger.html -TUPLE: exchanger thread ; +TUPLE: exchanger thread object ; : ( -- exchanger ) - f exchanger construct-boa ; + f f exchanger construct-boa ; + +: pop-object ( exchanger -- obj ) + dup exchanger-object f rot set-exchanger-object ; + +: pop-thread ( exchanger -- thread ) + dup exchanger-thread f rot set-exchanger-thread ; : exchange ( obj exchanger -- newobj ) dup exchanger-thread [ - dup exchanger-thread - f rot set-exchanger-thread - resume-with + dup pop-object >r pop-thread resume-with r> ] [ + [ set-exchanger-object ] keep [ set-exchanger-thread ] curry suspend ] if ; diff --git a/extra/concurrency/exchangers/exchangers.txt b/extra/concurrency/exchangers/exchangers.txt deleted file mode 100644 index ea69c91e03..0000000000 --- a/extra/concurrency/exchangers/exchangers.txt +++ /dev/null @@ -1 +0,0 @@ -Thread rendezvous points diff --git a/extra/concurrency/exchangers/summary.txt b/extra/concurrency/exchangers/summary.txt new file mode 100755 index 0000000000..c403f5a6e2 --- /dev/null +++ b/extra/concurrency/exchangers/summary.txt @@ -0,0 +1 @@ +Object exchange points diff --git a/extra/concurrency/futures/futures-docs.factor b/extra/concurrency/futures/futures-docs.factor new file mode 100755 index 0000000000..99b4bb6e81 --- /dev/null +++ b/extra/concurrency/futures/futures-docs.factor @@ -0,0 +1,29 @@ +! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: concurrency.promises concurrency.messaging kernel arrays +continuations help.markup help.syntax quotations ; +IN: concurrency.futures + +HELP: future +{ $values { "quot" "a quotation with stack effect " { $snippet "( -- value )" } } { "future" future } } +{ $description "Creates a deferred computation." +$nl +"The quotation begins with an empty data stack, an empty catch stack, and a name stack containing the global namespace only. This means that the only way to pass data to the quotation is to partially apply the data, for example using " { $link curry } " or " { $link compose } "." } ; + +HELP: ?future-timeout +{ $values { "future" future } { "timeout" "a timeout in milliseconds or " { $link f } } { "value" object } } +{ $description "Waits for a deferred computation to complete, blocking indefinitely if " { $snippet "timeout" } " is " { $link f } ", otherwise waiting up to " { $snippet "timeout" } " milliseconds." } +{ $errors "Throws an error if the timeout expires before the computation completes. Also throws an error if the future quotation threw an error." } ; + +HELP: ?future +{ $values { "future" future } { "value" object } } +{ $description "Waits for a deferred computation to complete, blocking indefinitely." } +{ $errors "Throws an error if future quotation threw an error." } ; + +ARTICLE: "concurrency.futures" "Futures" +"The " { $vocab-link "concurrency.futures" } " vocabulary implements " { $emphasis "futures" } ", which are deferred computations performed in a background thread. A thread may create a future, then proceed to perform other tasks, then later wait for the future to complete." +{ $subsection future } +{ $subsection ?future } +{ $subsection ?future-timeout } ; + +ABOUT: "concurrency.futures" diff --git a/extra/concurrency/futures/futures-tests.factor b/extra/concurrency/futures/futures-tests.factor new file mode 100755 index 0000000000..39299f9cf7 --- /dev/null +++ b/extra/concurrency/futures/futures-tests.factor @@ -0,0 +1,25 @@ +IN: temporary +USING: concurrency.futures kernel tools.test threads ; + +[ 50 ] [ + [ 50 ] future ?future +] unit-test + +[ + [ "this should propogate" throw ] future ?future +] must-fail + +[ ] [ + [ "this should not propogate" throw ] future drop +] unit-test + +! Race condition with futures +[ 3 3 ] [ + [ 3 ] future + dup ?future swap ?future +] unit-test + +! Another race +[ 3 ] [ + [ 3 yield ] future ?future +] unit-test diff --git a/extra/concurrency/locks/locks-docs.factor b/extra/concurrency/locks/locks-docs.factor new file mode 100755 index 0000000000..86db5914c9 --- /dev/null +++ b/extra/concurrency/locks/locks-docs.factor @@ -0,0 +1,60 @@ +USING: help.markup help.syntax sequences kernel quotations ; +IN: concurrency.locks + +HELP: lock +{ $class-description "The class of mutual exclusion locks." } ; + +HELP: +{ $values { "lock" lock } } +{ $description "Creates a non-reentrant lock." } ; + +HELP: +{ $values { "lock" lock } } +{ $description "Creates a reentrant lock." } ; + +HELP: with-lock +{ $values { "lock" lock } { "timeout" "a timeout in milliseconds or " { $link f } } { "quot" quotation } } +{ $description "Calls the quotation, ensuring that only one thread executes with the lock held at a time. If another thread is holding the lock, blocks until the thread releases the lock." } +{ $errors "Throws an error if the lock could not be acquired before the timeout expires. A timeout value of " { $link f } " means the thread is willing to wait indefinitely." } ; + +ARTICLE: "concurrency.locks.mutex" "Mutual-exclusion locks" +"A mutual-exclusion lock ensures that only one thread executes with the lock held at a time. They are used to protect critical sections so that certain operations appear to be atomic to other threads." +$nl +"There are two varieties of locks: non-reentrant and reentrant. The latter may be acquired recursively by the same thread. Attempting to do so with the former will deadlock." +{ $subsection lock } +{ $subsection } +{ $subsection } +{ $subsection with-lock } ; + +HELP: rw-lock +{ $class-description "The class of reader/writer locks." } ; + +HELP: with-read-lock +{ $values { "lock" lock } { "timeout" "a timeout in milliseconds or " { $link f } } { "quot" quotation } } +{ $description "Calls the quotation, ensuring that no other thread is holding a write lock at the same time. If another thread is holding a write lock, blocks until the thread releases the lock." } +{ $errors "Throws an error if the lock could not be acquired before the timeout expires. A timeout value of " { $link f } " means the thread is willing to wait indefinitely." } ; + +HELP: with-write-lock +{ $values { "lock" lock } { "timeout" "a timeout in milliseconds or " { $link f } } { "quot" quotation } } +{ $description "Calls the quotation, ensuring that no other thread is holding a read or write lock at the same time. If another thread is holding a read or write lock, blocks until the thread releases the lock." } +{ $errors "Throws an error if the lock could not be acquired before the timeout expires. A timeout value of " { $link f } " means the thread is willing to wait indefinitely." } ; + +ARTICLE: "concurrency.locks.rw" "Read-write locks" +"A read-write lock encapsulates a common pattern in the implementation of concurrent data structures, where one wishes to ensure that a thread is able to see a consistent view of the structure for a period of time, during which no other thread modifies the structure." +$nl +"While this can be achieved with a simple " { $link "concurrency.locks.mutex" } ", performance will suffer, since in fact multiple threads can view the structure at the same time; serialization must only be enforced for writes." +$nl +"Read/write locks allow any number of threads to hold the read lock simulateneously, however attempting to acquire a write lock blocks until all other threads release read locks and write locks." +$nl +"Read/write locks are reentrant. A thread holding a read lock may acquire a write lock recursively, and a thread holding a write lock may acquire a write lock or a read lock recursively, however a thread holding a read lock may not acquire a write lock recursively since that could break invariants assumed by the code executing with the read lock held." +{ $subsection rw-lock } +{ $subsection } +{ $subsection with-read-lock } +{ $subsection with-write-lock } ; + +ARTICLE: "concurrency.locks" "Locks" +"A " { $emphasis "lock" } " is an object protecting a critical region of code, enforcing a particular mutual-exclusion policy. The " { $vocab-link "concurrency.locks" } " vocabulary implements two types of locks:" +{ $subsection "concurrency.locks.mutex" } +{ $subsection "concurrency.locks.rw" } ; + +ABOUT: "concurrency.locks" diff --git a/extra/concurrency/locks/locks-tests.factor b/extra/concurrency/locks/locks-tests.factor new file mode 100755 index 0000000000..4c1d280cd6 --- /dev/null +++ b/extra/concurrency/locks/locks-tests.factor @@ -0,0 +1,159 @@ +IN: temporary +USING: tools.test concurrency.locks concurrency.count-downs +locals kernel threads sequences ; + +:: lock-test-0 | | + [let | v [ V{ } clone ] + c [ 2 ] | + + [ + yield + 1 v push + yield + 2 v push + c count-down + ] "Lock test 1" spawn drop + + [ + yield + 3 v push + yield + 4 v push + c count-down + ] "Lock test 2" spawn drop + + c await + v + ] ; + +:: lock-test-1 | | + [let | v [ V{ } clone ] + l [ ] + c [ 2 ] | + + [ + l f [ + yield + 1 v push + yield + 2 v push + ] with-lock + c count-down + ] "Lock test 1" spawn drop + + [ + l f [ + yield + 3 v push + yield + 4 v push + ] with-lock + c count-down + ] "Lock test 2" spawn drop + + c await + v + ] ; + +[ V{ 1 3 2 4 } ] [ lock-test-0 ] unit-test +[ V{ 1 2 3 4 } ] [ lock-test-1 ] unit-test + +[ 3 ] [ + dup f [ + f [ + 3 + ] with-lock + ] with-lock +] unit-test + +[ ] [ drop ] unit-test + +[ ] [ f [ ] with-read-lock ] unit-test + +[ ] [ dup f [ f [ ] with-read-lock ] with-read-lock ] unit-test + +[ ] [ f [ ] with-write-lock ] unit-test + +[ ] [ dup f [ f [ ] with-write-lock ] with-write-lock ] unit-test + +[ ] [ dup f [ f [ ] with-read-lock ] with-write-lock ] unit-test + +:: rw-lock-test-1 | | + [let | l [ ] + c [ 1 ] + c' [ 1 ] + c'' [ 4 ] + v [ V{ } clone ] | + + [ + l f [ + 1 v push + c count-down + yield + 3 v push + ] with-read-lock + c'' count-down + ] "R/W lock test 1" spawn drop + + [ + c await + l f [ + 4 v push + 1000 sleep + 5 v push + ] with-write-lock + c'' count-down + ] "R/W lock test 2" spawn drop + + [ + c await + l f [ + 2 v push + c' count-down + ] with-read-lock + c'' count-down + ] "R/W lock test 4" spawn drop + + [ + c' await + l f [ + 6 v push + ] with-write-lock + c'' count-down + ] "R/W lock test 5" spawn drop + + c'' await + v + ] ; + +[ V{ 1 2 3 4 5 6 } ] [ rw-lock-test-1 ] unit-test + +:: rw-lock-test-2 | | + [let | l [ ] + c [ 1 ] + c' [ 2 ] + v [ V{ } clone ] | + + [ + l f [ + 1 v push + c count-down + 1000 sleep + 2 v push + ] with-write-lock + c' count-down + ] "R/W lock test 1" spawn drop + + [ + c await + l f [ + 3 v push + ] with-read-lock + c' count-down + ] "R/W lock test 2" spawn drop + + c' await + v + ] ; + +[ V{ 1 2 3 } ] [ rw-lock-test-2 ] unit-test diff --git a/extra/concurrency/locks/locks.factor b/extra/concurrency/locks/locks.factor index 50a62e3f6f..663b22d626 100755 --- a/extra/concurrency/locks/locks.factor +++ b/extra/concurrency/locks/locks.factor @@ -5,9 +5,13 @@ concurrency.conditions ; IN: concurrency.locks ! Simple critical sections -TUPLE: lock threads owner ; +TUPLE: lock threads owner reentrant? ; -: lock construct-boa ; +: ( -- lock ) + f f lock construct-boa ; + +: ( -- lock ) + f t lock construct-boa ; r >r pick r> call over r> curry [ ] cleanup ; inline + >r swap compose pick >r 2curry r> r> curry [ ] cleanup ; + inline + +: (with-lock) ( lock timeout quot -- ) + [ acquire-lock ] [ release-lock ] do-lock ; inline PRIVATE> : with-lock ( lock timeout quot -- ) - [ acquire-lock ] [ release-lock ] do-lock ; inline - -: with-reentrant-lock ( lock timeout quot -- ) - over lock-owner self eq? - [ nip call ] [ with-lock ] if ; inline + pick lock-reentrant? [ + pick lock-owner self eq? [ + 2nip call + ] [ + (with-lock) + ] if + ] [ + (with-lock) + ] if ; inline ! Many-reader/single-writer locks TUPLE: rw-lock readers writers reader# writer ; @@ -40,8 +52,8 @@ TUPLE: rw-lock readers writers reader# writer ; r rw-lock-readers r> wait ] when drop dup rw-lock-reader# 1+ swap set-rw-lock-reader# ; @@ -52,8 +64,8 @@ TUPLE: rw-lock readers writers reader# writer ; dup rw-lock-reader# 1- dup pick set-rw-lock-reader# zero? [ notify-writer ] [ drop ] if ; -: acquire-write-lock ( lock -- ) - dup rw-lock-writer over rw-lock-reader# 0 > or +: acquire-write-lock ( lock timeout -- ) + over rw-lock-writer pick rw-lock-reader# 0 > or [ 2dup >r rw-lock-writers r> wait ] when drop self swap set-rw-lock-writer ; @@ -62,7 +74,7 @@ TUPLE: rw-lock readers writers reader# writer ; dup rw-lock-readers dlist-empty? [ notify-writer ] [ rw-lock-readers notify-all ] if ; -: do-recursive-rw-lock ( lock timeout quot quot' -- ) +: do-reentrant-rw-lock ( lock timeout quot quot' -- ) >r pick rw-lock-writer self eq? [ 2nip call ] r> if ; inline PRIVATE> @@ -70,9 +82,9 @@ PRIVATE> : with-read-lock ( lock timeout quot -- ) [ [ acquire-read-lock ] [ release-read-lock ] do-lock - ] do-recursive-rw-lock ; inline + ] do-reentrant-rw-lock ; inline : with-write-lock ( lock timeout quot -- ) [ [ acquire-write-lock ] [ release-write-lock ] do-lock - ] do-recursive-rw-lock ; inline + ] do-reentrant-rw-lock ; inline diff --git a/extra/concurrency/messaging/messaging-docs.factor b/extra/concurrency/messaging/messaging-docs.factor index a22014a106..45bf2006e0 100755 --- a/extra/concurrency/messaging/messaging-docs.factor +++ b/extra/concurrency/messaging/messaging-docs.factor @@ -1,13 +1,13 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: help.syntax help.markup concurrency.messaging.private -threads ; +threads kernel arrays quotations ; IN: concurrency.messaging HELP: { $values { "mailbox" mailbox } } -{ $description "A mailbox is an object that can be used for safe thread communication. Items can be put in the mailbox and retrieved in a FIFO order. If the mailbox is empty when a get operation is performed then the thread will block until another thread places something in the mailbox. If multiple threads are waiting on the same mailbox, only one of the waiting threads will be unblocked to process the get operation." } +{ $description "A mailbox is an object that can be used for safe thread communication. Items can be put in the mailbox and retrieved in a FIFO order. If the mailbox is empty when a get operation is performed then the thread will block until another thread places something in the mailbox. If multiple threads are waiting on the same mailbox, only one of the waiting threads will be unblocked to thread the get operation." } { $see-also mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ; HELP: mailbox-empty? @@ -18,7 +18,7 @@ HELP: mailbox-empty? { $see-also mailbox-put mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ; HELP: mailbox-put -{ $values { "obj" "an object" } +{ $values { "obj" object } { "mailbox" mailbox } } { $description "Put the object into the mailbox. Any threads that have a blocking get on the mailbox are resumed. Only one of those threads will successfully get the object, the rest will immediately block waiting for the next item in the mailbox." } @@ -27,29 +27,28 @@ HELP: mailbox-put HELP: block-unless-pred { $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } } { "mailbox" mailbox } - { "timeout" "a timeout in milliseconds" } + { "timeout" "a timeout in milliseconds, or " { $link f } } } { $description "Block the thread if there are no items in the mailbox that return true when the predicate is called with the item on the stack." } { $see-also mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ; HELP: block-if-empty { $values { "mailbox" mailbox } - { "mailbox2" "same object as 'mailbox'" } - { "timeout" "a timeout in milliseconds" } + { "timeout" "a timeout in milliseconds, or " { $link f } } } { $description "Block the thread if the mailbox is empty." } { $see-also mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ; HELP: mailbox-get { $values { "mailbox" mailbox } - { "obj" "an object" } + { "obj" object } } { $description "Get the first item put into the mailbox. If it is empty the thread blocks until an item is put into it. The thread then resumes, leaving the item on the stack." } { $see-also mailbox-empty? mailbox-put while-mailbox-empty mailbox-get-all mailbox-get? } ; HELP: mailbox-get-all { $values { "mailbox" mailbox } - { "array" "an array" } + { "array" array } } { $description "Blocks the thread if the mailbox is empty, otherwise removes all objects in the mailbox and returns an array containing the objects." } { $see-also mailbox-empty? mailbox-put while-mailbox-empty mailbox-get-all mailbox-get? } ; @@ -64,67 +63,93 @@ HELP: while-mailbox-empty HELP: mailbox-get? { $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } } { "mailbox" mailbox } - { "obj" "an object" } + { "obj" object } } { $description "Get the first item in the mailbox which satisfies the predicate. 'pred' will be called repeatedly for each item in the mailbox. When 'pred' returns true that item will be returned. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } { $see-also mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty } ; HELP: send -{ $values { "message" "an object" } - { "process" "a process object" } +{ $values { "message" object } + { "thread" "a thread object" } } -{ $description "Send the message to the process by placing it in the processes mailbox. This is an asynchronous operation and will return immediately. The receving process will act on the message the next time it retrieves that item from its mailbox (usually using the " { $link receive } " word. The message can be any Factor object. For destinations that are instances of remote-process the message must be a serializable Factor type." } +{ $description "Send the message to the thread by placing it in the threades mailbox. This is an asynchronous operation and will return immediately. The receving thread will act on the message the next time it retrieves that item from its mailbox (usually using the " { $link receive } " word. The message can be any Factor object. For destinations that are instances of remote-thread the message must be a serializable Factor type." } { $see-also receive receive-if } ; HELP: receive -{ $values { "message" "an object" } +{ $values { "message" object } } -{ $description "Return a message from the current processes mailbox. If the box is empty, suspend the process until another process places an item in the mailbox (usually via the " { $link send } " word." } +{ $description "Return a message from the current threades mailbox. If the box is empty, suspend the thread until another thread places an item in the mailbox (usually via the " { $link send } " word." } { $see-also send receive-if } ; HELP: receive-if -{ $values { "pred" "a predicate with stack effect " { $snippet "( X -- bool )" } } - { "message" "an object" } +{ $values { "pred" "a predicate with stack effect " { $snippet "( obj -- ? )" } } + { "message" object } } -{ $description "Return the first message from the current processes mailbox that satisfies the predicate. To satisfy the predicate, 'pred' is called with the item on the stack and the predicate should leave a boolean indicating whether it was satisfied or not. If nothing in the mailbox satisfies the predicate then the process will block until something does." } +{ $description "Return the first message from the current threades mailbox that satisfies the predicate. To satisfy the predicate, " { $snippet "pred" } " is called with the item on the stack and the predicate should leave a boolean indicating whether it was satisfied or not. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } { $see-also send receive } ; HELP: spawn-linked -{ $values { "quot" "a predicate with stack effect " { $snippet "( -- )" } } - { "process" "a process object" } +{ $values { "quot" quotation } + { "thread" "a thread object" } } -{ $description "Start a process which runs the given quotation. If that quotation throws an error which is not caught then the error will get propagated to the process that spawned it. This can be used to set up 'supervisor' processes that restart child processes that crash due to uncaught errors.\n" } +{ $description "Start a thread which runs the given quotation. If that quotation throws an error which is not caught then the error will get propagated to the thread that spawned it. This can be used to set up 'supervisor' threades that restart child threades that crash due to uncaught errors.\n" } { $see-also spawn } ; -ARTICLE: { "concurrency" "processes" } "Processes" -"A process is basically a thread with a message queue. Other processes can place items on this queue by sending the process a message. A process can check its queue for messages, blocking if none are pending, and process them as they are queued.\n\nFactor processes are very lightweight. Each process can take as little as 900 bytes of memory. This library has been tested running hundreds of thousands of simple processes.\n\nThe messages that are sent from process to process are any Factor value. Factor tuples are ideal for this sort of thing as you can send a tuple to a process and the predicate dispatch mechanism can be used to perform actions depending on what the type of the tuple is.\n\nProcesses are usually created using " { $link spawn } ". This word takes a quotation on the stack and starts a process that will execute that quotation asynchronously. When the quotation completes the process will die. 'spawn' leaves on the stack the process object that was started. This object can be used to send messages to the process using " { $link send } ".\n\n'send' will return immediately after placing the message in the target processes message queue.\n\nA process can get a message from its queue using " { $link receive } ". This will get the most recent message and leave it on the stack. If there are no messages in the queue the process will 'block' until a message is available. When a process is blocked it takes no CPU time at all." -{ $code "[ receive print ] spawn\n\"Hello Process!\" swap send" } -"This example spawns a process that first blocks, waiting to receive a message. When a message is received, the 'receive' call returns leaving it on the stack. It then prints the message and exits. 'spawn' left the process on the stack so it's available to send the 'Hello Process!' message to it. Immediately after the 'send' you should see 'Hello Process!' printed on the console.\n\nIt is also possible to selectively retrieve messages from the message queue. " { $link receive-if } " takes a predicate quotation on the stack and returns the first message in the queue that satisfies the predicate. If no items satisfy the predicate then the process is blocked until a message is received that does." -{ $code ": odd? ( n -- ? ) 2 mod 1 = ;\n1 self send 2 self send 3 self send\n\nreceive .\n => 1\n\n[ odd? ] receive-if .\n => 3\n\nreceive .\n => 2" } ; +ARTICLE: { "concurrency" "mailboxes" } "Mailboxes" +"Each thread has an associated message queue. Other threads can place items on this queue by sending the thread a message. A thread can check its queue for messages, blocking if none are pending, and thread them as they are queued." +$nl +"The messages that are sent from thread to thread are any Factor value. Factor tuples are ideal for this sort of thing as you can send a tuple to a thread and the generic word dispatch mechanism can be used to perform actions depending on what the type of the tuple is." +$nl +"The " { $link spawn } " word pushes the newly-created thread on the calling thread's stack; this thread object can then be sent messages:" +{ $subsection send } +"A thread can get a message from its queue:" +{ $subsection receive } +{ $subsection receive } +{ $subsection receive-if } +"Mailboxes can be created and used directly:" +{ $subsection mailbox } +{ $subsection } +{ $subsection mailbox-get } +{ $subsection mailbox-put } +{ $subsection mailbox-empty? } ; -ARTICLE: { "concurrency" "self" } "Self" -"A process can get access to its own process object using " { $link self } " so it can pass it to other processes. This allows the other processes to send messages back. A simple example of using this gets the current process' 'self' and spawns a process which sends a message to it. We then receive the message from the original process:" -{ $code "self [ \"Hello!\" swap send ] spawn 2drop receive .\n => \"Hello!\"" } ; +ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends" +"The " { $link send } " word sends a message asynchronously, and the sending thread continues immediately. It is also possible to send a message to a thread and block until a response is received:" +{ $subsection send-synchronous } +"To reply to a synchronous message:" +{ $subsection reply-synchronous } +"An example:" +{ $example + "USING: concurrency.messaging kernel threads ;" + ": pong-server ( -- )" + " receive >r \"pong\" r> reply-synchronous ;" + "[ pong-server t ] spawn-server" + "\"ping\" swap send-synchronous ." + "\"pong\"" +} ; -ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous Sends" -{ $link send } " sends a message asynchronously, and the sending process continues immediately. The 'pong server' example shown previously all sent messages to the server and waited for a reply back from the server. This pattern of synchronous sending is made easier with " { $link send-synchronous } ".\n\nThis word will send a message to the given process and immediately block until a reply is received for this particular message send. It leaves the reply on the stack. Note that it doesn't wait for just any reply, it waits for a reply specifically to this send.\n\nTo do this it wraps the requested message inside a tagged message format using " { $link } ":" -{ $code "\"My Message\" .\n => T{ synchronous f \"My Message\" ...from... ...tag... }" } -"The message is wrapped in array where the first item is the sending process object, the second is a unique tag, and the third is the original message. Server processes can use the 'from' to reply to the process that originally sent the message. The tag is used in the receiving server to include the value in the reply. After the send-synchronous call the current process will block waiting for a reply that has the exact same tag. In this way you can be sure that the reply you got was for the specific message sent. Here is the pong-server recoded to use 'send-synchronous':" -{ $code ": pong-server ( -- )\n receive {\n { { ?from ?tag \"ping\" } [ ?tag \"pong\" 2array ?from send pong-server ] }\n { { ?from _ } [ ?tag \"server shutdown\" 2array ?from send ] }\n } match-cond ;\n\n[ pong-server ] spawn \"ping\" swap send-synchronous .\n => \"pong\"" } -"Notice that the code to send the reply back to the original caller wraps the reply in an array where the first item is the tag originally sent. 'send-synchronous' only returns if it receives a reply containing that specific tag." ; - -ARTICLE: { "concurrency" "exceptions" } "Exceptions" -"A process can handle exceptions using the standard Factor exception handling mechanism. If an exception is uncaught the process will terminate. For example:" +ARTICLE: { "concurrency" "exceptions" } "Linked exceptions" +"A thread can handle exceptions using the standard Factor exception handling mechanism. If an exception is uncaught the thread will terminate. For example:" { $code "[ 1 0 / \"This will not print\" print ] spawn" } -"Processes can be linked so that a parent process can receive the exception that caused the child process to terminate. In this way 'supervisor' processes can be created that are notified when child processes terminate and possibly restart them.\n\nThe easiest way to form this link is using " { $link spawn-linked } ". This will create a unidirectional link, such that if an uncaught exception causes the child to terminate, the parent process can catch it:" -{ $code "[\n [ 1 0 / \"This will not print\" print ] spawn-link drop\n receive\n] [ \"Exception caught.\" print ] recover" } +"Processes can be linked so that a parent thread can receive the exception that caused the child thread to terminate. In this way 'supervisor' threades can be created that are notified when child threades terminate and possibly restart them." +{ $subsection spawn-linked } +"A more flexible version of the above deposits the error in an arbitary mailbox:" +{ $subsection spawn-linked-to } +"This will create a unidirectional link, such that if an uncaught exception causes the child to terminate, the parent thread can catch it:" +{ $code "[" +" [ 1 0 / \"This will not print\" print ] spawn-linked drop" +" receive" +"] [ \"Exception caught.\" print ] recover" } "Exceptions are only raised in the parent when the parent does a " { $link receive } " or " { $link receive-if } ". This is because the exception is sent from the child to the parent as a message." ; -ARTICLE: { "concurrency" "concurrency" } "Concurrency" -"The concurrency library is based upon the style of concurrency used in systems like Erlang and Termite. It is built on top of the standard Factor lightweight thread system.\nA concurrency oriented program is one in which multiple processes run simultaneously in a single Factor image or across multiple running Factor instances. The processes can communicate with each other by asynchronous message sends. Although processes can share data via Factor's mutable data structures it is not recommended as the use of shared state concurrency is often a cause of problems." -{ $subsection { "concurrency" "processes" } } -{ $subsection { "concurrency" "self" } } +ARTICLE: "concurrency.messaging" "Message-passing concurrency" +"The " { $vocab-link "concurrency.messaging" } " vocabulary is based upon the style of concurrency used in systems like Erlang and Termite. It is built on top of the standard Factor lightweight thread system." +$nl +"A concurrency oriented program is one in which multiple threades run simultaneously in a single Factor image or across multiple running Factor instances. The threades can communicate with each other by asynchronous message sends." +$nl +"Although threades can share data via Factor's mutable data structures it is not recommended to mix shared state with message passing as it can lead to confusing code." +{ $subsection { "concurrency" "mailboxes" } } { $subsection { "concurrency" "synchronous-sends" } } { $subsection { "concurrency" "exceptions" } } ; -ABOUT: { "concurrency" "concurrency" } +ABOUT: "concurrency.messaging" diff --git a/extra/concurrency/messaging/messaging-tests.factor b/extra/concurrency/messaging/messaging-tests.factor index 30b88cf16a..91217320ce 100755 --- a/extra/concurrency/messaging/messaging-tests.factor +++ b/extra/concurrency/messaging/messaging-tests.factor @@ -3,139 +3,88 @@ ! USING: kernel threads vectors arrays sequences namespaces tools.test continuations dlists strings math words -match quotations concurrency.private ; +match quotations concurrency.messaging ; IN: temporary -[ ] [ self process-mailbox mailbox-data dlist-delete-all ] unit-test +[ ] [ mailbox mailbox-data dlist-delete-all ] unit-test [ V{ 1 2 3 } ] [ - 0 - make-mailbox - 2dup [ mailbox-get swap push ] 2curry in-thread - 2dup [ mailbox-get swap push ] 2curry in-thread - 2dup [ mailbox-get swap push ] 2curry in-thread - 1 over mailbox-put - 2 over mailbox-put - 3 swap mailbox-put + 0 + + [ 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 - make-mailbox - 2dup [ [ integer? ] swap mailbox-get? swap push ] 2curry in-thread - 2dup [ [ integer? ] swap mailbox-get? swap push ] 2curry in-thread - 2dup [ [ integer? ] swap mailbox-get? swap push ] 2curry in-thread - 1 over mailbox-put - 2 over mailbox-put - 3 swap mailbox-put + 0 + + [ [ integer? ] swap mailbox-get? swap push ] in-thread + [ [ integer? ] swap mailbox-get? swap push ] in-thread + [ [ integer? ] swap 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 - make-mailbox - 2dup [ [ integer? ] swap mailbox-get? swap push ] 2curry in-thread - 2dup [ [ integer? ] swap mailbox-get? swap push ] 2curry in-thread - 2dup [ [ string? ] swap mailbox-get? swap push ] 2curry in-thread - 2dup [ [ string? ] swap mailbox-get? swap push ] 2curry 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 - -[ "test" ] [ - [ self ] "test" with-process + 0 + + [ [ integer? ] swap mailbox-get? swap push ] in-thread + [ [ integer? ] swap mailbox-get? swap push ] in-thread + [ [ string? ] swap mailbox-get? swap push ] in-thread + [ [ string? ] swap 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 [ "received" ] [ - [ - receive { - { { ?from ?tag _ } [ ?tag "received" 2array ?from send ] } - } match-cond - ] spawn - "sent" swap send-synchronous + [ + receive "received" swap reply-synchronous + ] "Synchronous test" spawn + "sent" swap send-synchronous ] unit-test [ 1 3 2 ] [ - 1 self send - 2 self send - 3 self send - receive - [ 2 mod 0 = not ] receive-if - receive + 1 self send + 2 self send + 3 self send + receive + [ 2 mod 0 = not ] receive-if + receive ] unit-test - [ - [ - "crash" throw - ] spawn-link drop - receive -] [ "crash" = ] must-fail-with + [ + "crash" throw + ] "Linked test" spawn-linked drop + receive +] [ linked-error "crash" = ] must-fail-with -[ 50 ] [ - [ 50 ] future ?future -] unit-test - -[ V{ 50 50 50 } ] [ - 0 - - 2dup [ ?promise swap push ] 2curry spawn drop - 2dup [ ?promise swap push ] 2curry spawn drop - 2dup [ ?promise swap push ] 2curry spawn drop - 50 swap fulfill -] unit-test - -MATCH-VARS: ?value ; +MATCH-VARS: ?from ?to ?value ; SYMBOL: increment SYMBOL: decrement SYMBOL: value -: counter ( value -- ) - receive { - { { increment ?value } [ ?value + counter ] } - { { decrement ?value } [ ?value - counter ] } - { { value ?from } [ dup ?from send counter ] } - } match-cond ; +: counter ( value -- value ) + receive { + { { increment ?value } [ ?value + ] } + { { decrement ?value } [ ?value - ] } + { { value ?from } [ dup ?from send ] } + } match-cond ; [ -5 ] [ - [ 0 counter ] spawn - { increment 10 } over send - { decrement 15 } over send - [ value , self , ] { } make swap send - receive -] unit-test - -! The following unit test blocks forever if the -! exception does not propogate. Uncomment when -! this is fixed (via a timeout). -[ - [ "this should propogate" throw ] future ?future -] must-fail - -[ ] [ - [ "this should not propogate" throw ] future drop -] unit-test - -[ f ] [ - [ 1 drop ] spawn 100 sleep process-pid get-process -] unit-test - -[ f ] [ - [ "testing unregistering on error" throw ] spawn - 100 sleep process-pid get-process -] unit-test - -! Race condition with futures -[ 3 3 ] [ - [ 3 ] future - dup ?future swap ?future -] unit-test - -! Another race -[ 3 ] [ - [ 3 yield ] future ?future + [ 0 [ t ] [ counter ] [ ] while ] "Counter" spawn + { increment 10 } over send + { decrement 15 } over send + [ value , self , ] { } make swap send + receive ] unit-test \ No newline at end of file diff --git a/extra/concurrency/messaging/messaging.factor b/extra/concurrency/messaging/messaging.factor index e7a860495f..cc1f966ce2 100755 --- a/extra/concurrency/messaging/messaging.factor +++ b/extra/concurrency/messaging/messaging.factor @@ -26,12 +26,12 @@ TUPLE: mailbox threads data ; 2over mailbox-data dlist-contains? [ 3drop ] [ - 2dup mailbox-threads wait block-unless-pred + 2dup >r mailbox-threads r> wait block-unless-pred ] if ; inline : block-if-empty ( mailbox timeout -- mailbox ) over mailbox-empty? [ - 2dup mailbox-threads wait block-if-empty + 2dup >r mailbox-threads r> wait block-if-empty ] [ drop ] if ; @@ -39,10 +39,10 @@ TUPLE: mailbox threads data ; PRIVATE> : mailbox-peek ( mailbox -- obj ) - mailbox-data peek-front ; + mailbox-data peek-back ; : mailbox-get-timeout ( mailbox timeout -- obj ) - block-if-empty mailbox-data pop-front ; + block-if-empty mailbox-data pop-back ; : mailbox-get ( mailbox -- obj ) f mailbox-get-timeout ; @@ -68,13 +68,13 @@ PRIVATE> mailbox-data delete-node-if ; inline : mailbox-get? ( pred mailbox -- obj ) - f mailbox-timeout-get? ; + f mailbox-timeout-get? ; inline TUPLE: linked error thread ; -: self linked construct-boa ; +C: linked -GENERIC: send ( message thread -- ) +GENERIC: send ( message process -- ) : mailbox-of ( thread -- mailbox ) dup thread-mailbox [ ] [ @@ -94,7 +94,7 @@ M: thread send ( message thread -- ) : receive-if ( pred -- message ) mailbox mailbox-get? ?linked ; inline -: rethrow-linked ( error supervisor -- ) +: rethrow-linked ( error process supervisor -- ) >r r> send ; : spawn-linked-to ( quot name mailbox -- thread ) @@ -115,9 +115,13 @@ TUPLE: reply data tag ; synchronous-tag \ reply construct-boa ; : send-synchronous ( message thread -- reply ) - >r dup r> send - [ over reply? [ reply-tag = ] [ 2drop f ] if ] curry - receive-if reply-data ; + >r dup r> send [ + over reply? [ + >r reply-tag r> synchronous-tag = + ] [ + 2drop f + ] if + ] curry receive-if reply-data ; : reply-synchronous ( message synchronous -- ) [ ] keep synchronous-sender send ; diff --git a/extra/concurrency/promises/promises-docs.factor b/extra/concurrency/promises/promises-docs.factor new file mode 100755 index 0000000000..a4d79d8a47 --- /dev/null +++ b/extra/concurrency/promises/promises-docs.factor @@ -0,0 +1,36 @@ +! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: concurrency.messaging kernel arrays +continuations help.markup help.syntax quotations ; +IN: concurrency.promises + +HELP: promise +{ $class-description "The class of write-once promises." } ; + +HELP: promise-fulfilled? +{ $values { "promise" promise } { "?" "a boolean" } } +{ $description "Tests if " { $link fulfill } " has previously been called on the promise, in which case " { $link ?promise } " will return immediately without blocking." } ; + +HELP: ?promise-timeout +{ $values { "promise" promise } { "timeout" "a timeout in milliseconds or " { $link f } } { "value" object } } +{ $description "Waits for another thread to fulfill a promise, returning immediately if the promise has already been fulfilled. A timeout of " { $link f } " indicates that the thread may block indefinitely, otherwise it will wait up to " { $snippet "timeout" } " milliseconds." } +{ $errors "Throws an error if the timeout expires before the promise has been fulfilled." } ; + +HELP: ?promise +{ $values { "promise" promise } { "value" object } } +{ $description "Waits for another thread to fulfill a promise, returning immediately if the promise has already been fulfilled." } ; + +HELP: fulfill +{ $values { "value" object } { "promise" promise } } +{ $description "Fulfills a promise by writing a value to it. Any threads waiting for the value are notified." } +{ $errors "Throws an error if the promise has already been fulfilled." } ; + +ARTICLE: "concurrency.promises" "Promises" +"The " { $vocab-link "concurrency.promises" } " vocabulary implements " { $emphasis "promises" } ", which are thread-safe write-once variables. Once a promise is created, threads may block waiting for it to be " { $emphasis "fulfilled" } "; at some point in the future, another thread may provide a value at which point all waiting threads are notified." +{ $subsection promise } +{ $subsection } +{ $subsection fulfill } +{ $subsection ?promise } +{ $subsection ?promise-timeout } ; + +ABOUT: "concurrency.promises" diff --git a/extra/concurrency/promises/promises-tests.factor b/extra/concurrency/promises/promises-tests.factor new file mode 100755 index 0000000000..fa749438d2 --- /dev/null +++ b/extra/concurrency/promises/promises-tests.factor @@ -0,0 +1,12 @@ +IN: temporary +USING: vectors concurrency.promises kernel threads sequences +tools.test ; + +[ V{ 50 50 50 } ] [ + 0 + + [ ?promise swap push ] in-thread + [ ?promise swap push ] in-thread + [ ?promise swap push ] in-thread + 50 swap fulfill +] unit-test diff --git a/extra/concurrency/semaphores/semaphores-docs.factor b/extra/concurrency/semaphores/semaphores-docs.factor new file mode 100755 index 0000000000..05ef6cc39e --- /dev/null +++ b/extra/concurrency/semaphores/semaphores-docs.factor @@ -0,0 +1,45 @@ +IN: concurrency.semaphores +USING: help.markup help.syntax kernel quotations ; + +HELP: semaphore +{ $class-description "The class of counting semaphores." } ; + +HELP: +{ $values { "n" "a non-negative integer" } { "semaphore" semaphore } } +{ $description "Creates a counting semaphore with the specified initial count." } ; + +HELP: acquire +{ $values { "semaphore" semaphore } { "timeout" "a timeout in milliseconds or " { $link f } } { "value" object } } +{ $description "If the semaphore has a non-zero count, decrements it and returns immediately. Otherwise, if the timeout is " { $link f } ", waits indefinitely for the semaphore to be released. If the timeout is not " { $link f } ", waits up to that number of milliseconds for the semaphore to be released." } ; + +HELP: release +{ $values { "semaphore" semaphore } } +{ $description "Increments a semaphore's count. If the count was previously zero, any threads waiting on the semaphore are woken up." } ; + +HELP: with-semaphore +{ $values { "semaphore" semaphore } { "quot" quotation } } +{ $description "Calls the quotation with the semaphore held." } ; + +ARTICLE: "concurrency.semaphores" "Counting semaphores" +"Counting semaphores are used to ensure that no more than a fixed number of threads are executing in a critical section at a time; as such, they generalize " { $link "concurrency.locks.mutex" } ", since locks can be thought of as semaphores with an initial count of 1." +$nl +"A use-case would be a batch processing server which runs a large number of jobs which perform calculations but then need to fire off expensive external processes or perform heavy network I/O. While for most of the time, the threads can all run in parallel, it might be desired that the expensive operation is not run by more than 10 threads at once, to avoid thrashing swap space or saturating the network. This can be accomplished with a counting semaphore:" +{ $code + "SYMBOL: expensive-section" + "10 expensive-section set-global" + "requests [" + " ..." + " expensive-section [ do-expensive-stuff ] with-semaphore" + " ..." + "] parallel-map" +} +"Creating semaphores:" +{ $subsection semaphore } +{ $subsection } +"Unlike locks, where acquisition and release are always paired by a combinator, semaphores expose these operations directly and there is no requirement that they be performed in the same thread:" +{ $subsection acquire } +{ $subsection release } +"A combinator which pairs acquisition and release:" +{ $subsection with-semaphore } ; + +ABOUT: "concurrency.semaphores" diff --git a/extra/concurrency/semaphores/semaphores.factor b/extra/concurrency/semaphores/semaphores.factor index 4afa02307a..b2c99ba6e7 100755 --- a/extra/concurrency/semaphores/semaphores.factor +++ b/extra/concurrency/semaphores/semaphores.factor @@ -1,23 +1,29 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: dlists kernel threads math ; +USING: dlists kernel threads math concurrency.conditions +continuations ; IN: concurrency.semaphores TUPLE: semaphore count threads ; -: ( -- semaphore ) +: ( n -- semaphore ) + dup 0 < [ "Cannot have semaphore with negative count" throw ] when 0 semaphore construct-boa ; -: wait-to-acquire ( semaphore -- ) - [ semaphore-threads push-front ] suspend drop ; +: wait-to-acquire ( semaphore timeout -- ) + >r semaphore-threads r> wait ; -: acquire ( semaphore -- ) +: acquire ( semaphore timeout -- ) dup semaphore-count zero? [ wait-to-acquire ] [ + drop dup semaphore-count 1- swap set-semaphore-count ] if ; : release ( semaphore -- ) dup semaphore-count 1+ over set-semaphore-count semaphore-threads notify-1 ; + +: with-semaphore ( semaphore quot -- ) + over acquire [ release ] curry [ ] cleanup ; inline diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 90e780c1ad..4bf78ffa80 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -78,8 +78,36 @@ ARTICLE: "dataflow" "Data and control flow" { $subsection "conditionals" } { $subsection "basic-combinators" } { $subsection "combinators" } -{ $subsection "continuations" } -{ $subsection "threads" } ; +{ $subsection "continuations" } ; + +USING: concurrency.combinators +concurrency.messaging +concurrency.promises +concurrency.futures +concurrency.distributed +concurrency.locks +concurrency.semaphores +concurrency.count-downs +concurrency.exchangers ; + +ARTICLE: "concurrency" "Concurrency" +"Factor supports a variety of concurrency abstractions, however they are mostly used to multiplex input/output operations since the thread scheduling is co-operative and only one CPU is used at a time." +$nl +"Factor's concurrency support was insipired by Erlang, Termite, Scheme48 and Java's " { $snippet "java.util.concurrent" } " library." +$nl +"The basic building blocks:" +{ $subsection "threads" } +"High-level abstractions:" +{ $subsection "concurrency.combinators" } +{ $subsection "concurrency.promises" } +{ $subsection "concurrency.futures" } +{ $subsection "concurrency.messaging" } +{ $subsection "concurrency.distributed" } +"Shared-state abstractions:" +{ $subsection "concurrency.locks" } +{ $subsection "concurrency.semaphores" } +{ $subsection "concurrency.count-downs" } +{ $subsection "concurrency.exchangers" } ; ARTICLE: "objects" "Objects" "An " { $emphasis "object" } " is any datum which may be identified. All values are objects in Factor. Each object carries type information, and types are checked at runtime; Factor is dynamically typed." @@ -216,6 +244,7 @@ ARTICLE: "handbook" "Factor documentation" { $subsection "numbers" } { $subsection "collections" } { $subsection "io" } +{ $subsection "concurrency" } { $subsection "os" } { $subsection "alien" } { $heading "Environment reference" } diff --git a/extra/smtp/server/server.factor b/extra/smtp/server/server.factor index 3ca1c72296..b89b351f9e 100755 --- a/extra/smtp/server/server.factor +++ b/extra/smtp/server/server.factor @@ -56,7 +56,7 @@ SYMBOL: data-mode data-mode off "220 OK\r\n" write flush t ] } - { [ data-mode get ] [ global [ print ] bind t ] } + { [ data-mode get ] [ dup global [ print ] bind t ] } { [ t ] [ "500 ERROR\r\n" write flush t ] } diff --git a/extra/tools/browser/browser.factor b/extra/tools/browser/browser.factor index 7c28983519..e9aaa190dc 100755 --- a/extra/tools/browser/browser.factor +++ b/extra/tools/browser/browser.factor @@ -107,6 +107,7 @@ MEMO: all-vocabs-seq ( -- seq ) { [ "ui.windows" ?head ] [ t ] } { [ "ui.cocoa" ?head ] [ t ] } { [ "cocoa" ?head ] [ t ] } + { [ "core-foundation" ?head ] [ t ] } { [ "vocabs.loader.test" ?head ] [ t ] } { [ "editors." ?head ] [ t ] } { [ ".windows" ?tail ] [ t ] } diff --git a/extra/tools/threads/threads.factor b/extra/tools/threads/threads.factor index aca9e8e649..3da8e315a1 100755 --- a/extra/tools/threads/threads.factor +++ b/extra/tools/threads/threads.factor @@ -16,7 +16,7 @@ io io.styles sequences assocs namespaces sorting ; [ [ write ] with-cell ] each ] with-row - threads get-global >alist sort-keys values [ + threads >alist sort-keys values [ [ thread. ] with-row ] each ] tabular-output ; diff --git a/vm/run.h b/vm/run.h index 1fcb4bedb4..3835c374ed 100755 --- a/vm/run.h +++ b/vm/run.h @@ -56,7 +56,11 @@ typedef enum { STAGE2_ENV = 39, /* have we bootstrapped? */ - CURRENT_THREAD_ENV = 40 + CURRENT_THREAD_ENV = 40, + + THREADS_ENV = 41, + RUN_QUEUE_ENV = 42, + SLEEP_QUEUE_ENV = 43, } F_ENVTYPE; #define FIRST_SAVE_ENV BOOT_ENV From cb1b19fa9bc95177d41edb498ef1e2a20c105292 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 19 Feb 2008 11:37:02 -0600 Subject: [PATCH 6/7] Fix semaphores, fix docs --- extra/concurrency/semaphores/semaphores.factor | 2 +- extra/help/handbook/handbook.factor | 5 ++--- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/extra/concurrency/semaphores/semaphores.factor b/extra/concurrency/semaphores/semaphores.factor index b2c99ba6e7..e4b07de8a6 100755 --- a/extra/concurrency/semaphores/semaphores.factor +++ b/extra/concurrency/semaphores/semaphores.factor @@ -8,7 +8,7 @@ TUPLE: semaphore count threads ; : ( n -- semaphore ) dup 0 < [ "Cannot have semaphore with negative count" throw ] when - 0 semaphore construct-boa ; + semaphore construct-boa ; : wait-to-acquire ( semaphore timeout -- ) >r semaphore-threads r> wait ; diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 4bf78ffa80..837d69d59d 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -84,7 +84,6 @@ USING: concurrency.combinators concurrency.messaging concurrency.promises concurrency.futures -concurrency.distributed concurrency.locks concurrency.semaphores concurrency.count-downs @@ -102,12 +101,12 @@ $nl { $subsection "concurrency.promises" } { $subsection "concurrency.futures" } { $subsection "concurrency.messaging" } -{ $subsection "concurrency.distributed" } "Shared-state abstractions:" { $subsection "concurrency.locks" } { $subsection "concurrency.semaphores" } { $subsection "concurrency.count-downs" } -{ $subsection "concurrency.exchangers" } ; +{ $subsection "concurrency.exchangers" } +"Other concurrency abstractions include " { $vocab-link "concurrency.distributed" } " and " { $vocab-link "channels" } "." ; ARTICLE: "objects" "Objects" "An " { $emphasis "object" } " is any datum which may be identified. All values are objects in Factor. Each object carries type information, and types are checked at runtime; Factor is dynamically typed." From 37e0e28f35e1b875d2bb14d2919ef077354e3c93 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 19 Feb 2008 14:38:02 -0600 Subject: [PATCH 7/7] Implement new box data type, fix various bugs, add status parameter for suspend, threads. now prints thread state --- core/boxes/boxes-docs.factor | 38 ++++++++++++++++++ core/boxes/boxes-tests.factor | 24 +++++++++++ core/boxes/boxes.factor | 21 ++++++++++ core/listener/listener.factor | 2 +- core/parser/parser.factor | 1 + core/threads/threads-docs.factor | 4 +- core/threads/threads-tests.factor | 2 +- core/threads/threads.factor | 30 ++++++++------ .../concurrency/conditions/conditions.factor | 4 +- .../concurrency/exchangers/exchangers.factor | 19 ++++----- extra/concurrency/locks/locks.factor | 6 +-- .../messaging/messaging-tests.factor | 19 +++++---- extra/concurrency/messaging/messaging.factor | 6 ++- .../concurrency/semaphores/semaphores.factor | 2 +- extra/help/handbook/handbook.factor | 1 + extra/io/launcher/launcher.factor | 5 ++- extra/io/monitors/monitors.factor | 15 +++---- extra/io/server/server.factor | 40 +++++++++++-------- extra/io/unix/backend/backend.factor | 2 +- extra/io/windows/nt/backend/backend.factor | 2 +- extra/tools/threads/threads.factor | 5 ++- extra/ui/tools/interactor/interactor.factor | 39 +++++++++--------- extra/ui/tools/listener/listener.factor | 32 +++++++++------ extra/ui/ui.factor | 10 ++--- 24 files changed, 218 insertions(+), 111 deletions(-) create mode 100755 core/boxes/boxes-docs.factor create mode 100755 core/boxes/boxes-tests.factor create mode 100755 core/boxes/boxes.factor diff --git a/core/boxes/boxes-docs.factor b/core/boxes/boxes-docs.factor new file mode 100755 index 0000000000..b3b91d06d9 --- /dev/null +++ b/core/boxes/boxes-docs.factor @@ -0,0 +1,38 @@ +USING: help.markup help.syntax kernel ; +IN: boxes + +HELP: box +{ $class-description "A data type holding a single value in the " { $link box-value } " slot. The " { $link box-full? } " slot indicates if the value is set." } ; + +HELP: +{ $values { "box" box } } +{ $description "Creates a new empty box." } ; + +HELP: >box +{ $values { "value" object } { "box" box } } +{ $description "Stores a value into a box." } +{ $errors "Throws an error if the box is full." } ; + +HELP: box> +{ $values { "box" box } { "value" "the value of the box" } } +{ $description "Removes a value from a box." } +{ $errors "Throws an error if the box is empty." } ; + +HELP: ?box +{ $values { "box" box } { "value" "the value of the box or " { $link f } } { "?" "a boolean" } } +{ $description "If the box is full, removes the value from the box and pushes " { $link t } ". If the box is empty pushes " { $snippet "f f" } "." } ; + +ARTICLE: "boxes" "Boxes" +"A " { $emphasis "box" } " is a container which can either be empty or hold a single value." +{ $subsection box } +"Creating an empty box:" +{ $subsection } +"Testing if a box is full:" +{ $subsection box-full? } +"Storing a value and removing a value from a box:" +{ $subsection >box } +{ $subsection box> } +"Safely removing a value:" +{ $subsection ?box } ; + +ABOUT: "boxes" diff --git a/core/boxes/boxes-tests.factor b/core/boxes/boxes-tests.factor new file mode 100755 index 0000000000..66ee5247ec --- /dev/null +++ b/core/boxes/boxes-tests.factor @@ -0,0 +1,24 @@ +IN: temporary +USING: boxes namespaces tools.test ; + +[ ] [ "b" set ] unit-test + +[ ] [ 3 "b" get >box ] unit-test + +[ t ] [ "b" get box-full? ] unit-test + +[ 4 "b" >box ] must-fail + +[ 3 ] [ "b" get box> ] unit-test + +[ f ] [ "b" get box-full? ] unit-test + +[ "b" get box> ] must-fail + +[ f f ] [ "b" get ?box ] unit-test + +[ ] [ 12 "b" get >box ] unit-test + +[ 12 t ] [ "b" get ?box ] unit-test + +[ f ] [ "b" get box-full? ] unit-test diff --git a/core/boxes/boxes.factor b/core/boxes/boxes.factor new file mode 100755 index 0000000000..8197e57969 --- /dev/null +++ b/core/boxes/boxes.factor @@ -0,0 +1,21 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel ; +IN: boxes + +TUPLE: box value full? ; + +: ( -- box ) box construct-empty ; + +: >box ( value box -- ) + dup box-full? [ "Box already has a value" throw ] when + t over set-box-full? + set-box-value ; + +: box> ( box -- value ) + dup box-full? [ "Box empty" throw ] unless + dup box-value f pick set-box-value + f rot set-box-full? ; + +: ?box ( box -- value/f ? ) + dup box-full? [ box> t ] [ drop f f ] if ; diff --git a/core/listener/listener.factor b/core/listener/listener.factor index 2d777d8087..288cb53322 100755 --- a/core/listener/listener.factor +++ b/core/listener/listener.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2003, 2007 Slava Pestov. +! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays hashtables io kernel math memory namespaces parser sequences strings io.styles io.streams.lines diff --git a/core/parser/parser.factor b/core/parser/parser.factor index fc29445f88..9bc02c763d 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -409,6 +409,7 @@ SYMBOL: interactive-vocabs "tools.memory" "tools.profiler" "tools.test" + "tools.threads" "tools.time" "vocabs" "vocabs.loader" diff --git a/core/threads/threads-docs.factor b/core/threads/threads-docs.factor index 6a5bd57751..da6844ed85 100755 --- a/core/threads/threads-docs.factor +++ b/core/threads/threads-docs.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax kernel kernel.private io threads.private continuations dlists init quotations strings -assocs heaps ; +assocs heaps boxes ; IN: threads ARTICLE: "threads-start/stop" "Starting and stopping threads" @@ -61,7 +61,7 @@ HELP: thread { { $link thread-id } " - a unique identifier assigned to each thread." } { { $link thread-name } " - the name passed to " { $link spawn } "." } { { $link thread-quot } " - the initial quotation passed to " { $link spawn } "." } - { { $link thread-continuation } " - if the thread is waiting to run, the saved thread context. If the thread is currently running, will be " { $link f } "." } + { { $link thread-continuation } " - a " { $link box } "; if the thread is ready to run, the box holds the continuation, otherwise it is empty." } { { $link thread-registered? } " - a boolean indicating whether the thread is eligible to run or not. Spawning a thread with " { $link (spawn) } " sets this flag and " { $link stop } " clears it." } } } ; diff --git a/core/threads/threads-tests.factor b/core/threads/threads-tests.factor index 49139a7807..00306da062 100755 --- a/core/threads/threads-tests.factor +++ b/core/threads/threads-tests.factor @@ -12,5 +12,5 @@ yield [ "hey" sleep ] must-fail [ 3 ] [ - [ 3 swap resume-with ] suspend + [ 3 swap resume-with ] "Test suspend" suspend ] unit-test diff --git a/core/threads/threads.factor b/core/threads/threads.factor index 553cd6fc03..05128982bb 100755 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -4,14 +4,15 @@ IN: threads USING: arrays hashtables heaps kernel kernel.private math namespaces sequences vectors continuations continuations.private -dlists assocs system combinators debugger prettyprint io init ; +dlists assocs system combinators debugger prettyprint io init +boxes ; SYMBOL: initial-thread TUPLE: thread name quot error-handler id registered? -continuation +continuation state mailbox variables ; : self ( -- thread ) 40 getenv ; inline @@ -61,11 +62,12 @@ threads global [ H{ } assoc-like ] change-at PRIVATE> : ( quot name error-handler -- thread ) - \ thread counter { + \ thread counter { set-thread-quot set-thread-name set-thread-error-handler set-thread-id + set-thread-continuation } \ thread construct ; : run-queue 42 getenv ; @@ -99,8 +101,8 @@ PRIVATE> wake-up run-queue pop-back dup array? [ first2 ] [ f swap ] if dup set-self - dup thread-continuation - f rot set-thread-continuation + f over set-thread-state + thread-continuation box> continue-with ] if* ; @@ -116,15 +118,19 @@ PRIVATE> : stop ( -- ) self unregister-thread next ; -: suspend ( quot -- obj ) +: suspend ( quot state -- obj ) [ - >r self [ set-thread-continuation ] keep r> call next - ] curry callcc1 ; inline + self thread-continuation >box + self set-thread-state + self swap call next + ] callcc1 2nip ; inline -: yield ( -- ) [ resume ] suspend drop ; +: yield ( -- ) [ resume ] "yield" suspend drop ; : sleep ( ms -- ) - >fixnum millis + [ schedule-sleep ] curry suspend drop ; + >fixnum millis + + [ schedule-sleep ] curry + "sleep" suspend drop ; : (spawn) ( thread -- ) [ @@ -137,7 +143,7 @@ PRIVATE> >r { } set-datastack r> thread-quot [ call stop ] call-clear ] 1 (throw) - ] suspend 2drop ; + ] "spawn" suspend 2drop ; : spawn ( quot name -- thread ) [ @@ -170,7 +176,7 @@ PRIVATE> 43 setenv initial-thread global [ drop f "Initial" [ die ] ] cache - f over set-thread-continuation + over set-thread-continuation f over set-thread-registered? dup register-thread set-self ; diff --git a/extra/concurrency/conditions/conditions.factor b/extra/concurrency/conditions/conditions.factor index b93658b9f1..4662f1b369 100755 --- a/extra/concurrency/conditions/conditions.factor +++ b/extra/concurrency/conditions/conditions.factor @@ -9,5 +9,5 @@ IN: concurrency.conditions : notify-all ( dlist -- ) [ second resume ] dlist-slurp yield ; -: wait ( queue timeout -- ) - [ 2array swap push-front ] suspend 3drop ; inline +: wait ( queue timeout status -- ) + >r [ 2array swap push-front ] r> suspend 3drop ; inline diff --git a/extra/concurrency/exchangers/exchangers.factor b/extra/concurrency/exchangers/exchangers.factor index f857cb62f2..e7c9be76d2 100755 --- a/extra/concurrency/exchangers/exchangers.factor +++ b/extra/concurrency/exchangers/exchangers.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel threads ; +USING: kernel threads boxes ; IN: concurrency.exchangers ! Motivated by @@ -9,18 +9,13 @@ IN: concurrency.exchangers TUPLE: exchanger thread object ; : ( -- exchanger ) - f f exchanger construct-boa ; - -: pop-object ( exchanger -- obj ) - dup exchanger-object f rot set-exchanger-object ; - -: pop-thread ( exchanger -- thread ) - dup exchanger-thread f rot set-exchanger-thread ; + exchanger construct-boa ; : exchange ( obj exchanger -- newobj ) - dup exchanger-thread [ - dup pop-object >r pop-thread resume-with r> + dup exchanger-thread box-full? [ + dup exchanger-object box> + >r exchanger-thread box> resume-with r> ] [ - [ set-exchanger-object ] keep - [ set-exchanger-thread ] curry suspend + [ exchanger-object >box ] keep + [ exchanger-thread >box ] curry "Exchange wait" suspend ] if ; diff --git a/extra/concurrency/locks/locks.factor b/extra/concurrency/locks/locks.factor index 663b22d626..f4138a0a76 100755 --- a/extra/concurrency/locks/locks.factor +++ b/extra/concurrency/locks/locks.factor @@ -17,7 +17,7 @@ TUPLE: lock threads owner reentrant? ; : acquire-lock ( lock timeout -- ) over lock-owner - [ 2dup >r lock-threads r> wait ] when drop + [ 2dup >r lock-threads r> "lock" wait ] when drop self swap set-lock-owner ; : release-lock ( lock -- ) @@ -54,7 +54,7 @@ TUPLE: rw-lock readers writers reader# writer ; : acquire-read-lock ( lock timeout -- ) over rw-lock-writer - [ 2dup >r rw-lock-readers r> wait ] when drop + [ 2dup >r rw-lock-readers r> "read lock" wait ] when drop dup rw-lock-reader# 1+ swap set-rw-lock-reader# ; : notify-writer ( lock -- ) @@ -66,7 +66,7 @@ TUPLE: rw-lock readers writers reader# writer ; : acquire-write-lock ( lock timeout -- ) over rw-lock-writer pick rw-lock-reader# 0 > or - [ 2dup >r rw-lock-writers r> wait ] when drop + [ 2dup >r rw-lock-writers r> "write lock" wait ] when drop self swap set-rw-lock-writer ; : release-write-lock ( lock -- ) diff --git a/extra/concurrency/messaging/messaging-tests.factor b/extra/concurrency/messaging/messaging-tests.factor index 91217320ce..267fc7a8cd 100755 --- a/extra/concurrency/messaging/messaging-tests.factor +++ b/extra/concurrency/messaging/messaging-tests.factor @@ -73,18 +73,21 @@ MATCH-VARS: ?from ?to ?value ; SYMBOL: increment SYMBOL: decrement SYMBOL: value +SYMBOL: exit -: counter ( value -- value ) +: counter ( value -- value ? ) receive { - { { increment ?value } [ ?value + ] } - { { decrement ?value } [ ?value - ] } - { { value ?from } [ dup ?from send ] } + { { increment ?value } [ ?value + t ] } + { { decrement ?value } [ ?value - t ] } + { { value ?from } [ dup ?from send t ] } + { exit [ f ] } } match-cond ; [ -5 ] [ - [ 0 [ t ] [ counter ] [ ] while ] "Counter" spawn - { increment 10 } over send - { decrement 15 } over send - [ value , self , ] { } make swap send + [ 0 [ counter ] [ ] [ ] while ] "Counter" spawn "counter" set + { increment 10 } "counter" get send + { decrement 15 } "counter" get send + [ value , self , ] { } make "counter" get send receive + exit "counter" get send ] unit-test \ No newline at end of file diff --git a/extra/concurrency/messaging/messaging.factor b/extra/concurrency/messaging/messaging.factor index cc1f966ce2..22a7282364 100755 --- a/extra/concurrency/messaging/messaging.factor +++ b/extra/concurrency/messaging/messaging.factor @@ -26,12 +26,14 @@ TUPLE: mailbox threads data ; 2over mailbox-data dlist-contains? [ 3drop ] [ - 2dup >r mailbox-threads r> wait block-unless-pred + 2dup >r mailbox-threads r> "mailbox" wait + block-unless-pred ] if ; inline : block-if-empty ( mailbox timeout -- mailbox ) over mailbox-empty? [ - 2dup >r mailbox-threads r> wait block-if-empty + 2dup >r mailbox-threads r> "mailbox" wait + block-if-empty ] [ drop ] if ; diff --git a/extra/concurrency/semaphores/semaphores.factor b/extra/concurrency/semaphores/semaphores.factor index e4b07de8a6..413e491fdb 100755 --- a/extra/concurrency/semaphores/semaphores.factor +++ b/extra/concurrency/semaphores/semaphores.factor @@ -11,7 +11,7 @@ TUPLE: semaphore count threads ; semaphore construct-boa ; : wait-to-acquire ( semaphore timeout -- ) - >r semaphore-threads r> wait ; + >r semaphore-threads r> "semaphore" wait ; : acquire ( semaphore timeout -- ) dup semaphore-count zero? [ diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 837d69d59d..1e3d2cf312 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -161,6 +161,7 @@ ARTICLE: "collections" "Collections" { $subsection "hashtables" } { $subsection "alists" } { $heading "Other collections" } +{ $subsection "boxes" } { $subsection "dlists" } { $subsection "heaps" } { $subsection "graphs" } diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 9b31c78833..eda4332473 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -83,7 +83,10 @@ HOOK: run-process* io-backend ( desc -- handle ) : wait-for-process ( process -- status ) [ dup process-handle - [ dup [ processes get at push ] curry suspend drop ] when + [ + dup [ processes get at push ] curry + "process" suspend drop + ] when dup process-killed? [ "Process was killed" throw ] [ process-status ] if ] with-timeout ; diff --git a/extra/io/monitors/monitors.factor b/extra/io/monitors/monitors.factor index 274d81a271..8c2c9cb9d8 100755 --- a/extra/io/monitors/monitors.factor +++ b/extra/io/monitors/monitors.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.backend kernel continuations namespaces sequences -assocs hashtables sorting arrays threads ; +assocs hashtables sorting arrays threads boxes ; IN: io.monitors ( handle -- simple-monitor ) - f (monitor) { + f (monitor) { set-simple-monitor-handle set-delegate + set-simple-monitor-callback } simple-monitor construct ; : construct-simple-monitor ( handle class -- simple-monitor ) >r r> construct-delegate ; inline : notify-callback ( simple-monitor -- ) - dup simple-monitor-callback - f rot set-simple-monitor-callback - [ resume ] when* ; + simple-monitor-callback ?box [ resume ] [ drop ] if ; M: simple-monitor fill-queue ( monitor -- ) - dup simple-monitor-callback [ - "Cannot wait for changes on the same file from multiple threads" throw - ] when - [ swap set-simple-monitor-callback ] suspend drop + [ swap simple-monitor-callback >box ] + "monitor" suspend drop check-monitor ; M: simple-monitor dispose ( monitor -- ) diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index 160af21661..6cc11ea6b6 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -3,10 +3,17 @@ USING: io io.sockets io.files logging continuations kernel math math.parser namespaces parser sequences strings prettyprint debugger quotations calendar -threads concurrency.combinators ; - +threads concurrency.combinators assocs ; IN: io.server +SYMBOL: servers + +r [ dup get ] H{ } map>assoc [ swap bind ] 2curry r> + spawn drop ; + LOG: accepted-connection NOTICE : with-client ( client quot -- ) @@ -15,23 +22,21 @@ LOG: accepted-connection NOTICE with-stream* ] curry with-disposal ; inline -\ with-client NOTICE add-error-logging +\ with-client DEBUG add-error-logging : accept-loop ( server quot -- ) [ >r accept r> [ with-client ] 2curry - "Client" spawn drop + { log-service servers } "Client" spawn-vars ] 2keep accept-loop ; inline -: server-loop ( server quot -- ) +: server-loop ( addrspec quot -- ) + >r dup servers get push r> [ accept-loop ] curry with-disposal ; inline -SYMBOL: servers +\ server-loop NOTICE add-error-logging -: spawn-server ( addrspec quot -- ) - >r dup servers get push r> server-loop ; inline - -\ spawn-server NOTICE add-error-logging +PRIVATE> : local-server ( port -- seq ) "localhost" swap t resolve-host ; @@ -40,17 +45,18 @@ SYMBOL: servers f swap t resolve-host ; : with-server ( seq service quot -- ) - [ - V{ } clone servers set - [ spawn-server ] curry parallel-each - ] curry with-logging ; inline + V{ } clone [ + servers [ + [ server-loop ] curry with-logging + ] with-variable + ] 3curry parallel-each ; inline : stop-server ( -- ) servers get [ dispose ] each ; -: received-datagram ( addrspec -- ) drop ; + + : with-datagrams ( seq service quot -- ) [ [ swap spawn-datagrams ] curry parallel-each diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 33f694a018..f22483d6e3 100755 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -62,7 +62,7 @@ M: mx register-io-task ( task mx -- ) mx get-global register-io-task ; : with-port-continuation ( port quot -- port ) - [ suspend drop ] curry with-timeout ; inline + [ "I/O" suspend drop ] curry with-timeout ; inline M: mx unregister-io-task ( task mx -- ) fd/container delete-at drop ; diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index caf6a31ea0..50b199b3bd 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -54,7 +54,7 @@ M: windows-nt-io add-completion ( handle -- ) swap dup alien? [ "bad overlapped in save-callback" throw ] unless io-hash get-global set-at - ] suspend 3drop ; + ] "I/O" suspend 3drop ; : wait-for-overlapped ( ms -- overlapped ? ) >r master-completion-port get-global r> ! port ms diff --git a/extra/tools/threads/threads.factor b/extra/tools/threads/threads.factor index 3da8e315a1..70a94cb910 100755 --- a/extra/tools/threads/threads.factor +++ b/extra/tools/threads/threads.factor @@ -2,12 +2,13 @@ ! See http://factorcode.org/license.txt for BSD license. IN: tools.threads USING: threads kernel prettyprint prettyprint.config -io io.styles sequences assocs namespaces sorting ; +io io.styles sequences assocs namespaces sorting boxes ; : thread. ( thread -- ) dup thread-id pprint-cell dup thread-name pprint-cell - thread-continuation "Waiting" "Running" ? [ write ] with-cell ; + thread-state [ "Waiting for " swap append ] [ "Running" ] if* + [ write ] with-cell ; : threads. ( -- ) standard-table-style [ diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor index e16560b708..a7b1568cf9 100755 --- a/extra/ui/tools/interactor/interactor.factor +++ b/extra/ui/tools/interactor/interactor.factor @@ -6,18 +6,27 @@ math.vectors models namespaces parser prettyprint quotations sequences sequences.lib strings threads listener tuples ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.presentations ui.gadgets.worlds ui.gestures -definitions ; +definitions boxes ; IN: ui.tools.interactor TUPLE: interactor history output -thread quot busy? +thread quot help ; +: interactor-continuation ( interactor -- continuation ) + interactor-thread box-value + thread-continuation box-value ; + +: interactor-busy? ( interactor -- ? ) + interactor-thread box-full? not ; + : interactor-use ( interactor -- seq ) - use swap - interactor-thread thread-continuation continuation-name - assoc-stack ; + dup interactor-busy? [ drop f ] [ + use swap + interactor-continuation continuation-name + assoc-stack + ] if ; : init-caret-help ( interactor -- ) dup editor-caret 100 swap set-interactor-help ; @@ -29,13 +38,13 @@ help ; interactor construct-editor tuck set-interactor-output + over set-interactor-thread dup init-interactor-history dup init-caret-help ; M: interactor graft* dup delegate graft* - dup dup interactor-help add-connection - f swap set-interactor-busy? ; + dup interactor-help add-connection ; : word-at-loc ( loc interactor -- word ) over [ @@ -65,17 +74,16 @@ M: interactor model-changed over empty? [ 2drop ] [ interactor-history push-new ] if ; : interactor-continue ( obj interactor -- ) - t over set-interactor-busy? - interactor-thread resume-with ; + interactor-thread box> resume-with ; : clear-input ( interactor -- ) gadget-model clear-doc ; : interactor-finish ( interactor -- ) - #! The in-thread is a kludge to make it infer. Stupid. + #! The spawn is a kludge to make it infer. Stupid. [ editor-string ] keep [ interactor-input. ] 2keep [ add-interactor-history ] keep - [ clear-input ] curry in-thread ; + [ clear-input ] curry "Clearing input" spawn drop ; : interactor-eof ( interactor -- ) dup interactor-busy? [ @@ -88,12 +96,7 @@ M: interactor model-changed ] unless drop ; : interactor-yield ( interactor -- obj ) - ! dup gadget-graft-state first [ - f over set-interactor-busy? - [ set-interactor-thread ] curry suspend ; - ! ] [ - ! drop f - ! ] if ; + [ interactor-thread >box ] curry "input" suspend ; M: interactor stream-readln [ interactor-yield ] keep interactor-finish ?first ; @@ -127,7 +130,7 @@ M: interactor stream-read-partial [ drop parse-lines-interactive ] [ - >r f swap set-interactor-busy? drop r> + 2nip dup delegate unexpected-eof? [ drop f ] when ] recover ; diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor index e4a7e6e0e8..009d694e21 100755 --- a/extra/ui/tools/listener/listener.factor +++ b/extra/ui/tools/listener/listener.factor @@ -28,11 +28,7 @@ TUPLE: listener-gadget input output stack ; "Input" f track, ; : welcome. ( -- ) - "If this is your first time with the Factor UI," print - "please read " write - "ui-tools" ($link) " and " write - "ui-listener" ($link) "." print nl - "If you are completely new to Factor, start with the " print + "If this is your first time with Factor, please read the " print "cookbook" ($link) "." print nl ; M: listener-gadget focusable-child* @@ -45,7 +41,8 @@ M: listener-gadget tool-scroller listener-gadget-output find-scroller ; : workspace-busy? ( workspace -- ? ) - workspace-listener listener-gadget-input interactor-busy? ; + workspace-listener listener-gadget-input + interactor-busy? ; : get-listener ( -- listener ) [ workspace-busy? not ] get-workspace* workspace-listener ; @@ -81,8 +78,9 @@ M: listener-operation invoke-command ( target command -- ) listener-gadget-input interactor-eof ; : clear-output ( listener -- ) - [ listener-gadget-output [ pane-clear ] curry ] keep - (call-listener) ; + listener-gadget-output pane-clear ; + +\ clear-output H{ { +listener+ t } } define-command : clear-stack ( listener -- ) [ clear ] swap (call-listener) ; @@ -134,16 +132,16 @@ M: stack-display tool-scroller ] with-stream* ; : restart-listener ( listener -- ) - [ listener-thread ] curry "Listener" spawn drop ; + dup com-end dup clear-output + [ listener-thread ] curry + "Listener" spawn drop ; : init-listener ( listener -- ) f swap set-listener-gadget-stack ; : ( -- gadget ) - listener-gadget construct-empty - dup init-listener - [ listener-output, listener-input, ] { 0 1 } build-track - dup restart-listener ; + listener-gadget construct-empty dup init-listener + [ listener-output, listener-input, ] { 0 1 } build-track ; : listener-help "ui-listener" help-window ; @@ -160,3 +158,11 @@ listener-gadget "toolbar" f { M: listener-gadget handle-gesture* ( gadget gesture delegate -- ? ) 3dup drop swap find-workspace workspace-page handle-gesture [ default-gesture-handler ] [ 3drop f ] if ; + +M: listener-gadget graft* + dup delegate graft* + restart-listener ; + +M: listener-gadget ungraft* + dup com-end + delegate ungraft* ; diff --git a/extra/ui/ui.factor b/extra/ui/ui.factor index e152ea2fa4..787d572326 100755 --- a/extra/ui/ui.factor +++ b/extra/ui/ui.factor @@ -131,12 +131,10 @@ SYMBOL: ui-hook graft-queue [ notify ] dlist-slurp ; : ui-step ( -- ) - [ - do-timers - notify-queued - layout-queued - redraw-worlds - ] assert-depth ; + [ do-timers ] assert-depth + [ notify-queued ] assert-depth + [ layout-queued "a" set ] assert-depth + [ "a" get redraw-worlds ] assert-depth ; : open-world-window ( world -- ) dup pref-dim over set-gadget-dim dup relayout graft ui-step ;