winio: update temp path so GCC etc can handle it.

Also fix PIPE support, clean up error casting, fix memory leaks

3 files changed, 60 insertions, 32 deletions

diff --git a/libraries/base/GHC/Event/Windows.hsc b/libraries/base/GHC/Event/Windows.hsc
index 57aef2461d..823d237900 100644
--- a/libraries/base/GHC/Event/Windows.hsc
+++ b/libraries/base/GHC/Event/Windows.hsc
@@ -563,16 +563,17 @@ withOverlappedEx mgr fname h offset startCB completionCB = do
           -- non-overlapping handle or was completed immediately.
           -- e.g. stdio redirection or data in cache, FAST I/O.
           success <- FFI.overlappedIOStatus lpol
-          err     <- fmap fromIntegral getLastError
+          err     <- getLastError
           -- Determine if the caller has done any checking.  If not then check
           -- to see if the request was completed synchronously.  We have to
           -- in order to prevent deadlocks since if it has completed
           -- synchronously we've requested to not have the completion queued.
           let result' =
                 case result of
-                  CbNone ret | success == #{const STATUS_SUCCESS}          -> CbDone Nothing
+                  CbNone ret -- Start by checking some flags which indicates we
+                             -- are done.
+                             | success == #{const STATUS_SUCCESS}          -> CbDone Nothing
                              | success == #{const STATUS_END_OF_FILE}      -> CbDone Nothing
-                             | success == #{const STATUS_PENDING}          -> CbPending
                              -- Buffer was too small.. not sure what to do, so I'll just
                              -- complete the read request
                              | err     == #{const ERROR_MORE_DATA}         -> CbDone Nothing
@@ -581,8 +582,17 @@ withOverlappedEx mgr fname h offset startCB completionCB = do
                              | err     == #{const ERROR_IO_INCOMPLETE}     -> CbIncomplete
                              | err     == #{const ERROR_HANDLE_EOF}        -> CbDone Nothing
                              | err     == #{const ERROR_BROKEN_PIPE}       -> CbDone Nothing
+                             | err     == #{const ERROR_NO_MORE_ITEMS}     -> CbDone Nothing
                              | err     == #{const ERROR_OPERATION_ABORTED} -> CbDone Nothing
-                             | not ret                                     -> CbError err
+                             -- This is currently mapping all non-complete requests we don't know
+                             -- about as an error. I wonder if this isn't too strict..
+                             | not ret                                     -> CbError $ fromIntegral err
+                             -- We check success codes after checking error as
+                             -- errors are much more indicative
+                             | success == #{const STATUS_PENDING}          -> CbPending
+                             -- If not just assume we can complete.  If we can't this will
+                             -- hang because we don't know how to properly deal with it.
+                             -- I don't know what the best default here is...
                              | otherwise                                   -> CbPending
                   _                                                        -> result
           case result' of
@@ -602,7 +612,7 @@ withOverlappedEx mgr fname h offset startCB completionCB = do
               debugIO $ "== " ++ show (finished)
               status <- FFI.overlappedIOStatus lpol
               debugIO $ "== >< " ++ show (status)
-              lasterr <- fmap fromIntegral getLastError :: IO Int
+              lasterr <- getLastError
               -- This status indicated that we have finished early and so we
               -- won't have a request enqueued.  Handle it inline.
               let done_early = status == #{const STATUS_SUCCESS}
@@ -610,6 +620,7 @@ withOverlappedEx mgr fname h offset startCB completionCB = do
                                || lasterr == #{const ERROR_HANDLE_EOF}
                                || lasterr == #{const ERROR_SUCCESS}
                                || lasterr == #{const ERROR_BROKEN_PIPE}
+                               || lasterr == #{const ERROR_NO_MORE_ITEMS}
                                || lasterr == #{const ERROR_OPERATION_ABORTED}
               -- This status indicates that the request hasn't finished early,
               -- but it will finish shortly.  The I/O manager will not be
@@ -681,7 +692,7 @@ withOverlappedEx mgr fname h offset startCB completionCB = do
         case execute of
           CbPending    -> runner
           CbDone rdata -> do
-            -- free cdData
+            free cdData
             debugIO $ dbg $ ":: done " ++ show lpol ++ " - " ++ show rdata
             bytes <- if isJust rdata
                         then return rdata
@@ -689,13 +700,13 @@ withOverlappedEx mgr fname h offset startCB completionCB = do
                         else FFI.getOverlappedResult h lpol False
             debugIO $ dbg $ ":: done bytes: " ++ show bytes
             case bytes of
-              Just res ->  completionCB 0 res -- free hs_lpol >> completionCB 0 res
+              Just res ->  free hs_lpol >> completionCB 0 res
               Nothing  -> do err <- FFI.overlappedIOStatus lpol
                              numBytes <- FFI.overlappedIONumBytes lpol
                              -- TODO: Remap between STATUS_ and ERROR_ instead
                              -- of re-interpret here. But for now, don't care.
                              let err' = fromIntegral err
-                             -- free hs_lpol
+                             free hs_lpol
                              debugIO $ dbg $ ":: done callback: " ++ show err' ++ " - " ++ show numBytes
                              completionCB err' (fromIntegral numBytes)
           CbError err  -> do
@@ -721,13 +732,14 @@ withOverlappedEx mgr fname h offset startCB completionCB = do
                   return $ CbDone res
                         | otherwise ->
                   do m <- newEmptyIOPort
-                     lasterr <- fmap fromIntegral getLastError :: IO Int
+                     lasterr <- getLastError
                      let done =
                             lasterr == #{const ERROR_HANDLE_EOF}
                             || lasterr == #{const ERROR_SUCCESS}
                             || lasterr == #{const ERROR_BROKEN_PIPE}
+                            || lasterr == #{const ERROR_NO_MORE_ITEMS}
                             || lasterr == #{const ERROR_OPERATION_ABORTED}
-                     debugIO $ ":: loop - " ++ show lasterr ++ " :" ++ show done
+                     -- debugIO $ ":: loop - " ++ show lasterr ++ " :" ++ show done
                      -- We will complete quite soon, in the threaded RTS we
                      -- probably don't really want to wait for it while we could
                      -- have done something else.  In particular this is because
@@ -741,13 +753,18 @@ withOverlappedEx mgr fname h offset startCB completionCB = do
                      -- are any complaints.
                      -- OTOH any of the two should be a massive improvement over
                      -- The old I/O Manager.
-                     when threadedIOMgr $ do
-                       let usecs = 100 -- 0.1ms
-                       reg <- registerTimeout mgr usecs $
-                                writeIOPort m () >> return ()
-                       readIOPort m `onException` unregisterTimeout mgr reg
+                     case (done, threadedIOMgr) of
+                       (False, True) -> do
+                         let usecs = 250 -- 0.25ms
+                         reg <- registerTimeout mgr usecs $
+                                  writeIOPort m () >> return ()
+                         readIOPort m `onException` unregisterTimeout mgr reg
+                       (False, False) -> sleepBlock 250
+                       _              -> return ()
                      if done
-                        then return $ CbDone Nothing
+                        then do when (not threadedIOMgr)
+                                  completeSynchronousRequest
+                                return $ CbDone Nothing
                         else spinWaitComplete fhndl lpol
                 Just _ -> do
                    when (not threadedIOMgr) completeSynchronousRequest
@@ -1159,6 +1176,7 @@ foreign import ccall unsafe "sendIOManagerEvent" -- in the RTS (ThrIOManager.c)
 
 foreign import ccall unsafe "rtsSupportsBoundThreads" threadedIOMgr :: Bool
 
+foreign import stdcall unsafe "Sleep" sleepBlock :: Int -> IO ()
 
 -- ---------------------------------------------------------------------------
 -- I/O manager event notifications
diff --git a/libraries/base/GHC/IO/Windows/Handle.hsc b/libraries/base/GHC/IO/Windows/Handle.hsc
index 9fc8d9af6d..3ed119858c 100644
--- a/libraries/base/GHC/IO/Windows/Handle.hsc
+++ b/libraries/base/GHC/IO/Windows/Handle.hsc
@@ -432,13 +432,14 @@ hwndRead hwnd ptr offset bytes
       return $ Mgr.CbNone ret
 
     completionCB err dwBytes
-      | err == #{const ERROR_SUCCESS}      = Mgr.ioSuccess $ fromIntegral dwBytes
-      | err == #{const ERROR_HANDLE_EOF}   = Mgr.ioSuccess 0
-      | err == #{const STATUS_END_OF_FILE} = Mgr.ioSuccess 0
-      | err == #{const ERROR_BROKEN_PIPE}  = Mgr.ioSuccess 0
-      | err == #{const STATUS_PIPE_BROKEN} = Mgr.ioSuccess 0
-      | err == #{const ERROR_MORE_DATA}    = Mgr.ioSuccess $ fromIntegral dwBytes
-      | otherwise                          = Mgr.ioFailed err
+      | err == #{const ERROR_SUCCESS}       = Mgr.ioSuccess $ fromIntegral dwBytes
+      | err == #{const ERROR_HANDLE_EOF}    = Mgr.ioSuccess 0
+      | err == #{const STATUS_END_OF_FILE}  = Mgr.ioSuccess 0
+      | err == #{const ERROR_BROKEN_PIPE}   = Mgr.ioSuccess 0
+      | err == #{const STATUS_PIPE_BROKEN}  = Mgr.ioSuccess 0
+      | err == #{const ERROR_NO_MORE_ITEMS} = Mgr.ioSuccess 0
+      | err == #{const ERROR_MORE_DATA}     = Mgr.ioSuccess $ fromIntegral dwBytes
+      | otherwise                           = Mgr.ioFailed err
 
 -- In WinIO we'll never block in the FFI call, so this call is equivalent to
 -- hwndRead,  Though we may revisit this when implementing sockets and pipes.
@@ -459,12 +460,14 @@ hwndReadNonBlocking hwnd ptr offset bytes
       return $ Mgr.CbNone ret
 
     completionCB err dwBytes
-      | err == #{const ERROR_SUCCESS}      = Mgr.ioSuccess $ fromIntegral dwBytes
-      | err == #{const ERROR_HANDLE_EOF}   = Mgr.ioSuccess 0
-      | err == #{const STATUS_END_OF_FILE} = Mgr.ioSuccess 0
-      | err == #{const ERROR_BROKEN_PIPE}  = Mgr.ioSuccess 0
-      | err == #{const STATUS_PIPE_BROKEN} = Mgr.ioSuccess 0
-      | otherwise                          = Mgr.ioFailed err
+      | err == #{const ERROR_SUCCESS}       = Mgr.ioSuccess $ fromIntegral dwBytes
+      | err == #{const ERROR_HANDLE_EOF}    = Mgr.ioSuccess 0
+      | err == #{const STATUS_END_OF_FILE}  = Mgr.ioSuccess 0
+      | err == #{const ERROR_BROKEN_PIPE}   = Mgr.ioSuccess 0
+      | err == #{const STATUS_PIPE_BROKEN}  = Mgr.ioSuccess 0
+      | err == #{const ERROR_NO_MORE_ITEMS} = Mgr.ioSuccess 0
+      | err == #{const ERROR_MORE_DATA}     = Mgr.ioSuccess $ fromIntegral dwBytes
+      | otherwise                           = Mgr.ioFailed err
 
 hwndWrite :: Io NativeHandle -> Ptr Word8 -> Word64 -> Int -> IO ()
 hwndWrite hwnd ptr offset bytes
diff --git a/libraries/base/cbits/Win32Utils.c b/libraries/base/cbits/Win32Utils.c
index 345e46811b..e886cceb9f 100644
--- a/libraries/base/cbits/Win32Utils.c
+++ b/libraries/base/cbits/Win32Utils.c
@@ -183,15 +183,22 @@ bool __createUUIDTempFileErrNo (wchar_t* pathName, wchar_t* prefix,
       if (UuidToStringW ((UUID*)&guid, &guidStr) != S_OK)
         goto fail;
 
-      wchar_t* devName = FS(create_device_name) ((wchar_t*)pathName);
+      /* We can't create a device path here since this path escapes the compiler
+         so instead return a normal path and have openFile deal with it.  */
+      wchar_t* devName = malloc (sizeof (wchar_t) * wcslen (pathName));
+      wcscpy (devName, pathName);
       int len = wcslen (devName) + wcslen (suffix) + wcslen (prefix)
               + wcslen (guidStr) + 3;
       *tempFileName = malloc (len * sizeof (wchar_t));
       if (*tempFileName == NULL)
         goto fail;
 
-      if (-1 == swprintf_s (*tempFileName, len, L"%ls\\%ls-%ls%ls",
-                            devName, prefix, guidStr, suffix))
+      /* Only add a slash if path didn't already end in one, otherwise we create
+         an invalid path.  */
+      bool slashed = devName[wcslen(devName)-1] == '\\';
+      wchar_t* sep = slashed ? L"" : L"\\";
+      if (-1 == swprintf_s (*tempFileName, len, L"%ls%ls%ls-%ls%ls",
+                            devName, sep, prefix, guidStr, suffix))
         goto fail;
 
       free (devName);