[project @ 2000-05-18 12:42:20 by simonmar]

New version of hGetLine that is roughly 4 times faster than the
original, and is tail-recursive to boot.

I'm not entirely happy with the code, but it needs to get some testing.

diff --git a/ghc/lib/std/PrelHandle.lhs b/ghc/lib/std/PrelHandle.lhs
index caa59db..d3b1320 100644 (file)
--- a/ghc/lib/std/PrelHandle.lhs
+++ b/ghc/lib/std/PrelHandle.lhs
@@ -1108,10 +1108,10 @@ mayBlock fo act = do
      _ -> do
         return rc
 
-data MayBlock
+data MayBlock a
   = BlockRead Int
   | BlockWrite Int
-  | NoBlock Int
+  | NoBlock a
 
 mayBlockRead :: String -> Handle -> (FILE_OBJECT -> IO Int) -> IO Int
 mayBlockRead fname handle fn = do
@@ -1141,6 +1141,38 @@ mayBlockRead fname handle fn = do
           mayBlockRead fname handle fn
        NoBlock c -> return c
 
+mayBlockRead' :: String -> Handle
+       -> (FILE_OBJECT -> IO Int)
+       -> (FILE_OBJECT -> Int -> IO a)
+       -> IO a
+mayBlockRead' fname handle fn io = 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 do a <- io fo rc 
+                         return (NoBlock a)
+                 else constructErrorAndFail fname
+    case r of
+       BlockRead fd -> do
+          threadWaitRead fd
+          mayBlockRead' fname handle fn io
+       BlockWrite fd -> do
+          threadWaitWrite fd
+          mayBlockRead' fname handle fn io
+       NoBlock c -> return c
+
 mayBlockWrite :: String -> Handle -> (FILE_OBJECT -> IO Int) -> IO Int
 mayBlockWrite fname handle fn = do
     r <- wantWriteableHandle fname handle $ \ handle_ -> do

diff --git a/ghc/lib/std/PrelIO.lhs b/ghc/lib/std/PrelIO.lhs
index 187653c..ec150bb 100644 (file)
--- a/ghc/lib/std/PrelIO.lhs
+++ b/ghc/lib/std/PrelIO.lhs
@@ -20,15 +20,15 @@ import PrelIOBase
 import PrelHandle      -- much of the real stuff is in here
 
 import PrelNum
-import PrelRead         ( readParen, Read(..), reads, lex,
-                         readIO 
-                       )
+import PrelRead         ( readParen, Read(..), reads, lex, readIO )
 import PrelShow
 import PrelMaybe       ( Either(..), Maybe(..) )
 import PrelAddr                ( Addr(..), AddrOff(..), nullAddr, plusAddr )
+import PrelList                ( concat, reverse, null )
 import PrelByteArr     ( ByteArray )
-import PrelPack                ( unpackNBytesAccST )
-import PrelException    ( ioError, catch, catchException, throw, blockAsyncExceptions )
+import PrelPack                ( unpackNBytesST, unpackNBytesAccST )
+import PrelException    ( ioError, catch, catchException, throw, 
+                         blockAsyncExceptions )
 import PrelConc
 \end{code}
 
@@ -137,30 +137,33 @@ hGetChar handle = do
   EOF and return the partial line. Next attempt at calling
   hGetLine on the handle will yield an EOF IO exception though.
 -}
-hGetLine :: Handle -> IO String
-hGetLine h = do
-  c <- hGetChar h
-  if c == '\n' then
-     return ""
-   else do
-    l <- getRest
-    return (c:l)
- where
-  getRest = do
-    c <- 
-      catch 
-        (hGetChar h)
-        (\ err -> do
-          if isEOFError err then
-            return '\n'
-          else
-            ioError err)
-    if c == '\n' then
-       return ""
-     else do
-       s <- getRest
-       return (c:s)
 
+hGetLine :: Handle -> IO String
+hGetLine h = hGetLineBuf' []
+  where hGetLineBuf' xss = do
+          (eol, xss) <- catch 
+           ( do
+             mayBlockRead' "hGetLine" h 
+               (\fo -> readLine fo)
+               (\fo bytes -> do
+                 buf <- getBufStart fo bytes
+                 eol <- readCharOffAddr buf (bytes-1)
+                 xs <- if (eol == '\n') 
+                         then stToIO (unpackNBytesST buf (bytes-1))
+                         else stToIO (unpackNBytesST buf bytes)
+                 return (eol, xs:xss)
+              )
+            )
+            (\e -> if isEOFError e && not (null xss)
+                       then return ('\n', xss)
+                       else ioError e)
+               
+          if (eol == '\n')
+               then return (concat (reverse xss))
+               else hGetLineBuf' xss
+
+readCharOffAddr (A# a) (I# i)
+  = IO $ \s -> case readCharOffAddr# a i s of { (# s,x #) -> (# s, C# x #) }
 \end{code}
 
 @hLookahead hdl@ returns the next character from handle @hdl@