From: simonmar <unknown>
Date: Tue, 18 Jan 2000 12:44:37 +0000 (+0000)
Subject: [project @ 2000-01-18 12:44:37 by simonmar]
X-Git-Tag: Approximately_9120_patches~5262
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=382ca27d7b1e33640b9dab670bfbf3f32bb3f4cf;p=ghc-hetmet.git

[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.
---

diff --git a/ghc/lib/std/IO.lhs b/ghc/lib/std/IO.lhs
index 1a8d4b3..0ca2180 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 d65c234..a1faf99 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: