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

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