From 17386317577d280fb2adfd8b4e134acbfc7c66f5 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Sat, 17 May 2008 18:24:20 -0500 Subject: [PATCH 1/3] Fix memory management issue --- extra/io/windows/nt/sockets/sockets.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor index c680d18077..a31c41942f 100755 --- a/extra/io/windows/nt/sockets/sockets.factor +++ b/extra/io/windows/nt/sockets/sockets.factor @@ -131,7 +131,8 @@ TUPLE: WSARecvFrom-args port WSARecvFrom-args >tuple*< WSARecvFrom socket-error* ; : parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr ) - [ lpBuffers*>> WSABUF-buf swap memory>byte-array ] [ lpFrom*>> ] bi ; + [ lpBuffers*>> WSABUF-buf swap memory>byte-array ] + [ [ lpFrom*>> ] [ lpFromLen*>> *int ] bi memory>byte-array ] bi ; M: winnt (receive) ( datagram -- packet addrspec ) [ From dcce702d0c643997ced4f49e6df8fd905fa5c8b2 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Sat, 17 May 2008 23:50:11 -0500 Subject: [PATCH 2/3] Remove pending-error machinery --- core/io/files/files-tests.factor | 2 + core/io/streams/c/c.factor | 6 + extra/io/monitors/monitors-tests.factor | 19 ++- extra/io/ports/ports-docs.factor | 14 +- extra/io/ports/ports.factor | 16 +-- extra/io/sockets/sockets-tests.factor | 8 +- extra/io/unix/backend/backend.factor | 31 +++-- extra/io/unix/sockets/secure/secure.factor | 4 +- extra/io/windows/nt/backend/backend.factor | 129 ++++++++----------- extra/io/windows/nt/monitors/monitors.factor | 2 +- 10 files changed, 117 insertions(+), 114 deletions(-) mode change 100644 => 100755 extra/io/monitors/monitors-tests.factor mode change 100644 => 100755 extra/io/unix/backend/backend.factor mode change 100644 => 100755 extra/io/unix/sockets/secure/secure.factor diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index 14bc5fe2a2..f10bcef8a9 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -105,6 +105,8 @@ strings accessors io.encodings.utf8 math destructors ; [ f ] [ "test-bar.txt" temp-file exists? ] unit-test +[ "test-blah" temp-file delete-tree ] ignore-errors + [ ] [ "test-blah" temp-file make-directory ] unit-test [ ] [ diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor index f80d9de5b5..365d5b7c5d 100755 --- a/core/io/streams/c/c.factor +++ b/core/io/streams/c/c.factor @@ -10,12 +10,15 @@ TUPLE: c-writer handle disposed ; : ( handle -- stream ) f c-writer boa ; M: c-writer stream-write1 + dup check-disposed handle>> fputc ; M: c-writer stream-write + dup check-disposed handle>> fwrite ; M: c-writer stream-flush + dup check-disposed handle>> fflush ; M: c-writer dispose* @@ -26,12 +29,14 @@ TUPLE: c-reader handle disposed ; : ( handle -- stream ) f c-reader boa ; M: c-reader stream-read + dup check-disposed handle>> fread ; M: c-reader stream-read-partial stream-read ; M: c-reader stream-read1 + dup check-disposed handle>> fgetc ; : read-until-loop ( stream delim -- ch ) @@ -42,6 +47,7 @@ M: c-reader stream-read1 ] if ; M: c-reader stream-read-until + dup check-disposed [ swap read-until-loop ] B{ } make swap over empty? over not and [ 2drop f f ] when ; diff --git a/extra/io/monitors/monitors-tests.factor b/extra/io/monitors/monitors-tests.factor old mode 100644 new mode 100755 index 6e7196960d..bd33954436 --- a/extra/io/monitors/monitors-tests.factor +++ b/extra/io/monitors/monitors-tests.factor @@ -1,7 +1,7 @@ IN: io.monitors.tests USING: io.monitors tools.test io.files system sequences continuations namespaces concurrency.count-downs kernel io -threads calendar prettyprint destructors ; +threads calendar prettyprint destructors io.timeouts ; os { winnt linux macosx } member? [ [ @@ -91,4 +91,21 @@ os { winnt linux macosx } member? [ ! Out-of-scope disposal should not fail [ ] [ [ "" resource-path f ] with-monitors dispose ] unit-test [ ] [ [ "" resource-path t ] with-monitors dispose ] unit-test + + ! Timeouts + [ + [ ] [ "monitor-timeout-test" temp-file make-directories ] unit-test + + ! Non-recursive + [ ] [ "monitor-timeout-test" temp-file f "m" set ] unit-test + [ ] [ 3 seconds "m" get set-timeout ] unit-test + [ [ t ] [ "m" get next-change 2drop ] [ ] while ] must-fail + [ ] [ "m" get dispose ] unit-test + + ! Recursive + [ ] [ "monitor-timeout-test" temp-file t "m" set ] unit-test + [ ] [ 3 seconds "m" get set-timeout ] unit-test + [ [ t ] [ "m" get next-change 2drop ] [ ] while ] must-fail + [ ] [ "m" get dispose ] unit-test + ] with-monitors ] when diff --git a/extra/io/ports/ports-docs.factor b/extra/io/ports/ports-docs.factor index 63d1507692..40890e877b 100755 --- a/extra/io/ports/ports-docs.factor +++ b/extra/io/ports/ports-docs.factor @@ -29,15 +29,7 @@ $nl ABOUT: "io.ports" HELP: port -{ $class-description "Instances of this class present a blocking stream interface on top of an underlying non-blocking I/O system, giving the illusion of blocking by yielding the thread which is waiting for input or output." -$nl -"Ports have the following slots:" -{ $list - { { $snippet "handle" } " - a native handle identifying the underlying native resource used by the port" } - { { $snippet "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" } - { { $snippet "type" } " - a symbol identifying the port's intended purpose" } - { { $snippet "eof" } " - a flag indicating if the port has reached the end of file while reading" } -} } ; +{ $class-description "Instances of this class present a blocking stream interface on top of an underlying non-blocking I/O system, giving the illusion of blocking by yielding the thread which is waiting for input or output." } ; HELP: input-port { $class-description "The class of ports implementing the input stream protocol." } ; @@ -65,10 +57,6 @@ HELP: { $description "Creates a new " { $link output-port } " using the specified native handle and a default-sized input buffer." } $low-level-note ; -HELP: pending-error -{ $values { "port" port } } -{ $description "If an error occurred while the I/O thread was performing input or output on this port, this error will be thrown to the caller." } ; - HELP: (wait-to-read) { $values { "port" input-port } } { $contract "Suspends the current thread until the port's buffer has data available for reading." } ; diff --git a/extra/io/ports/ports.factor b/extra/io/ports/ports.factor index d345975441..128a8b788b 100755 --- a/extra/io/ports/ports.factor +++ b/extra/io/ports/ports.factor @@ -10,7 +10,7 @@ IN: io.ports SYMBOL: default-buffer-size 64 1024 * default-buffer-size set-global -TUPLE: port handle error timeout disposed ; +TUPLE: port handle timeout disposed ; M: port timeout timeout>> ; @@ -19,9 +19,6 @@ M: port set-timeout (>>timeout) ; : ( handle class -- port ) new swap >>handle ; inline -: pending-error ( port -- ) - [ f ] change-error drop [ throw ] when* ; - TUPLE: buffered-port < port buffer ; : ( handle class -- port ) @@ -106,14 +103,15 @@ M: output-port stream-write HOOK: (wait-to-write) io-backend ( port -- ) -: flush-port ( port -- ) - dup buffer>> buffer-empty? [ drop ] [ (wait-to-write) ] if ; +: port-flush ( port -- ) + dup buffer>> buffer-empty? + [ drop ] [ dup (wait-to-write) port-flush ] if ; M: output-port stream-flush ( port -- ) - [ check-disposed ] [ flush-port ] bi ; + [ check-disposed ] [ port-flush ] bi ; -M: output-port dispose* - [ flush-port ] [ call-next-method ] bi ; +M: output-port dispose + [ port-flush ] [ call-next-method ] bi ; M: buffered-port dispose* [ call-next-method ] diff --git a/extra/io/sockets/sockets-tests.factor b/extra/io/sockets/sockets-tests.factor index c411e30ae6..dfeb311312 100755 --- a/extra/io/sockets/sockets-tests.factor +++ b/extra/io/sockets/sockets-tests.factor @@ -1,6 +1,6 @@ IN: io.sockets.tests USING: io.sockets sequences math tools.test namespaces accessors -kernel destructors ; +kernel destructors calendar io.timeouts ; [ B{ 1 2 3 4 } ] [ "1.2.3.4" T{ inet4 } inet-pton ] unit-test @@ -62,3 +62,9 @@ kernel destructors ; [ ] [ "datagram1" get dispose ] unit-test [ ] [ "datagram2" get dispose ] unit-test + +! Test timeouts +[ ] [ "127.0.0.1" 0 "datagram3" set ] unit-test + +[ ] [ 1 seconds "datagram3" get set-timeout ] unit-test +[ "datagram3" get receive ] must-fail diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor old mode 100644 new mode 100755 index 2d5ebb98ca..d43350e425 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -62,21 +62,18 @@ GENERIC: wait-for-events ( ms mx -- ) : output-available ( fd mx -- ) remove-output-callbacks [ resume ] each ; -TUPLE: io-timeout ; - -M: io-timeout summary drop "I/O operation timed out" ; - M: unix cancel-io ( port -- ) - io-timeout new >>error handle>> handle-fd mx get-global - [ input-available ] [ output-available ] 2bi ; + [ remove-input-callbacks [ t swap resume-with ] each ] + [ remove-output-callbacks [ t swap resume-with ] each ] + 2bi ; SYMBOL: +retry+ ! just try the operation again without blocking SYMBOL: +input+ SYMBOL: +output+ -: wait-for-fd ( handle event -- ) - dup +retry+ eq? [ 2drop ] [ +: wait-for-fd ( handle event -- timeout? ) + dup +retry+ eq? [ 2drop f ] [ [ >r swap handle-fd @@ -85,12 +82,18 @@ SYMBOL: +output+ { +input+ [ add-input-callback ] } { +output+ [ add-output-callback ] } } case - ] curry "I/O" suspend 2drop + ] curry "I/O" suspend nip ] if ; +ERROR: io-timeout ; + +M: io-timeout summary drop "I/O operation timed out" ; + : wait-for-port ( port event -- ) - [ >r dup handle>> r> wait-for-fd ] curry - with-timeout pending-error ; + [ + >r handle>> r> wait-for-fd + [ io-timeout ] when + ] with-timeout ; ! Some general stuff : file-mode OCT: 0666 ; @@ -147,8 +150,7 @@ M: fd drain } cond ; M: unix (wait-to-write) ( port -- ) - dup dup handle>> drain dup - [ dupd wait-for-port (wait-to-write) ] [ 2drop ] if ; + dup dup handle>> drain dup [ wait-for-port ] [ 2drop ] if ; M: unix io-multiplex ( ms/f -- ) mx get-global wait-for-events ; @@ -166,7 +168,8 @@ TUPLE: mx-port < port mx ; : multiplexer-error ( n -- ) 0 < [ - err_no [ EAGAIN = ] [ EINTR = ] bi or [ (io-error) ] unless + err_no [ EAGAIN = ] [ EINTR = ] bi or + [ (io-error) ] unless ] when ; : ?flag ( n mask symbol -- n ) diff --git a/extra/io/unix/sockets/secure/secure.factor b/extra/io/unix/sockets/secure/secure.factor old mode 100644 new mode 100755 index b4381de43b..28ecee7c1a --- a/extra/io/unix/sockets/secure/secure.factor +++ b/extra/io/unix/sockets/secure/secure.factor @@ -111,7 +111,7 @@ M: ssl (server) addrspec>> (server) ; : do-ssl-accept ( ssl-handle -- ) dup dup handle>> SSL_accept check-accept-response dup - [ >r dup file>> r> wait-for-fd do-ssl-accept ] [ 2drop ] if ; + [ >r dup file>> r> wait-for-fd drop do-ssl-accept ] [ 2drop ] if ; M: ssl (accept) [ @@ -144,5 +144,5 @@ M: ssl (accept) M: unix ssl-shutdown dup connected>> [ dup handle>> dup SSL_shutdown check-shutdown-response - dup [ dupd wait-for-fd ssl-shutdown ] [ 2drop ] if + dup [ dupd wait-for-fd drop ssl-shutdown ] [ 2drop ] if ] [ drop ] if ; diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index 134a0c024a..73f4688ac9 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -8,7 +8,8 @@ accessors locals ; QUALIFIED: windows.winsock IN: io.windows.nt.backend -SYMBOL: io-hash +! Global variable with assoc mapping overlapped to threads +SYMBOL: pending-overlapped TUPLE: io-callback port thread ; @@ -33,62 +34,41 @@ M: winnt add-completion ( win32-handle -- ) handle>> master-completion-port get-global drop ; : eof? ( error -- ? ) - dup ERROR_HANDLE_EOF = swap ERROR_BROKEN_PIPE = or ; - -: overlapped-error? ( port n -- ? ) - zero? [ - GetLastError { - { [ dup expected-io-error? ] [ 2drop t ] } - { [ dup eof? ] [ drop t >>eof drop f ] } - [ (win32-error-string) throw ] - } cond - ] [ - drop t - ] if ; - -: get-overlapped-result ( overlapped port -- bytes-transferred ) - dup handle>> handle>> rot 0 - [ 0 GetOverlappedResult overlapped-error? drop ] keep *uint ; - -: save-callback ( overlapped port -- ) - [ - swap - dup alien? [ "bad overlapped in save-callback" throw ] unless - io-hash get-global set-at - ] "I/O" suspend 3drop ; + [ ERROR_HANDLE_EOF = ] [ ERROR_BROKEN_PIPE = ] bi or ; : twiddle-thumbs ( overlapped port -- bytes-transferred ) - [ save-callback ] - [ get-overlapped-result ] - [ nip pending-error ] - 2tri ; - -:: wait-for-overlapped ( ms -- overlapped ? ) - master-completion-port get-global - 0 ! bytes - f ! key - f ! overlapped [ - ms INFINITE or ! timeout - GetQueuedCompletionStatus - ] keep *void* swap zero? ; + drop + [ pending-overlapped get-global set-at ] curry "I/O" suspend + { + { [ dup integer? ] [ ] } + { [ dup array? ] [ + first dup eof? + [ drop 0 ] [ (win32-error-string) throw ] if + ] } + } cond + ] with-timeout ; -: lookup-callback ( overlapped -- callback ) - io-hash get-global delete-at* drop - dup io-callback? [ "no callback in io-hash" throw ] unless ; +:: wait-for-overlapped ( ms -- bytes-transferred overlapped error? ) + master-completion-port get-global + 0 [ ! bytes + f ! key + f [ ! overlapped + ms INFINITE or ! timeout + GetQueuedCompletionStatus zero? + ] keep *void* + ] keep *int spin ; + +: resume-callback ( result overlapped -- ) + pending-overlapped get-global delete-at* drop resume-with ; : handle-overlapped ( timeout -- ? ) wait-for-overlapped [ - GetLastError dup expected-io-error? [ 2drop f ] [ - >r lookup-callback [ thread>> ] [ port>> ] bi r> - dup eof? - [ drop t >>eof ] - [ (win32-error-string) >>error ] if drop - resume t - ] if + >r drop GetLastError + [ 1array ] [ expected-io-error? ] bi + [ r> 2drop f ] [ r> resume-callback t ] if ] [ - lookup-callback - thread>> resume t + resume-callback t ] if ; M: winnt cancel-io @@ -99,29 +79,35 @@ M: winnt io-multiplex ( ms -- ) M: winnt init-io ( -- ) master-completion-port set-global - H{ } clone io-hash set-global + H{ } clone pending-overlapped set-global windows.winsock:init-winsock ; +: file-error? ( n -- eof? ) + zero? [ + GetLastError { + { [ dup expected-io-error? ] [ drop f ] } + { [ dup eof? ] [ drop t ] } + [ (win32-error-string) throw ] + } cond + ] [ f ] if ; + +: wait-for-file ( FileArgs n port -- n ) + swap file-error? + [ 2drop 0 ] [ >r lpOverlapped>> r> twiddle-thumbs ] if ; + : update-file-ptr ( n port -- ) handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ; -: finish-flush ( n port -- ) +: finish-write ( n port -- ) [ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ; -: ((wait-to-write)) ( port -- ) - dup make-FileArgs - tuck setup-write WriteFile - dupd overlapped-error? [ - >r lpOverlapped>> r> - [ twiddle-thumbs ] keep - [ finish-flush ] keep - dup buffer>> buffer-empty? [ drop ] [ ((wait-to-write)) ] if - ] [ - 2drop - ] if ; - M: winnt (wait-to-write) - [ [ ((wait-to-write)) ] with-timeout ] with-destructors ; + [ + [ make-FileArgs dup setup-write WriteFile ] + [ wait-for-file ] + [ finish-write ] + tri + ] with-destructors ; : finish-read ( n port -- ) over zero? [ @@ -130,13 +116,10 @@ M: winnt (wait-to-write) [ buffer>> n>buffer ] [ update-file-ptr ] 2bi ] if ; -: ((wait-to-read)) ( port -- ) - dup make-FileArgs - tuck setup-read ReadFile - dupd overlapped-error? [ - >r lpOverlapped>> r> - [ twiddle-thumbs ] [ finish-read ] bi - ] [ 2drop ] if ; - M: winnt (wait-to-read) ( port -- ) - [ [ ((wait-to-read)) ] with-timeout ] with-destructors ; + [ + [ make-FileArgs dup setup-read ReadFile ] + [ wait-for-file ] + [ finish-read ] + tri + ] with-destructors ; diff --git a/extra/io/windows/nt/monitors/monitors.factor b/extra/io/windows/nt/monitors/monitors.factor index a509d1d5e7..fa4d19a46e 100755 --- a/extra/io/windows/nt/monitors/monitors.factor +++ b/extra/io/windows/nt/monitors/monitors.factor @@ -35,7 +35,7 @@ TUPLE: win32-monitor < monitor port ; (make-overlapped) [ f ReadDirectoryChangesW win32-error=0/f ] keep ; -: read-changes ( port -- bytes ) +: read-changes ( port -- bytes-transferred ) [ [ begin-reading-changes ] [ twiddle-thumbs ] bi ] with-destructors ; From 8a35f7c099c77951b4cce81ddff2ebfde2e3120a Mon Sep 17 00:00:00 2001 From: slava Date: Sun, 18 May 2008 16:50:50 -0500 Subject: [PATCH 3/3] Better error message --- extra/openal/openal.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/openal/openal.factor b/extra/openal/openal.factor index c0a79d8353..38d61a8823 100644 --- a/extra/openal/openal.factor +++ b/extra/openal/openal.factor @@ -235,13 +235,13 @@ SYMBOL: init : init-openal ( -- ) init get-global expired? [ - f f alutInit drop + f f alutInit 0 = [ "Could not initialize OpenAL" throw ] when 1337 init set-global ] when ; : exit-openal ( -- ) init get-global expired? [ - alutExit drop + alutExit 0 = [ "Could not close OpenAL" throw ] when f init set-global ] unless ;