Clean up Windows I/O
Slava Pestov
parent
5031cca224
commit
c79b8d8471
|
|
@ -8,7 +8,7 @@ IN: io.windows.ce.backend
|
|||
win32-error-string swap set-port-error ;
|
||||
|
||||
M: windows-ce-io io-multiplex ( ms -- ) (sleep) ;
|
||||
M: windows-ce-io add-completion ( port -- ) drop ;
|
||||
M: windows-ce-io add-completion ( handle -- ) drop ;
|
||||
|
||||
GENERIC: wince-read ( port port-handle -- )
|
||||
|
||||
|
|
|
|||
|
|
@ -43,7 +43,7 @@ M: windows-nt-io normalize-pathname ( string -- string )
|
|||
|
||||
SYMBOL: io-hash
|
||||
|
||||
TUPLE: io-callback continuation port ;
|
||||
TUPLE: io-callback port continuation ;
|
||||
|
||||
C: <io-callback> io-callback
|
||||
|
||||
|
|
@ -59,12 +59,6 @@ C: <io-callback> io-callback
|
|||
>r (make-overlapped) r> port-handle win32-file-ptr
|
||||
[ over set-OVERLAPPED-offset ] when* ;
|
||||
|
||||
: port-overlapped ( port -- overlapped )
|
||||
port-handle win32-file-overlapped ;
|
||||
|
||||
: set-port-overlapped ( overlapped port -- )
|
||||
port-handle set-win32-file-overlapped ;
|
||||
|
||||
: <completion-port> ( handle existing -- handle )
|
||||
f 1 CreateIoCompletionPort dup win32-error=0/f ;
|
||||
|
||||
|
|
@ -90,21 +84,16 @@ M: windows-nt-io add-completion ( handle -- )
|
|||
drop t
|
||||
] if ;
|
||||
|
||||
: get-overlapped-result ( port -- bytes-transferred )
|
||||
dup
|
||||
port-handle
|
||||
dup win32-file-handle
|
||||
swap win32-file-overlapped
|
||||
0 <uint> [
|
||||
0
|
||||
GetOverlappedResult overlapped-error? drop
|
||||
] keep *uint ;
|
||||
: get-overlapped-result ( overlapped port -- bytes-transferred )
|
||||
dup port-handle win32-file-handle rot 0 <uint>
|
||||
[ 0 GetOverlappedResult overlapped-error? drop ] keep *uint ;
|
||||
|
||||
: save-callback ( port -- )
|
||||
: save-callback ( overlapped port -- )
|
||||
[
|
||||
[ <io-callback> ] keep port-handle win32-file-overlapped
|
||||
<io-callback> swap
|
||||
dup alien? [ "bad overlapped in save-callback" throw ] unless
|
||||
io-hash get-global set-at stop
|
||||
] curry callcc0 ;
|
||||
] callcc0 2drop ;
|
||||
|
||||
: wait-for-overlapped ( ms -- overlapped ? )
|
||||
>r master-completion-port get-global r> ! port ms
|
||||
|
|
@ -113,8 +102,9 @@ M: windows-nt-io add-completion ( handle -- )
|
|||
f <void*> ! overlapped
|
||||
[ roll GetQueuedCompletionStatus ] keep *void* swap zero? ;
|
||||
|
||||
: lookup-callback ( GetQueuedCompletion-args -- callback )
|
||||
io-hash get-global delete-at* drop ;
|
||||
: lookup-callback ( overlapped -- callback )
|
||||
io-hash get-global delete-at* drop
|
||||
dup io-callback? [ "no callback in io-hash" throw ] unless ;
|
||||
|
||||
: handle-overlapped ( timeout -- ? )
|
||||
wait-for-overlapped [
|
||||
|
|
|
|||
|
|
@ -17,22 +17,19 @@ M: windows-nt-io FileArgs-overlapped ( port -- overlapped )
|
|||
2drop
|
||||
] if* ;
|
||||
|
||||
: finish-flush ( port -- )
|
||||
: finish-flush ( overlapped port -- )
|
||||
dup pending-error
|
||||
dup get-overlapped-result
|
||||
tuck get-overlapped-result
|
||||
dup pick update-file-ptr
|
||||
swap buffer-consume ;
|
||||
|
||||
: save-overlapped-and-callback ( fileargs port -- )
|
||||
swap FileArgs-lpOverlapped over set-port-overlapped
|
||||
save-callback ;
|
||||
|
||||
: (flush-output) ( port -- )
|
||||
dup touch-port
|
||||
dup make-FileArgs
|
||||
tuck setup-write WriteFile
|
||||
dupd overlapped-error? [
|
||||
[ save-overlapped-and-callback ] keep
|
||||
>r FileArgs-lpOverlapped r>
|
||||
[ save-callback ] 2keep
|
||||
[ finish-flush ] keep
|
||||
dup buffer-empty? [ drop ] [ (flush-output) ] if
|
||||
] [
|
||||
|
|
@ -45,9 +42,9 @@ M: windows-nt-io FileArgs-overlapped ( port -- overlapped )
|
|||
M: port port-flush
|
||||
dup buffer-empty? [ dup flush-output ] unless drop ;
|
||||
|
||||
: finish-read ( port -- )
|
||||
: finish-read ( overlapped port -- )
|
||||
dup pending-error
|
||||
dup get-overlapped-result dup zero? [
|
||||
tuck get-overlapped-result dup zero? [
|
||||
drop t swap set-port-eof?
|
||||
] [
|
||||
dup pick n>buffer
|
||||
|
|
@ -59,7 +56,8 @@ M: port port-flush
|
|||
dup make-FileArgs
|
||||
tuck setup-read ReadFile
|
||||
dupd overlapped-error? [
|
||||
[ save-overlapped-and-callback ] keep
|
||||
>r FileArgs-lpOverlapped r>
|
||||
[ save-callback ] 2keep
|
||||
finish-read
|
||||
] [
|
||||
2drop
|
||||
|
|
|
|||
|
|
@ -1,55 +1,58 @@
|
|||
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types destructors io.windows kernel math windows
|
||||
windows.kernel32 windows.types libc assocs alien namespaces
|
||||
continuations io.monitor sequences hashtables sorting arrays ;
|
||||
USING: alien.c-types destructors io.windows
|
||||
io.windows.nt.backend kernel math windows windows.kernel32
|
||||
windows.types libc assocs alien namespaces continuations
|
||||
io.monitor io.nonblocking io.buffers io.files io sequences
|
||||
hashtables sorting arrays ;
|
||||
IN: io.windows.nt.monitor
|
||||
|
||||
TUPLE: monitor handle recursive? buffer queue closed? ;
|
||||
TUPLE: monitor path recursive? queue closed? ;
|
||||
|
||||
: open-directory ( path -- handle )
|
||||
[
|
||||
FILE_LIST_DIRECTORY
|
||||
share-mode
|
||||
f
|
||||
OPEN_EXISTING
|
||||
FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED bitor
|
||||
f
|
||||
CreateFile dup invalid-handle? dup close-later
|
||||
] with-destructors ;
|
||||
|
||||
: buffer-size 65536 ; inline
|
||||
FILE_LIST_DIRECTORY
|
||||
share-mode
|
||||
f
|
||||
OPEN_EXISTING
|
||||
FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED bitor
|
||||
f
|
||||
CreateFile
|
||||
dup invalid-handle?
|
||||
dup close-later
|
||||
dup add-completion
|
||||
f <win32-file> ;
|
||||
|
||||
M: windows-nt-io <monitor> ( path recursive? -- monitor )
|
||||
[
|
||||
>r open-directory r>
|
||||
buffer-size malloc dup free-later f
|
||||
] with-destructors
|
||||
f monitor construct-boa ;
|
||||
>r dup open-directory monitor <buffered-port> r> {
|
||||
set-monitor-path
|
||||
set-delegate
|
||||
set-monitor-recursive?
|
||||
} monitor construct
|
||||
] with-destructors ;
|
||||
|
||||
: check-closed ( monitor -- )
|
||||
monitor-closed? [ "Monitor closed" throw ] when ;
|
||||
port-type closed eq? [ "Monitor closed" throw ] when ;
|
||||
|
||||
M: windows-nt-io close-monitor ( monitor -- )
|
||||
dup check-closed
|
||||
dup monitor-buffer free
|
||||
dup monitor-handle CloseHandle drop
|
||||
t swap set-monitor-closed? ;
|
||||
M: windows-nt-io close-monitor ( monitor -- ) stream-close ;
|
||||
|
||||
: fill-buffer ( monitor -- bytes )
|
||||
: begin-reading-changes ( monitor -- overlapped )
|
||||
[
|
||||
dup monitor-handle
|
||||
over monitor-buffer
|
||||
buffer-size
|
||||
dup port-handle win32-file-handle
|
||||
over buffer-ptr
|
||||
pick buffer-size
|
||||
roll monitor-recursive? 1 0 ?
|
||||
FILE_NOTIFY_CHANGE_ALL
|
||||
0 <uint> [
|
||||
f
|
||||
f
|
||||
ReadDirectoryChangesW win32-error=0/f
|
||||
] keep *uint
|
||||
0 <uint>
|
||||
f
|
||||
(make-overlapped)
|
||||
[ ReadDirectoryChangesW win32-error=0/f ] keep
|
||||
] with-destructors ;
|
||||
|
||||
: read-changes ( monitor -- bytes )
|
||||
dup begin-reading-changes swap [ save-callback ] 2keep
|
||||
get-overlapped-result ;
|
||||
|
||||
: parse-action-flag ( action mask symbol -- action )
|
||||
>r over bitand 0 > [ r> , ] [ r> drop ] if ;
|
||||
|
||||
|
|
@ -68,34 +71,30 @@ M: windows-nt-io close-monitor ( monitor -- )
|
|||
drop
|
||||
] { } make ;
|
||||
|
||||
: changed-file ( buffer -- changes path )
|
||||
: changed-file ( directory buffer -- changes path )
|
||||
{
|
||||
FILE_NOTIFY_INFORMATION-FileName
|
||||
FILE_NOTIFY_INFORMATION-FileNameLength
|
||||
FILE_NOTIFY_INFORMATION-Action
|
||||
} get-slots parse-action -rot memory>u16-string ;
|
||||
} get-slots >r memory>u16-string path+ r> parse-action swap ;
|
||||
|
||||
: (changed-files) ( buffer -- )
|
||||
dup changed-file namespace [ append ] change-at
|
||||
dup FILE_NOTIFY_INFORMATION-NextEntryOffset
|
||||
dup zero? [ 2drop ] [
|
||||
swap <displaced-alien> (changed-files)
|
||||
] if ;
|
||||
: (changed-files) ( directory buffer -- )
|
||||
2dup changed-file namespace [ append ] change-at
|
||||
dup FILE_NOTIFY_INFORMATION-NextEntryOffset dup zero?
|
||||
[ 3drop ] [ swap <displaced-alien> (changed-files) ] if ;
|
||||
|
||||
: changed-files ( buffer len -- assoc )
|
||||
[
|
||||
zero? [ drop ] [ (changed-files) ] if
|
||||
] H{ } make-assoc ;
|
||||
: changed-files ( directory buffer len -- assoc )
|
||||
[ zero? [ 2drop ] [ (changed-files) ] if ] H{ } make-assoc ;
|
||||
|
||||
: fill-queue ( monitor -- )
|
||||
dup monitor-buffer
|
||||
over fill-buffer changed-files
|
||||
dup monitor-path over buffer-ptr pick read-changes
|
||||
changed-files
|
||||
swap set-monitor-queue ;
|
||||
|
||||
M: windows-nt-io next-change ( monitor -- path changes )
|
||||
dup check-closed
|
||||
dup monitor-queue dup assoc-empty? [
|
||||
drop dup fill-queue next-change
|
||||
drop dup fill-queue next-change
|
||||
] [
|
||||
nip delete-any prune natural-sort >array
|
||||
] if ;
|
||||
|
|
|
|||
|
|
@ -44,12 +44,11 @@ TUPLE: ConnectEx-args port
|
|||
"stdcall" alien-indirect drop
|
||||
winsock-error-string [ throw ] when* ;
|
||||
|
||||
: check-connect-error ( ConnectEx -- )
|
||||
ConnectEx-args-port duplex-stream-in get-overlapped-result drop ;
|
||||
|
||||
: connect-continuation ( ConnectEx -- )
|
||||
[ ConnectEx-args-port duplex-stream-in save-callback ] keep
|
||||
check-connect-error ;
|
||||
dup ConnectEx-args-lpOverlapped*
|
||||
swap ConnectEx-args-port duplex-stream-in
|
||||
[ save-callback ] 2keep
|
||||
get-overlapped-result drop ;
|
||||
|
||||
M: windows-nt-io (client) ( addrspec -- duplex-stream )
|
||||
[
|
||||
|
|
@ -64,10 +63,6 @@ M: windows-nt-io (client) ( addrspec -- duplex-stream )
|
|||
dup ConnectEx-args-s* <win32-socket> dup handle>duplex-stream
|
||||
over set-ConnectEx-args-port
|
||||
|
||||
[
|
||||
dup ConnectEx-args-lpOverlapped*
|
||||
swap ConnectEx-args-port duplex-stream-in set-port-overlapped
|
||||
] keep
|
||||
dup connect-continuation
|
||||
ConnectEx-args-port
|
||||
[ duplex-stream-in pending-error ] keep
|
||||
|
|
@ -93,8 +88,7 @@ TUPLE: AcceptEx-args port
|
|||
over set-AcceptEx-args-sAcceptSocket*
|
||||
0 over set-AcceptEx-args-dwReceiveDataLength*
|
||||
f over set-AcceptEx-args-lpdwBytesReceived*
|
||||
(make-overlapped) over set-AcceptEx-args-lpOverlapped*
|
||||
dup AcceptEx-args-lpOverlapped* swap AcceptEx-args-port set-port-overlapped ;
|
||||
(make-overlapped) swap set-AcceptEx-args-lpOverlapped* ;
|
||||
|
||||
: (accept) ( AcceptEx -- )
|
||||
\ AcceptEx-args >tuple*<
|
||||
|
|
@ -102,10 +96,12 @@ TUPLE: AcceptEx-args port
|
|||
winsock-error-string [ throw ] when* ;
|
||||
|
||||
: make-accept-continuation ( AcceptEx -- )
|
||||
AcceptEx-args-port save-callback ;
|
||||
dup AcceptEx-args-lpOverlapped*
|
||||
swap AcceptEx-args-port save-callback ;
|
||||
|
||||
: check-accept-error ( AcceptEx -- )
|
||||
AcceptEx-args-port get-overlapped-result drop ;
|
||||
dup AcceptEx-args-lpOverlapped*
|
||||
swap AcceptEx-args-port get-overlapped-result drop ;
|
||||
|
||||
: extract-remote-host ( AcceptEx -- addrspec )
|
||||
[
|
||||
|
|
@ -184,21 +180,18 @@ TUPLE: WSARecvFrom-args port
|
|||
1 over set-WSARecvFrom-args-dwBufferCount*
|
||||
0 malloc-int dup free-always over set-WSARecvFrom-args-lpFlags*
|
||||
0 malloc-int dup free-always over set-WSARecvFrom-args-lpNumberOfBytesRecvd*
|
||||
(make-overlapped) [ over set-WSARecvFrom-args-lpOverlapped* ] keep
|
||||
swap WSARecvFrom-args-port set-port-overlapped ;
|
||||
(make-overlapped) swap set-WSARecvFrom-args-lpOverlapped* ;
|
||||
|
||||
: make-WSARecvFrom-continuation ( WSARecvFrom -- )
|
||||
WSARecvFrom-args-port save-callback ;
|
||||
: WSARecvFrom-continuation ( WSARecvFrom -- n )
|
||||
dup WSARecvFrom-args-lpOverlapped*
|
||||
swap WSARecvFrom-args-port [ save-callback ] 2keep
|
||||
get-overlapped-result ;
|
||||
|
||||
: call-WSARecvFrom ( WSARecvFrom -- )
|
||||
\ WSARecvFrom-args >tuple*<
|
||||
WSARecvFrom
|
||||
socket-error* ;
|
||||
|
||||
: WSARecvFrom-continuation ( WSARecvFrom -- n )
|
||||
[ make-WSARecvFrom-continuation ] keep
|
||||
WSARecvFrom-args-port get-overlapped-result ;
|
||||
|
||||
: parse-WSARecvFrom ( n WSARecvFrom -- packet addrspec )
|
||||
[
|
||||
WSARecvFrom-args-lpBuffers* WSABUF-buf
|
||||
|
|
@ -225,7 +218,7 @@ TUPLE: WSASendTo-args port
|
|||
: init-WSASendTo ( packet addrspec datagram WSASendTo -- )
|
||||
[ set-WSASendTo-args-port ] 2keep
|
||||
[
|
||||
>r delegate port-handle delegate win32-file-handle r>
|
||||
>r delegate port-handle win32-file-handle r>
|
||||
set-WSASendTo-args-s*
|
||||
] keep [
|
||||
>r make-sockaddr/size >r
|
||||
|
|
@ -242,15 +235,13 @@ TUPLE: WSASendTo-args port
|
|||
] keep
|
||||
1 over set-WSASendTo-args-dwBufferCount*
|
||||
0 over set-WSASendTo-args-dwFlags*
|
||||
(make-overlapped) [ over set-WSASendTo-args-lpOverlapped* ] keep
|
||||
swap WSASendTo-args-port set-port-overlapped ;
|
||||
|
||||
: make-WSASendTo-continuation ( WSASendTo -- )
|
||||
WSASendTo-args-port save-callback ;
|
||||
(make-overlapped) swap set-WSASendTo-args-lpOverlapped* ;
|
||||
|
||||
: WSASendTo-continuation ( WSASendTo -- )
|
||||
[ make-WSASendTo-continuation ] keep
|
||||
WSASendTo-args-port get-overlapped-result drop ;
|
||||
dup WSASendTo-args-lpOverlapped*
|
||||
swap WSASendTo-args-port
|
||||
[ save-callback ] 2keep
|
||||
get-overlapped-result drop ;
|
||||
|
||||
: call-WSASendTo ( WSASendTo -- )
|
||||
\ WSASendTo-args >tuple*<
|
||||
|
|
|
|||
|
|
@ -15,10 +15,9 @@ M: windows-io destruct-handle CloseHandle drop ;
|
|||
|
||||
M: windows-io destruct-socket closesocket drop ;
|
||||
|
||||
TUPLE: win32-file handle ptr overlapped ;
|
||||
TUPLE: win32-file handle ptr ;
|
||||
|
||||
: <win32-file> ( handle ptr -- obj )
|
||||
f win32-file construct-boa ;
|
||||
C: <win32-file> win32-file
|
||||
|
||||
: <win32-duplex-stream> ( in out -- stream )
|
||||
>r f <win32-file> r> f <win32-file> handle>duplex-stream ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue