1 USING: alien alien.c-types arrays assocs combinators continuations
2 destructors io io.backend io.ports io.timeouts io.backend.windows
3 io.files.windows io.files.windows.nt io.files io.pathnames io.buffers
4 io.streams.c io.streams.null libc kernel math namespaces sequences
5 threads windows windows.errors windows.kernel32 strings splitting
6 ascii system accessors locals classes.struct combinators.short-circuit ;
7 IN: io.backend.windows.nt
9 ! Global variable with assoc mapping overlapped to threads
10 SYMBOL: pending-overlapped
12 TUPLE: io-callback port thread ;
14 C: <io-callback> io-callback
16 : (make-overlapped) ( -- overlapped-ext )
17 OVERLAPPED malloc-struct &free ;
19 : make-overlapped ( port -- overlapped-ext )
20 [ (make-overlapped) ] dip
21 handle>> ptr>> [ >>offset ] when* ;
23 M: winnt FileArgs-overlapped ( port -- overlapped )
26 : <completion-port> ( handle existing -- handle )
27 f 1 CreateIoCompletionPort dup win32-error=0/f ;
29 SYMBOL: master-completion-port
31 : <master-completion-port> ( -- handle )
32 INVALID_HANDLE_VALUE f <completion-port> ;
34 M: winnt add-completion ( win32-handle -- )
35 handle>> master-completion-port get-global <completion-port> drop ;
38 { [ ERROR_HANDLE_EOF = ] [ ERROR_BROKEN_PIPE = ] } 1|| ;
40 : twiddle-thumbs ( overlapped port -- bytes-transferred )
43 [ self ] dip >c-ptr pending-overlapped get-global set-at
45 { [ dup integer? ] [ ] }
48 [ drop 0 ] [ n>win32-error-string throw ] if
53 :: wait-for-overlapped ( nanos -- bytes-transferred overlapped error? )
54 nanos [ 1,000,000 /i ] [ INFINITE ] if* :> timeout
55 master-completion-port get-global
56 { int void* pointer: OVERLAPPED }
57 [ timeout GetQueuedCompletionStatus zero? ] [ ] with-out-parameters
58 :> ( error? bytes key overlapped )
59 bytes overlapped error? ;
61 : resume-callback ( result overlapped -- )
62 >c-ptr pending-overlapped get-global delete-at* drop resume-with ;
64 : handle-overlapped ( nanos -- ? )
67 [ drop GetLastError 1array ] dip resume-callback t
69 ] [ resume-callback t ] if ;
71 M: win32-handle cancel-operation
72 [ check-disposed ] [ handle>> CancelIo drop ] bi ;
74 M: winnt io-multiplex ( nanos -- )
75 handle-overlapped [ 0 io-multiplex ] when ;
77 M: winnt init-io ( -- )
78 <master-completion-port> master-completion-port set-global
79 H{ } clone pending-overlapped set-global ;
81 ERROR: invalid-file-size n ;
83 : handle>file-size ( handle -- n )
84 0 <ulonglong> [ GetFileSizeEx win32-error=0/f ] keep *ulonglong ;
86 ERROR: seek-before-start n ;
88 : set-seek-ptr ( n handle -- )
89 [ dup 0 < [ seek-before-start ] when ] dip ptr<< ;
91 M: winnt tell-handle ( handle -- n ) ptr>> ;
93 M: winnt seek-handle ( n seek-type handle -- )
95 { seek-absolute [ set-seek-ptr ] }
96 { seek-relative [ [ ptr>> + ] keep set-seek-ptr ] }
97 { seek-end [ [ handle>> handle>file-size + ] keep set-seek-ptr ] }
101 : file-error? ( n -- eof? )
104 { [ dup expected-io-error? ] [ drop f ] }
105 { [ dup eof? ] [ drop t ] }
106 [ n>win32-error-string throw ]
110 : wait-for-file ( FileArgs n port -- n )
112 [ 2drop 0 ] [ [ lpOverlapped>> ] dip twiddle-thumbs ] if ;
114 : update-file-ptr ( n port -- )
115 handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ;
117 : finish-write ( n port -- )
118 [ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ;
120 M: winnt (wait-to-write)
122 [ make-FileArgs dup setup-write WriteFile ]
128 : finish-read ( n port -- )
129 [ update-file-ptr ] [ buffer>> n>buffer ] 2bi ;
131 M: winnt (wait-to-read) ( port -- )
133 [ make-FileArgs dup setup-read ReadFile ]
139 : console-app? ( -- ? ) GetConsoleWindow >boolean ;
144 [ null-reader null-writer null-writer set-stdio ] if ;