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

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