From c8f042aef4c9e9d41eb9d81fab7ad2a074f0037e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 21:34:42 -0600 Subject: [PATCH] Redo timeouts --- core/inference/inference-tests.factor | 3 +- core/io/io-docs.factor | 9 +-- core/io/io.factor | 1 - core/io/streams/duplex/duplex.factor | 5 -- extra/delegate/protocols/protocols.factor | 2 +- extra/http/client/client.factor | 4 +- extra/http/server/server.factor | 2 +- extra/io/launcher/launcher.factor | 26 +++++--- extra/io/nonblocking/nonblocking-docs.factor | 2 - extra/io/nonblocking/nonblocking.factor | 56 ++++------------ extra/io/streams/null/null.factor | 4 +- extra/io/timeouts/timeouts.factor | 67 ++++++++++++++++++++ extra/io/unix/backend/backend.factor | 4 +- extra/io/windows/ce/sockets/sockets.factor | 2 +- extra/io/windows/nt/backend/backend.factor | 2 +- extra/io/windows/nt/files/files.factor | 12 ++-- extra/io/windows/nt/monitors/monitors.factor | 7 +- extra/io/windows/nt/sockets/sockets.factor | 6 +- extra/smtp/server/server.factor | 4 +- extra/smtp/smtp.factor | 9 +-- 20 files changed, 129 insertions(+), 98 deletions(-) create mode 100755 extra/io/timeouts/timeouts.factor mode change 100644 => 100755 extra/smtp/server/server.factor diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index c5bc3b5fda..2691be8c3a 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -4,7 +4,8 @@ math.parser math.private namespaces namespaces.private parser sequences strings vectors words quotations effects tools.test continuations generic.standard sorting assocs definitions prettyprint io inspector tuples classes.union classes.predicate -debugger threads.private io.streams.string combinators.private ; +debugger threads.private io.streams.string io.timeouts +combinators.private ; IN: temporary { 0 2 } [ 2 "Hello" ] must-infer-as diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor index 208e2a2ba7..aff2c6d099 100755 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -21,9 +21,7 @@ $nl { $subsection make-span-stream } { $subsection make-block-stream } { $subsection make-cell-stream } -{ $subsection stream-write-table } -"Optional word for network streams:" -{ $subsection set-timeout } ; +{ $subsection stream-write-table } ; ARTICLE: "stdio" "The default stream" "Various words take an implicit stream parameter from a variable to reduce stack shuffling." @@ -73,11 +71,6 @@ ARTICLE: "streams" "Streams" ABOUT: "streams" -HELP: set-timeout -{ $values { "n" "an integer" } { "stream" "a stream" } } -{ $contract "Sets a timeout, in milliseconds, for input and output operations on the stream. If a read or a write is initiated and no activity is seen before the timeout expires, an error will be thrown to the caller of the operation being performed." } -{ $notes "Whether or not the stream is closed when the error is thrown is implementation-specific, and user code should take care to close the stream on all error conditions in any case." } ; - HELP: stream-readln { $values { "stream" "an input stream" } { "str" string } } { $contract "Reads a line of input from the stream. Outputs " { $link f } " on stream exhaustion." } diff --git a/core/io/io.factor b/core/io/io.factor index e0c890c0e3..2d927d088a 100755 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -4,7 +4,6 @@ USING: hashtables generic kernel math namespaces sequences strings continuations assocs io.styles sbufs ; IN: io -GENERIC: set-timeout ( n stream -- ) GENERIC: stream-readln ( stream -- str ) GENERIC: stream-read1 ( stream -- ch/f ) GENERIC: stream-read ( n stream -- str/f ) diff --git a/core/io/streams/duplex/duplex.factor b/core/io/streams/duplex/duplex.factor index 86660b2752..97e60b4a60 100755 --- a/core/io/streams/duplex/duplex.factor +++ b/core/io/streams/duplex/duplex.factor @@ -74,8 +74,3 @@ M: duplex-stream dispose [ dup duplex-stream-out dispose ] [ dup duplex-stream-in dispose ] [ ] cleanup ] unless drop ; - -M: duplex-stream set-timeout - 2dup - duplex-stream-in set-timeout - duplex-stream-out set-timeout ; diff --git a/extra/delegate/protocols/protocols.factor b/extra/delegate/protocols/protocols.factor index 1121883b7c..37f3812d2d 100755 --- a/extra/delegate/protocols/protocols.factor +++ b/extra/delegate/protocols/protocols.factor @@ -18,7 +18,7 @@ PROTOCOL: stream-protocol stream-read1 stream-read stream-read-until stream-flush stream-write1 stream-write stream-format stream-nl make-span-stream make-block-stream stream-readln - make-cell-stream stream-write-table set-timeout ; + make-cell-stream stream-write-table ; PROTOCOL: definition-protocol where set-where forget uses redefined* diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 109bf17c40..679d603708 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs http kernel math math.parser namespaces sequences -io io.sockets io.streams.string io.files strings splitting -continuations assocs.lib ; +io io.sockets io.streams.string io.files io.timeouts strings +splitting continuations assocs.lib ; IN: http.client : parse-host ( url -- host port ) diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index eca2253e2a..957a82d09f 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs kernel namespaces io strings splitting +USING: assocs kernel namespaces io io.timeouts strings splitting threads http http.server.responders sequences prettyprint io.server logging ; diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 4a6bbf46fb..efcecd50bc 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io io.backend system kernel namespaces strings hashtables -sequences assocs combinators vocabs.loader init threads -continuations math ; +USING: io io.backend io.timeouts system kernel namespaces +strings hashtables sequences assocs combinators vocabs.loader +init threads continuations math ; IN: io.launcher ! Non-blocking process exit notification facility @@ -10,14 +10,14 @@ SYMBOL: processes [ H{ } clone processes set-global ] "io.launcher" add-init-hook -TUPLE: process handle status ; +TUPLE: process handle status killed? lapse ; HOOK: register-process io-backend ( process -- ) M: object register-process drop ; : ( handle -- process ) - f process construct-boa + f f process construct-boa V{ } clone over processes get set-at dup register-process ; @@ -25,6 +25,8 @@ M: process equal? 2drop f ; M: process hashcode* process-handle hashcode* ; +: process-running? ( process -- ? ) process-status not ; + SYMBOL: +command+ SYMBOL: +arguments+ SYMBOL: +detached+ @@ -34,6 +36,7 @@ SYMBOL: +stdin+ SYMBOL: +stdout+ SYMBOL: +stderr+ SYMBOL: +closed+ +SYMBOL: +timeout+ SYMBOL: +prepend-environment+ SYMBOL: +replace-environment+ @@ -72,13 +75,17 @@ M: assoc >descriptor >hashtable ; HOOK: run-process* io-backend ( desc -- handle ) : wait-for-process ( process -- status ) - dup process-handle [ - dup [ processes get at push stop ] curry callcc0 - ] when process-status ; + [ + dup process-handle + [ dup [ processes get at push stop ] curry callcc0 ] when + dup process-killed? + [ "Process was killed" throw ] [ process-status ] if + ] with-timeout ; : run-process ( desc -- process ) >descriptor dup run-process* + +timeout+ pick at [ over set-timeout ] when* +detached+ rot at [ dup wait-for-process drop ] unless ; : run-detached ( desc -- process ) @@ -96,8 +103,11 @@ TUPLE: process-failed code ; HOOK: kill-process* io-backend ( handle -- ) : kill-process ( process -- ) + t over set-process-killed? process-handle [ kill-process* ] when* ; +M: process timed-out kill-process ; + HOOK: process-stream* io-backend ( desc -- stream process ) TUPLE: process-stream process ; diff --git a/extra/io/nonblocking/nonblocking-docs.factor b/extra/io/nonblocking/nonblocking-docs.factor index af73a47030..d8d2cf5479 100755 --- a/extra/io/nonblocking/nonblocking-docs.factor +++ b/extra/io/nonblocking/nonblocking-docs.factor @@ -38,8 +38,6 @@ $nl { $list { { $link port-handle } " - a native handle identifying the underlying native resource used by the port" } { { $link port-error } " - the most recent I/O error, if any. This error is thrown to the waiting thread when " { $link pending-error } " is called by stream operations" } - { { $link port-timeout } " - a timeout, specifying the maximum length of time, in milliseconds, for which input operations can block before throwing an error. A value of 0 denotes no timeout is desired." } - { { $link port-cutoff } " - the time when the current timeout expires; if no input data arrives before this time, an error is thrown" } { { $link port-type } " - a symbol identifying the port's intended purpose" } { { $link port-eof? } " - a flag indicating if the port has reached the end of file while reading" } } } ; diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index 5dbd3d1490..4d8634bde9 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman ! See http://factorcode.org/license.txt for BSD license. IN: io.nonblocking -USING: math kernel io sequences io.buffers generic sbufs system -io.streams.lines io.streams.plain io.streams.duplex io.backend -continuations debugger classes byte-arrays namespaces splitting -dlists assocs ; +USING: math kernel io sequences io.buffers io.timeouts generic +sbufs system io.streams.lines io.streams.plain io.streams.duplex +io.backend continuations debugger classes byte-arrays namespaces +splitting dlists assocs ; SYMBOL: default-buffer-size 64 1024 * default-buffer-size set-global @@ -13,9 +13,12 @@ SYMBOL: default-buffer-size TUPLE: port handle error -timeout-entry timeout cutoff +lapse type eof? ; +! Ports support the lapse protocol +M: port lapse port-lapse ; + SYMBOL: closed PREDICATE: port input-port port-type input-port eq? ; @@ -26,12 +29,11 @@ GENERIC: close-handle ( handle -- ) : ( handle buffer type -- port ) pick init-handle - 0 0 { + { set-port-handle set-delegate set-port-type - set-port-timeout - set-port-cutoff + set-port-lapse } port construct ; : ( handle type -- port ) @@ -48,50 +50,14 @@ GENERIC: close-handle ( handle -- ) [ >r r> ] [ ] [ dispose ] cleanup ; -: timeout? ( port -- ? ) - port-cutoff dup zero? not swap millis < and ; - : pending-error ( port -- ) dup port-error f rot set-port-error [ throw ] when* ; -SYMBOL: timeout-queue - -timeout-queue global [ [ ] unless* ] change-at - -: unqueue-timeout ( port -- ) - port-timeout-entry [ - timeout-queue get-global swap delete-node - ] when* ; - -: queue-timeout ( port -- ) - dup timeout-queue get-global push-front* - swap set-port-timeout-entry ; - HOOK: cancel-io io-backend ( port -- ) M: object cancel-io drop ; -: expire-timeouts ( -- ) - timeout-queue get-global dup dlist-empty? [ drop ] [ - dup peek-back timeout? - [ pop-back cancel-io expire-timeouts ] [ drop ] if - ] if ; - -: begin-timeout ( port -- ) - dup port-timeout dup zero? [ - 2drop - ] [ - millis + over set-port-cutoff - dup unqueue-timeout queue-timeout - ] if ; - -: end-timeout ( port -- ) - unqueue-timeout ; - -: with-port-timeout ( port quot -- ) - over begin-timeout keep end-timeout ; inline - -M: port set-timeout set-port-timeout ; +M: port timed-out cancel-io ; GENERIC: (wait-to-read) ( port -- ) diff --git a/extra/io/streams/null/null.factor b/extra/io/streams/null/null.factor index f76b0cbce3..d747fa0a29 100755 --- a/extra/io/streams/null/null.factor +++ b/extra/io/streams/null/null.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: io.streams.null -USING: kernel io continuations ; +USING: kernel io io.timeouts continuations ; TUPLE: null-stream ; M: null-stream dispose drop ; -M: null-stream set-timeout 2drop ; +M: null-stream set-timeout drop ; M: null-stream stream-readln drop f ; M: null-stream stream-read1 drop f ; M: null-stream stream-read-until 2drop f f ; diff --git a/extra/io/timeouts/timeouts.factor b/extra/io/timeouts/timeouts.factor new file mode 100755 index 0000000000..67bc3a4783 --- /dev/null +++ b/extra/io/timeouts/timeouts.factor @@ -0,0 +1,67 @@ +! Copyright (C) 2008 Slava Pestov, Doug Coleman +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math system dlists namespaces assocs init threads +io.streams.duplex ; +IN: io.timeouts + +TUPLE: lapse entry timeout cutoff ; + +: f 0 0 \ lapse construct-boa ; + +GENERIC: lapse ( obj -- lapse ) +GENERIC: set-timeout ( ms obj -- ) + +M: object set-timeout lapse set-lapse-timeout ; + +M: duplex-stream set-timeout + 2dup + duplex-stream-in set-timeout + duplex-stream-out set-timeout ; + +: timeout ( obj -- ms ) lapse lapse-timeout ; +: entry ( obj -- dlist-node ) lapse lapse-entry ; +: set-entry ( dlist-node -- obj ) lapse set-lapse-entry ; +: cutoff ( obj -- ms ) lapse lapse-cutoff ; +: set-cutoff ( ms obj -- ) lapse set-lapse-cutoff ; + +SYMBOL: timeout-queue + +: timeout? ( lapse -- ? ) + cutoff dup zero? not swap millis < and ; + +timeout-queue global [ [ ] unless* ] change-at + +: unqueue-timeout ( obj -- ) + entry [ + timeout-queue get-global swap delete-node + ] when* ; + +: queue-timeout ( obj -- ) + dup timeout-queue get-global push-front* + swap set-entry ; + +GENERIC: timed-out ( obj -- ) + +M: object timed-out drop ; + +: expire-timeouts ( -- ) + timeout-queue get-global dup dlist-empty? [ drop ] [ + dup peek-back timeout? + [ pop-back timed-out expire-timeouts ] [ drop ] if + ] if ; + +: begin-timeout ( obj -- ) + dup timeout dup zero? [ + 2drop + ] [ + millis + over set-cutoff + dup unqueue-timeout queue-timeout + ] if ; + +: with-timeout ( obj quot -- ) + over begin-timeout keep unqueue-timeout ; inline + +: expiry-thread ( -- ) + expire-timeouts 5000 sleep expire-timeouts ; + +[ expiry-thread ] "io.timeouts" add-init-hook diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 7112c48551..1547ecec65 100755 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -61,7 +61,7 @@ M: mx register-io-task ( task mx -- ) mx get-global register-io-task stop ; : with-port-continuation ( port quot -- port ) - [ callcc0 ] curry with-port-timeout ; inline + [ callcc0 ] curry with-timeout ; inline M: mx unregister-io-task ( task mx -- ) fd/container delete-at drop ; @@ -178,7 +178,7 @@ M: port port-flush ( port -- ) dup buffer-empty? [ drop ] [ (wait-to-write) ] if ; M: unix-io io-multiplex ( ms -- ) - expire-timeouts mx get-global wait-for-events ; + mx get-global wait-for-events ; M: unix-io init-stdio ( -- ) 0 1 handle>duplex-stream io:stdio set-global diff --git a/extra/io/windows/ce/sockets/sockets.factor b/extra/io/windows/ce/sockets/sockets.factor index 9114dceb75..e9ca6220af 100755 --- a/extra/io/windows/ce/sockets/sockets.factor +++ b/extra/io/windows/ce/sockets/sockets.factor @@ -55,7 +55,7 @@ M: windows-ce-io accept ( server -- client ) ] keep ] keep server-port-addr parse-sockaddr swap dup handle>duplex-stream - ] with-port-timeout ; + ] with-timeout ; M: windows-ce-io ( addrspec -- datagram ) [ diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index 760bcec457..597bc99be2 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -91,7 +91,7 @@ M: windows-nt-io cancel-io port-handle win32-file-handle CancelIo drop ; M: windows-nt-io io-multiplex ( ms -- ) - expire-timeouts drain-overlapped ; + drain-overlapped ; M: windows-nt-io init-io ( -- ) master-completion-port set-global diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index a1c331816c..ecc989530e 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.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 ; +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 ; IN: io.windows.nt.files M: windows-nt-io cwd @@ -98,7 +98,7 @@ M: windows-nt-io FileArgs-overlapped ( port -- overlapped ) ] if ; : flush-output ( port -- ) - [ [ (flush-output) ] with-port-timeout ] with-destructors ; + [ [ (flush-output) ] with-timeout ] with-destructors ; M: port port-flush dup buffer-empty? [ dup flush-output ] unless drop ; @@ -122,4 +122,4 @@ M: port port-flush ] [ 2drop ] if ; M: input-port (wait-to-read) ( port -- ) - [ [ ((wait-to-read)) ] with-port-timeout ] with-destructors ; + [ [ ((wait-to-read)) ] with-timeout ] with-destructors ; diff --git a/extra/io/windows/nt/monitors/monitors.factor b/extra/io/windows/nt/monitors/monitors.factor index a593e829fe..a7a1e2f485 100755 --- a/extra/io/windows/nt/monitors/monitors.factor +++ b/extra/io/windows/nt/monitors/monitors.factor @@ -3,8 +3,9 @@ USING: alien.c-types destructors io.windows io.windows.nt.backend kernel math windows windows.kernel32 windows.types libc assocs alien namespaces continuations -io.monitors io.monitors.private io.nonblocking io.buffers io.files -io sequences hashtables sorting arrays combinators ; +io.monitors io.monitors.private io.nonblocking io.buffers +io.files io.timeouts io sequences hashtables sorting arrays +combinators ; IN: io.windows.nt.monitors : open-directory ( path -- handle ) @@ -52,7 +53,7 @@ M: windows-nt-io ( path recursive? -- monitor ) swap [ save-callback ] 2keep dup check-monitor ! we may have closed it... get-overlapped-result - ] with-port-timeout + ] with-timeout ] with-destructors ; : parse-action ( action -- changed ) diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor index 77249df9f1..eef7476dd5 100755 --- a/extra/io/windows/nt/sockets/sockets.factor +++ b/extra/io/windows/nt/sockets/sockets.factor @@ -1,6 +1,6 @@ USING: alien alien.accessors alien.c-types byte-arrays -continuations destructors io.nonblocking io io.sockets -io.sockets.impl namespaces io.streams.duplex io.windows +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 ; IN: io.windows.nt.sockets @@ -139,7 +139,7 @@ M: windows-nt-io accept ( server -- client ) AcceptEx-args-port pending-error dup duplex-stream-in pending-error dup duplex-stream-out pending-error - ] with-port-timeout + ] with-timeout ] with-destructors ; M: windows-nt-io ( addrspec -- server ) diff --git a/extra/smtp/server/server.factor b/extra/smtp/server/server.factor old mode 100644 new mode 100755 index 2cfc1e65e4..275deee994 --- a/extra/smtp/server/server.factor +++ b/extra/smtp/server/server.factor @@ -27,8 +27,8 @@ ! bye ! Connection closed by foreign host. -USING: combinators kernel prettyprint io io.server sequences -namespaces io.sockets continuations ; +USING: combinators kernel prettyprint io io.timeouts io.server +sequences namespaces io.sockets continuations ; SYMBOL: data-mode diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor index 211fbbcabd..27aac1202e 100755 --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -1,8 +1,9 @@ -! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels, Slava Pestov. +! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels, +! Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces io kernel logging io.sockets sequences -combinators sequences.lib splitting assocs strings math.parser -random system calendar ; +USING: namespaces io io.timeouts kernel logging io.sockets +sequences combinators sequences.lib splitting assocs strings +math.parser random system calendar ; IN: smtp