102 lines
3.3 KiB
Factor
102 lines
3.3 KiB
Factor
|
USING: alien alien.c-types arrays assocs combinators continuations
|
||
|
|
destructors io io.backend io.nonblocking io.windows io.windows.nt libc
|
||
|
|
kernel math namespaces sequences threads tuples.lib windows
|
||
|
|
windows.errors windows.kernel32 prettyprint ;
|
||
|
|
IN: io.windows.nt.backend
|
||
|
|
|
||
|
|
SYMBOL: io-hash
|
||
|
|
|
||
|
|
TUPLE: io-callback port continuation ;
|
||
|
|
C: <io-callback> io-callback
|
||
|
|
|
||
|
|
: (make-overlapped) ( -- overlapped-ext )
|
||
|
|
"OVERLAPPED" malloc-object dup [ free ] t add-destructor
|
||
|
|
0 over set-OVERLAPPED-internal
|
||
|
|
0 over set-OVERLAPPED-internal-high
|
||
|
|
0 over set-OVERLAPPED-offset-high
|
||
|
|
0 over set-OVERLAPPED-offset
|
||
|
|
f over set-OVERLAPPED-event ;
|
||
|
|
|
||
|
|
: make-overlapped ( port -- overlapped-ext )
|
||
|
|
>r (make-overlapped) r> port-handle win32-file-ptr
|
||
|
|
[ over set-OVERLAPPED-offset ] when* ;
|
||
|
|
|
||
|
|
: completion-port ( handle existing -- handle )
|
||
|
|
f 1 CreateIoCompletionPort dup win32-error=0/f ;
|
||
|
|
|
||
|
|
: master-completion-port ( -- handle )
|
||
|
|
INVALID_HANDLE_VALUE f completion-port ;
|
||
|
|
|
||
|
|
M: windows-nt-io add-completion ( handle -- )
|
||
|
|
\ master-completion-port get-global completion-port drop ;
|
||
|
|
|
||
|
|
TUPLE: GetOverlappedResult-args hFile* lpOverlapped* lpNumberOfBytesTransferred* bWait* port ;
|
||
|
|
|
||
|
|
C: <GetOverlappedResult-args> GetOverlappedResult-args
|
||
|
|
|
||
|
|
: get-overlapped-result ( port -- n )
|
||
|
|
[
|
||
|
|
port-handle dup win32-file-handle
|
||
|
|
swap win32-file-overlapped 0 <int> 0
|
||
|
|
] keep <GetOverlappedResult-args> [
|
||
|
|
\ GetOverlappedResult-args >tuple<
|
||
|
|
>r GetOverlappedResult r> swap overlapped-error? drop
|
||
|
|
] keep GetOverlappedResult-args-lpNumberOfBytesTransferred* *int ;
|
||
|
|
|
||
|
|
: (save-callback) ( io-callback -- )
|
||
|
|
dup io-callback-port port-handle win32-file-overlapped
|
||
|
|
\ io-hash get-global set-at ;
|
||
|
|
|
||
|
|
: save-callback ( port -- )
|
||
|
|
[
|
||
|
|
<io-callback> (save-callback) stop
|
||
|
|
] callcc0 drop ;
|
||
|
|
|
||
|
|
TUPLE: GetQueuedCompletionStatusParams hCompletionPort* lpNumberOfBytes* lpCompletionKey* lpOverlapped* dwMilliseconds* ;
|
||
|
|
|
||
|
|
C: <GetQueuedCompletionStatusParams> GetQueuedCompletionStatusParams
|
||
|
|
|
||
|
|
: wait-for-overlapped ( ms -- GetQueuedCompletionStatus-Params ret )
|
||
|
|
>r \ master-completion-port get-global 0 <int>
|
||
|
|
0 <int> 0 <int> r> <GetQueuedCompletionStatusParams> [
|
||
|
|
GetQueuedCompletionStatusParams >tuple*<
|
||
|
|
GetQueuedCompletionStatus
|
||
|
|
] keep swap ;
|
||
|
|
|
||
|
|
: lookup-callback ( GetQueuedCompletion-args -- callback ? )
|
||
|
|
GetQueuedCompletionStatusParams-lpOverlapped* *void*
|
||
|
|
\ io-hash get-global delete-at* ;
|
||
|
|
|
||
|
|
: wait-for-io ( timeout -- continuation/f )
|
||
|
|
wait-for-overlapped
|
||
|
|
zero? [
|
||
|
|
GetLastError dup (expected-io-error?) [
|
||
|
|
2drop f
|
||
|
|
] [
|
||
|
|
(win32-error-string) swap lookup-callback [
|
||
|
|
[ io-callback-port set-port-error ] keep
|
||
|
|
io-callback-continuation
|
||
|
|
] [
|
||
|
|
drop "No callback found" 2array throw
|
||
|
|
] if
|
||
|
|
] if
|
||
|
|
] [
|
||
|
|
lookup-callback [ io-callback-continuation ] when
|
||
|
|
] if ;
|
||
|
|
|
||
|
|
: maybe-expire ( io-callbck -- )
|
||
|
|
io-callback-port
|
||
|
|
dup timeout? [
|
||
|
|
port-handle win32-file-handle CancelIo drop
|
||
|
|
] [
|
||
|
|
drop
|
||
|
|
] if ;
|
||
|
|
|
||
|
|
: cancel-timedout ( -- )
|
||
|
|
io-hash get-global values [ maybe-expire ] each ;
|
||
|
|
|
||
|
|
M: windows-nt-io io-multiplex ( ms -- )
|
||
|
|
cancel-timedout
|
||
|
|
[ wait-for-io ] [ global [ "error: " write . flush ] bind drop f ] recover
|
||
|
|
[ schedule-thread ] when* ;
|