[project @ 2001-09-18 08:32:11 by simonmar]

[ghc-hetmet.git] / ghc / lib / std / PrelIO.hsc

diff --git a/ghc/lib/std/PrelIO.hsc b/ghc/lib/std/PrelIO.hsc
index 867c8b6..67f909b 100644 (file)
--- a/ghc/lib/std/PrelIO.hsc
+++ b/ghc/lib/std/PrelIO.hsc
@@ -3,7 +3,7 @@
 #undef DEBUG_DUMP
 
 -- -----------------------------------------------------------------------------
--- $Id: PrelIO.hsc,v 1.7 2001/07/13 11:48:52 rrt Exp $
+-- $Id: PrelIO.hsc,v 1.16 2001/09/18 08:32:11 simonmar Exp $
 --
 -- (c) The University of Glasgow, 1992-2001
 --
@@ -14,7 +14,14 @@
 -- but as it happens they also do everything required by library
 -- module IO.
 
-module PrelIO where
+module PrelIO ( 
+   putChar, putStr, putStrLn, print, getChar, getLine, getContents,
+   interact, readFile, writeFile, appendFile, readLn, readIO, hReady,
+   hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
+   hPutStrLn, hPrint,
+   commitBuffer',      -- hack, see below
+   hGetcBuffered,      -- needed by ghc/compiler/utils/StringBuffer.lhs
+ ) where
 
 #include "HsStd.h"
 #include "PrelHandle_hsc.h"
@@ -22,7 +29,6 @@ module PrelIO where
 import PrelBase
 
 import PrelPosix
-import PrelMarshalAlloc
 import PrelMarshalUtils
 import PrelStorable
 import PrelCError
@@ -492,13 +498,18 @@ writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =
        -- check n == len first, to ensure that shoveString is strict in n.
    shoveString n cs | n == len = do
        new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
-       writeBlocks hdl new_buf cs
+       writeLines hdl new_buf cs
    shoveString n [] = do
        commitBuffer hdl raw len n False{-no flush-} True{-release-}
        return ()
    shoveString n (c:cs) = do
        n' <- writeCharIntoBuffer raw n c
-       shoveString n' cs
+       if (c == '\n') 
+          then do 
+               new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
+               writeLines hdl new_buf cs
+          else 
+               shoveString n' cs
   in
   shoveString 0 s
 
@@ -544,13 +555,27 @@ commitBuffer
        :: Handle                       -- handle to commit to
        -> RawBuffer -> Int             -- address and size (in bytes) of buffer
        -> Int                          -- number of bytes of data in buffer
-       -> Bool                         -- flush the handle afterward?
+       -> Bool                         -- True <=> flush the handle afterward
        -> Bool                         -- release the buffer?
        -> IO Buffer
 
-commitBuffer hdl raw sz count flush release = do
-  wantWritableHandle "commitAndReleaseBuffer" hdl $ 
-    \ handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } -> do
+commitBuffer hdl raw sz@(I## _) count@(I## _) flush release = do
+  wantWritableHandle "commitAndReleaseBuffer" hdl $
+     commitBuffer' hdl raw sz count flush release
+
+-- Explicitly lambda-lift this function to subvert GHC's full laziness
+-- optimisations, which otherwise tends to float out subexpressions
+-- past the \handle, which is really a pessimisation in this case because
+-- that lambda is a one-shot lambda.
+--
+-- Don't forget to export the function, to stop it being inlined too
+-- (this appears to be better than NOINLINE, because the strictness
+-- analyser still gets to worker-wrapper it).
+--
+-- This hack is a fairly big win for hPutStr performance.  --SDM 18/9/2001
+--
+commitBuffer' hdl raw sz@(I## _) count@(I## _) flush release
+  handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do
 
 #ifdef DEBUG_DUMP
       puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
@@ -604,20 +629,22 @@ commitBuffer hdl raw sz count flush release = do
                             else allocateBuffer size WriteBuffer
 
       -- release the buffer if necessary
-      if release && bufSize buf_ret == size
-        then do
+      case buf_ret of
+        Buffer{ bufSize=buf_ret_sz, bufBuf=buf_ret_raw } -> do
+          if release && buf_ret_sz == size
+           then do
              spare_bufs <- readIORef spare_buf_ref
              writeIORef spare_buf_ref 
-               (BufferListCons (bufBuf buf_ret) spare_bufs)
+               (BufferListCons buf_ret_raw spare_bufs)
              return buf_ret
-        else
+           else
              return buf_ret
 
 
-foreign import "memcpy_wrap" unsafe 
+foreign import "memcpy_PrelIO_wrap" unsafe 
    memcpy_off :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
 #def inline \
-void *memcpy_wrap(char *dst, int dst_off, char *src, size_t sz) \
+void *memcpy_PrelIO_wrap(char *dst, HsInt dst_off, const char *src, size_t sz) \
 { return memcpy(dst+dst_off, src, sz); }
 
 -- ---------------------------------------------------------------------------