From 6f191b69a64cdf0492643c56b279f95a0caa87cf Mon Sep 17 00:00:00 2001
From: simonmar <unknown>
Date: Thu, 18 May 2000 12:42:21 +0000
Subject: [PATCH] [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.
---
 ghc/lib/std/PrelHandle.lhs |   36 +++++++++++++++++++++++++--
 ghc/lib/std/PrelIO.lhs     |   59 +++++++++++++++++++++++---------------------
 2 files changed, 65 insertions(+), 30 deletions(-)

diff --git a/ghc/lib/std/PrelHandle.lhs b/ghc/lib/std/PrelHandle.lhs
index caa59db..d3b1320 100644
--- 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
--- 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@
-- 
1.7.10.4