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

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