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