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

   1 USING: alien alien.c-types arrays assocs combinators
   2 continuations destructors io io.backend io.ports io.timeouts
   3 io.backend.windows io.files.windows io.files.windows.nt io.files
   4 io.pathnames io.buffers io.streams.c libc kernel math namespaces
   5 sequences threads windows windows.errors windows.kernel32
   6 strings splitting ascii system accessors locals ;
   7 QUALIFIED: windows.winsock
   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-object &free ;
  19
  20 : make-overlapped ( port -- overlapped-ext )
  21     [ (make-overlapped) ] dip
  22     handle>> ptr>> [ over set-OVERLAPPED-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 = ] bi or ;
  40
  41 : twiddle-thumbs ( overlapped port -- bytes-transferred )
  42     [
  43         drop
  44         [ pending-overlapped get-global set-at ] curry "I/O" suspend
  45         {
  46             { [ dup integer? ] [ ] }
  47             { [ dup array? ] [
  48                 first dup eof?
  49                 [ drop 0 ] [ (win32-error-string) throw ] if
  50             ] }
  51         } cond
  52     ] with-timeout ;
  53
  54 :: wait-for-overlapped ( us -- bytes-transferred overlapped error? )
  55     master-completion-port get-global
  56     0 <int> [ ! bytes
  57         f <void*> ! key
  58         f <void*> [ ! overlapped
  59             us [ 1000 /i ] [ INFINITE ] if* ! timeout
  60             GetQueuedCompletionStatus zero?
  61         ] keep *void*
  62     ] keep *int spin ;
  63
  64 : resume-callback ( result overlapped -- )
  65     pending-overlapped get-global delete-at* drop resume-with ;
  66
  67 : handle-overlapped ( us -- ? )
  68     wait-for-overlapped [
  69         dup [
  70             [ drop GetLastError 1array ] dip resume-callback t
  71         ] [ 2drop f ] if
  72     ] [ resume-callback t ] if ;
  73
  74 M: win32-handle cancel-operation
  75     [ check-disposed ] [ handle>> CancelIo drop ] bi ;
  76
  77 M: winnt io-multiplex ( us -- )
  78     handle-overlapped [ 0 io-multiplex ] when ;
  79
  80 M: winnt init-io ( -- )
  81     <master-completion-port> master-completion-port set-global
  82     H{ } clone pending-overlapped set-global
  83     windows.winsock:init-winsock ;
  84
  85 : file-error? ( n -- eof? )
  86     zero? [
  87         GetLastError {
  88             { [ dup expected-io-error? ] [ drop f ] }
  89             { [ dup eof? ] [ drop t ] }
  90             [ (win32-error-string) throw ]
  91         } cond
  92     ] [ f ] if ;
  93
  94 : wait-for-file ( FileArgs n port -- n )
  95     swap file-error?
  96     [ 2drop 0 ] [ [ lpOverlapped>> ] dip twiddle-thumbs ] if ;
  97
  98 : update-file-ptr ( n port -- )
  99     handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ;
 100
 101 : finish-write ( n port -- )
 102     [ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ;
 103
 104 M: winnt (wait-to-write)
 105     [
 106         [ make-FileArgs dup setup-write WriteFile ]
 107         [ wait-for-file ]
 108         [ finish-write ]
 109         tri
 110     ] with-destructors ;
 111
 112 : finish-read ( n port -- )
 113     [ update-file-ptr ] [ buffer>> n>buffer ] 2bi ;
 114
 115 M: winnt (wait-to-read) ( port -- )
 116     [
 117         [ make-FileArgs dup setup-read ReadFile ]
 118         [ wait-for-file ]
 119         [ finish-read ]
 120         tri
 121     ] with-destructors ;
 122
 123 M: winnt (init-stdio) init-c-stdio ;
 124
 125 winnt set-io-backend