1 USING: alien alien.c-types alien.data alien.syntax arrays assocs
2 combinators continuations destructors io io.backend io.ports
3 io.timeouts io.backend.windows io.files.windows
4 io.files.windows.nt io.files io.pathnames io.buffers
5 io.streams.c io.streams.null libc kernel math namespaces
6 sequences threads windows windows.errors windows.kernel32
7 strings splitting ascii system accessors locals classes.struct
8 combinators.short-circuit ;
9 IN: io.backend.windows.nt
11 ! Global variable with assoc mapping overlapped to threads
12 SYMBOL: pending-overlapped
14 TUPLE: io-callback port thread ;
16 C: <io-callback> io-callback
18 : (make-overlapped) ( -- overlapped-ext )
19 OVERLAPPED malloc-struct &free ;
21 : make-overlapped ( port -- overlapped-ext )
22 [ (make-overlapped) ] dip
23 handle>> ptr>> [ >>offset ] when* ;
25 M: winnt FileArgs-overlapped ( port -- overlapped )
28 : <completion-port> ( handle existing -- handle )
29 f 1 CreateIoCompletionPort dup win32-error=0/f ;
31 SYMBOL: master-completion-port
33 : <master-completion-port> ( -- handle )
34 INVALID_HANDLE_VALUE f <completion-port> ;
36 M: winnt add-completion ( win32-handle -- )
37 handle>> master-completion-port get-global <completion-port> drop ;
40 { [ ERROR_HANDLE_EOF = ] [ ERROR_BROKEN_PIPE = ] } 1|| ;
42 : twiddle-thumbs ( overlapped port -- bytes-transferred )
45 [ self ] dip >c-ptr pending-overlapped get-global set-at
47 { [ dup integer? ] [ ] }
50 [ drop 0 ] [ n>win32-error-string throw ] if
55 :: wait-for-overlapped ( nanos -- bytes-transferred overlapped error? )
56 nanos [ 1,000,000 /i ] [ INFINITE ] if* :> timeout
57 master-completion-port get-global
58 { int void* pointer: OVERLAPPED }
59 [ timeout GetQueuedCompletionStatus zero? ] with-out-parameters
60 :> ( error? bytes key overlapped )
61 bytes overlapped error? ;
63 : resume-callback ( result overlapped -- )
64 >c-ptr pending-overlapped get-global delete-at* drop resume-with ;
66 : handle-overlapped ( nanos -- ? )
69 [ drop GetLastError 1array ] dip resume-callback t
71 ] [ resume-callback t ] if ;
73 M: win32-handle cancel-operation
74 [ handle>> CancelIo win32-error=0/f ] unless-disposed ;
76 M: winnt io-multiplex ( nanos -- )
77 handle-overlapped [ 0 io-multiplex ] when ;
79 M: winnt init-io ( -- )
80 <master-completion-port> master-completion-port set-global
81 H{ } clone pending-overlapped set-global ;
83 ERROR: invalid-file-size n ;
85 : handle>file-size ( handle -- n )
86 0 <ulonglong> [ GetFileSizeEx win32-error=0/f ] keep *ulonglong ;
88 ERROR: seek-before-start n ;
90 : set-seek-ptr ( n handle -- )
91 [ dup 0 < [ seek-before-start ] when ] dip ptr<< ;
93 M: winnt tell-handle ( handle -- n ) ptr>> ;
95 M: winnt seek-handle ( n seek-type handle -- )
97 { seek-absolute [ set-seek-ptr ] }
98 { seek-relative [ [ ptr>> + ] keep set-seek-ptr ] }
99 { seek-end [ [ handle>> handle>file-size + ] keep set-seek-ptr ] }
103 : file-error? ( n -- eof? )
106 { [ dup expected-io-error? ] [ drop f ] }
107 { [ dup eof? ] [ drop t ] }
108 [ n>win32-error-string throw ]
112 : wait-for-file ( FileArgs n port -- n )
114 [ 2drop 0 ] [ [ lpOverlapped>> ] dip twiddle-thumbs ] if ;
116 : update-file-ptr ( n port -- )
117 handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ;
119 : finish-write ( n port -- )
120 [ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ;
122 M: winnt (wait-to-write)
124 [ make-FileArgs dup setup-write WriteFile ]
130 : finish-read ( n port -- )
131 [ update-file-ptr ] [ buffer>> n>buffer ] 2bi ;
133 M: winnt (wait-to-read) ( port -- )
135 [ make-FileArgs dup setup-read ReadFile ]
141 : console-app? ( -- ? ) GetConsoleWindow >boolean ;
146 [ null-reader null-writer null-writer set-stdio ] if ;