diff options
| author | Tamar Christina <tamar@zhox.com> | 2019-11-17 21:21:51 +0000 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2020-07-15 16:41:02 -0400 |
| commit | ccf0d1073969e3b73fed82cd421d74800f552953 (patch) | |
| tree | 2efcd4acecce82fc2fdb566161d82e30d3e83caa /libraries/base | |
| parent | 84ea3d1492127442e2d416f1f576a5921186ada4 (diff) | |
| download | haskell-ccf0d1073969e3b73fed82cd421d74800f552953.tar.gz | |
winio: Fix issues with non-threaded I/O manager after split.
Diffstat (limited to 'libraries/base')
| -rw-r--r-- | libraries/base/GHC/Event/Windows.hsc | 25 | ||||
| -rw-r--r-- | libraries/base/GHC/IO/Windows/Handle.hsc | 2 |
2 files changed, 21 insertions, 6 deletions
diff --git a/libraries/base/GHC/Event/Windows.hsc b/libraries/base/GHC/Event/Windows.hsc index c923e4e922..5180835396 100644 --- a/libraries/base/GHC/Event/Windows.hsc +++ b/libraries/base/GHC/Event/Windows.hsc @@ -478,7 +478,7 @@ interruptSystemManager = do -- | The initial number of I/O requests we can service at the same time. -- Must be power of 2. This number is used as the starting point to scale --- the number of concurrent requests. It will be doubled everytime we are +-- the number of concurrent requests. It will be doubled every time we are -- saturated. callbackArraySize :: Int callbackArraySize = 32 @@ -728,10 +728,24 @@ withOverlappedEx mgr fname h offset startCB completionCB = do return $ CbDone res | otherwise -> do m <- newEmptyIOPort - let secs = 100 / 1000000.0 - reg <- registerTimeout mgr secs $ - writeIOPort m () >> return () - readIOPort m `onException` unregisterTimeout mgr reg + -- 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 + -- of sockets which make take slightly longer. However for + -- the non-threaded RTS, using the timer manage is a waste + -- since there's only one capability anyway. + -- There's a trade-off. Using the timer would allow it do + -- to continue running other Haskell threads, but also + -- means it may take longer to complete the wait. For now + -- I'll not use it and enter a busy wait and see if there + -- are any complaints. + -- OTOH any of the two should be a massive improvement over + -- The old I/O Manager. + when threaded $ do + let secs = 100 / 1000000.0 + reg <- registerTimeout mgr secs $ + writeIOPort m () >> return () + readIOPort m `onException` unregisterTimeout mgr reg spinWaitComplete fhndl lpol _ -> do when (not threaded) completeSynchronousRequest @@ -786,6 +800,7 @@ registerTimeout mgr@Manager{..} relTime cb = do now <- getTime mgrClock let !expTime = secondsToNanoSeconds $ now + relTime editTimeouts mgr (Q.unsafeInsertNew key expTime cb) + wakeupIOManager return $ TK key -- | Update an active timeout to fire in the given number of seconds (from the diff --git a/libraries/base/GHC/IO/Windows/Handle.hsc b/libraries/base/GHC/IO/Windows/Handle.hsc index f0a000e626..a970743b68 100644 --- a/libraries/base/GHC/IO/Windows/Handle.hsc +++ b/libraries/base/GHC/IO/Windows/Handle.hsc @@ -632,7 +632,7 @@ consoleRead hwnd ptr _offset bytes if eventType == #{const KEY_EVENT} && btnDown then do debugIO $ "cobble: read-char." char <- peekByteOff p_inputs char_offset - let w_ptr' = w_ptr `plusPtr` 1 + let w_ptr' = w_ptr `plusPtr` 1 debugIO $ "cobble: offset - " ++ show char_offset debugIO $ "cobble: show > " ++ show char debugIO $ "cobble: repeat: " ++ show repeated |