basis/io/backend/windows/nt/nt.factor

   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
   8
   9 ! Global variable with assoc mapping overlapped to threads
  10 SYMBOL: pending-overlapped
  11
  12 TUPLE: io-callback port thread ;
  13
  14 C: <io-callback> io-callback
  15
  16 : (make-overlapped) ( -- overlapped-ext )
  17     OVERLAPPED malloc-struct &free ;
  18
  19 : make-overlapped ( port -- overlapped-ext )
  20     [ (make-overlapped) ] dip
  21     handle>> ptr>> [ >>offset ] when* ;
  22
  23 M: winnt FileArgs-overlapped ( port -- overlapped )
  24     make-overlapped ;
  25
  26 : <completion-port> ( handle existing -- handle )
  27      f 1 CreateIoCompletionPort dup win32-error=0/f ;
  28
  29 SYMBOL: master-completion-port
  30
  31 : <master-completion-port> ( -- handle )
  32     INVALID_HANDLE_VALUE f <completion-port> ;
  33
  34 M: winnt add-completion ( win32-handle -- )
  35     handle>> master-completion-port get-global <completion-port> drop ;
  36
  37 : eof? ( error -- ? )
  38     { [ ERROR_HANDLE_EOF = ] [ ERROR_BROKEN_PIPE = ] } 1|| ;
  39
  40 : twiddle-thumbs ( overlapped port -- bytes-transferred )
  41     [
  42         drop
  43         [ self ] dip >c-ptr pending-overlapped get-global set-at
  44         "I/O" suspend {
  45             { [ dup integer? ] [ ] }
  46             { [ dup array? ] [
  47                 first dup eof?
  48                 [ drop 0 ] [ n>win32-error-string throw ] if
  49             ] }
  50         } cond
  51     ] with-timeout ;
  52
  53 :: wait-for-overlapped ( nanos -- bytes-transferred overlapped error? )
  54     master-completion-port get-global
  55     0 <int> :> bytes
  56     f <void*> :> key
  57     f <void*> :> overlapped
  58     nanos [ 1,000,000 /i ] [ INFINITE ] if* :> timeout
  59     bytes key overlapped timeout GetQueuedCompletionStatus zero? :> error?
  60
  61     bytes *int
  62     overlapped *void* dup [ OVERLAPPED memory>struct ] when
  63     error? ;
  64
  65 : resume-callback ( result overlapped -- )
  66     >c-ptr pending-overlapped get-global delete-at* drop resume-with ;
  67
  68 : handle-overlapped ( nanos -- ? )
  69     wait-for-overlapped [
  70         [
  71             [ drop GetLastError 1array ] dip resume-callback t
  72         ] [ drop f ] if*
  73     ] [ resume-callback t ] if ;
  74
  75 M: win32-handle cancel-operation
  76     [ check-disposed ] [ handle>> CancelIo drop ] bi ;
  77
  78 M: winnt io-multiplex ( nanos -- )
  79     handle-overlapped [ 0 io-multiplex ] when ;
  80
  81 M: winnt init-io ( -- )
  82     <master-completion-port> master-completion-port set-global
  83     H{ } clone pending-overlapped set-global ;
  84
  85 ERROR: invalid-file-size n ;
  86
  87 : handle>file-size ( handle -- n )
  88     0 <ulonglong> [ GetFileSizeEx win32-error=0/f ] keep *ulonglong ;
  89
  90 ERROR: seek-before-start n ;
  91
  92 : set-seek-ptr ( n handle -- )
  93     [ dup 0 < [ seek-before-start ] when ] dip ptr<< ;
  94
  95 M: winnt tell-handle ( handle -- n ) ptr>> ;
  96
  97 M: winnt seek-handle ( n seek-type handle -- )
  98     swap {
  99         { seek-absolute [ set-seek-ptr ] }
 100         { seek-relative [ [ ptr>> + ] keep set-seek-ptr ] }
 101         { seek-end [ [ handle>> handle>file-size + ] keep set-seek-ptr ] }
 102         [ bad-seek-type ]
 103     } case ;
 104
 105 : file-error? ( n -- eof? )
 106     zero? [
 107         GetLastError {
 108             { [ dup expected-io-error? ] [ drop f ] }
 109             { [ dup eof? ] [ drop t ] }
 110             [ n>win32-error-string throw ]
 111         } cond
 112     ] [ f ] if ;
 113
 114 : wait-for-file ( FileArgs n port -- n )
 115     swap file-error?
 116     [ 2drop 0 ] [ [ lpOverlapped>> ] dip twiddle-thumbs ] if ;
 117
 118 : update-file-ptr ( n port -- )
 119     handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ;
 120
 121 : finish-write ( n port -- )
 122     [ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ;
 123
 124 M: winnt (wait-to-write)
 125     [
 126         [ make-FileArgs dup setup-write WriteFile ]
 127         [ wait-for-file ]
 128         [ finish-write ]
 129         tri
 130     ] with-destructors ;
 131
 132 : finish-read ( n port -- )
 133     [ update-file-ptr ] [ buffer>> n>buffer ] 2bi ;
 134
 135 M: winnt (wait-to-read) ( port -- )
 136     [
 137         [ make-FileArgs dup setup-read ReadFile ]
 138         [ wait-for-file ]
 139         [ finish-read ]
 140         tri
 141     ] with-destructors ;
 142
 143 : console-app? ( -- ? ) GetConsoleWindow >boolean ;
 144
 145 M: winnt init-stdio
 146     console-app?
 147     [ init-c-stdio ]
 148     [ null-reader null-writer null-writer set-stdio ] if ;
 149
 150 winnt set-io-backend