From 382ca27d7b1e33640b9dab670bfbf3f32bb3f4cf Mon Sep 17 00:00:00 2001
From: simonmar <unknown>
Date: Tue, 18 Jan 2000 12:44:37 +0000
Subject: [PATCH] [project @ 2000-01-18 12:44:37 by simonmar] Don't hold the
lock on the Handle while we block waiting for data on a read. This is a
partial solution to the general problem of holding a lock on the Handle while
in mayBlock.
---
ghc/lib/std/IO.lhs | 22 +++++-----------
ghc/lib/std/PrelHandle.lhs | 54 ++++++++++++++++++++++++++------------
2 files changed, 44 insertions(+), 32 deletions(-)
diff --git a/ghc/lib/std/IO.lhs b/ghc/lib/std/IO.lhs
index 1a8d4b338ca9..0ca21801ead9 100644
--- a/ghc/lib/std/IO.lhs
+++ b/ghc/lib/std/IO.lhs
@@ -110,6 +110,7 @@ import PrelAddr ( Addr(..), nullAddr )
import PrelByteArr ( ByteArray )
import PrelPack ( unpackNBytesAccST )
import PrelException ( ioError, catch )
+import PrelConc
#ifndef __PARALLEL_HASKELL__
import PrelForeign ( ForeignObj )
@@ -157,13 +158,9 @@ blocking until a character is available.
\begin{code}
hGetChar :: Handle -> IO Char
-hGetChar handle =
- wantReadableHandle "hGetChar" handle $ \ handle_ -> do
- let fo = haFO__ handle_
- intc <- mayBlock fo (fileGetc fo) -- ConcHask: UNSAFE, may block
- if intc /= ((-1)::Int)
- then return (chr intc)
- else constructErrorAndFail "hGetChar"
+hGetChar handle = do
+ c <- mayBlockRead "hGetChar" handle fileGetc
+ return (chr c)
{-
If EOF is reached before EOL is encountered, ignore the
@@ -202,14 +199,9 @@ character is available.
\begin{code}
hLookAhead :: Handle -> IO Char
-hLookAhead handle =
- wantReadableHandle "hLookAhead" handle $ \ handle_ -> do
- let fo = haFO__ handle_
- intc <- mayBlock fo (fileLookAhead fo) -- ConcHask: UNSAFE, may block
- if intc /= (-1)
- then return (chr intc)
- else constructErrorAndFail "hLookAhead"
-
+hLookAhead handle = do
+ rc <- mayBlockRead "hLookAhead" handle fileLookAhead
+ return (chr rc)
\end{code}
diff --git a/ghc/lib/std/PrelHandle.lhs b/ghc/lib/std/PrelHandle.lhs
index d65c234e858b..a1faf9932c50 100644
--- a/ghc/lib/std/PrelHandle.lhs
+++ b/ghc/lib/std/PrelHandle.lhs
@@ -437,10 +437,8 @@ the file. Otherwise, it returns @False@.
\begin{code}
hIsEOF :: Handle -> IO Bool
-hIsEOF handle =
- wantReadableHandle "hIsEOF" handle $ \ handle_ -> do
- let fo = haFO__ handle_
- rc <- mayBlock fo (fileEOF fo) -- ConcHask: UNSAFE, may block
+hIsEOF handle = do
+ rc <- mayBlockRead "hIsEOF" handle fileEOF
case rc of
0 -> return False
1 -> return True
@@ -905,12 +903,7 @@ hFillBufBA handle buf sz
"hFillBufBA"
("illegal buffer size " ++ showsPrec 9 sz [])) -- 9 => should be parens'ified.
| otherwise =
- wantReadableHandle "hFillBufBA" handle $ \ handle_ -> do
- let fo = haFO__ handle_
- rc <- mayBlock fo (readChunkBA fo buf sz) -- ConcHask: UNSAFE, may block.
- if rc >= (0::Int)
- then return rc
- else constructErrorAndFail "hFillBufBA"
+ mayBlockRead "hFillBufBA" handle (\fo -> readChunkBA fo buf sz)
#endif
hFillBuf :: Handle -> Addr -> Int -> IO Int
@@ -920,13 +913,7 @@ hFillBuf handle buf sz
"hFillBuf"
("illegal buffer size " ++ showsPrec 9 sz [])) -- 9 => should be parens'ified.
| otherwise =
- wantReadableHandle "hFillBuf" handle $ \ handle_ -> do
- let fo = haFO__ handle_
- rc <- mayBlock fo (readChunk fo buf sz) -- ConcHask: UNSAFE, may block.
- if rc >= 0
- then return rc
- else constructErrorAndFail "hFillBuf"
-
+ mayBlockRead "hFillBuf" handle (\fo -> readChunk fo buf sz)
\end{code}
The @hPutBuf hdl buf len@ action writes an already packed sequence of
@@ -1142,6 +1129,39 @@ mayBlock fo act = do
mayBlock fo act -- output possible
_ -> do
return rc
+
+data MayBlock
+ = BlockRead Int
+ | BlockWrite Int
+ | NoBlock Int
+
+mayBlockRead :: String -> Handle -> (ForeignObj -> IO Int) -> IO Int
+mayBlockRead fname handle fn = do
+ r <- wantReadableHandle fname handle $ \ handle_ -> do
+ let fo = haFO__ handle_
+ rc <- fn fo
+ case rc of
+ -5 -> do -- (possibly blocking) read
+ fd <- getFileFd fo
+ return (BlockRead fd)
+ -6 -> do -- (possibly blocking) write
+ fd <- getFileFd fo
+ return (BlockWrite fd)
+ -7 -> do -- (possibly blocking) write on connected handle
+ fd <- getConnFileFd fo
+ return (BlockWrite fd)
+ _ ->
+ if rc >= 0
+ then return (NoBlock rc)
+ else constructErrorAndFail fname
+ case r of
+ BlockRead fd -> do
+ threadWaitRead fd
+ mayBlockRead fname handle fn
+ BlockWrite fd -> do
+ threadWaitWrite fd
+ mayBlockRead fname handle fn
+ NoBlock c -> return c
\end{code}
Foreign import declarations of helper functions:
--
GitLab