Enable shortcutting of stack squeezing

[ghc-hetmet.git] / ghc / compiler / utils / StringBuffer.lhs

diff --git a/ghc/compiler/utils/StringBuffer.lhs b/ghc/compiler/utils/StringBuffer.lhs
index e2eed88..e52e7e7 100644 (file)
--- a/ghc/compiler/utils/StringBuffer.lhs
+++ b/ghc/compiler/utils/StringBuffer.lhs
@@ -1,14 +1,11 @@
 %
-% (c) The University of Glasgow, 1997-2003
+% (c) The University of Glasgow, 1997-2006
 %
 \section{String buffers}
 
 Buffers for scanning string input stored in external arrays.
 
 \begin{code}
-{-# OPTIONS_GHC -O #-}
--- always optimise this module, it's critical
-
 module StringBuffer
        (
         StringBuffer(..),
@@ -16,6 +13,8 @@ module StringBuffer
 
         -- * Creation\/destruction
         hGetStringBuffer,
+        hGetStringBufferBlock,
+        appendStringBuffers,
        stringToStringBuffer,
 
        -- * Inspection
@@ -40,19 +39,17 @@ module StringBuffer
 #include "HsVersions.h"
 
 import Encoding
-import FastString      (FastString,mkFastString,mkFastStringBytes)
-
-import GLAEXTS
+import FastString              ( FastString,mkFastString,mkFastStringBytes )
 
 import Foreign
+import System.IO               ( hGetBuf, hFileSize,IOMode(ReadMode), hClose
+                                , Handle, hTell )
 
+import GHC.Ptr                 ( Ptr(..) )
+import GHC.Exts
 import GHC.IOBase              ( IO(..) )
 import GHC.Base                        ( unsafeChr )
 
-import System.IO               ( hGetBuf )
-
-import IO                      ( hFileSize, IOMode(ReadMode),
-                                 hClose )
 #if __GLASGOW_HASKELL__ >= 601
 import System.IO               ( openBinaryFile )
 #else
@@ -108,6 +105,32 @@ hGetStringBuffer fname = do
                 -- sentinels for UTF-8 decoding
          return (StringBuffer buf size 0)
 
+hGetStringBufferBlock :: Handle -> Int -> IO StringBuffer
+hGetStringBufferBlock handle wanted
+    = do size_i <- hFileSize handle
+         offset_i <- hTell handle
+         let size = min wanted (fromIntegral $ size_i-offset_i)
+         buf <- mallocForeignPtrArray (size+3)
+         withForeignPtr buf $ \ptr ->
+             do r <- if size == 0 then return 0 else hGetBuf handle ptr size
+                if r /= size
+                   then ioError (userError $ "short read of file: "++show(r,size,fromIntegral size_i,handle))
+                   else do pokeArray (ptr `plusPtr` size :: Ptr Word8) [0,0,0]
+                           return (StringBuffer buf size 0)
+
+appendStringBuffers :: StringBuffer -> StringBuffer -> IO StringBuffer
+appendStringBuffers sb1 sb2
+    = do newBuf <- mallocForeignPtrArray (size+3)
+         withForeignPtr newBuf $ \ptr ->
+          withForeignPtr (buf sb1) $ \sb1Ptr ->
+           withForeignPtr (buf sb2) $ \sb2Ptr ->
+             do copyArray (sb1Ptr `advancePtr` cur sb1) ptr (calcLen sb1)
+                copyArray (sb2Ptr `advancePtr` cur sb2) (ptr `advancePtr` cur sb1) (calcLen sb2)
+                pokeArray (ptr `advancePtr` size) [0,0,0]
+                return (StringBuffer newBuf size 0)
+    where calcLen sb = len sb - cur sb
+          size = calcLen sb1 + calcLen sb2
+
 stringToStringBuffer :: String -> IO StringBuffer
 stringToStringBuffer str = do
   let size = utf8EncodedLength str
@@ -199,4 +222,19 @@ parseInteger buf len radix to_int
 inlinePerformIO :: IO a -> a
 inlinePerformIO (IO m) = case m realWorld# of (# _, r #)   -> r
 
+#if __GLASGOW_HASKELL__ < 600
+mallocForeignPtrArray :: Storable a => Int -> IO (ForeignPtr a)
+mallocForeignPtrArray  = doMalloc undefined
+  where
+    doMalloc            :: Storable b => b -> Int -> IO (ForeignPtr b)
+    doMalloc dummy size  = mallocForeignPtrBytes (size * sizeOf dummy)
+
+mallocForeignPtrBytes :: Int -> IO (ForeignPtr a)
+mallocForeignPtrBytes n = do
+  r <- mallocBytes n
+  newForeignPtr r (finalizerFree r)
+
+foreign import ccall unsafe "stdlib.h free" 
+  finalizerFree :: Ptr a -> IO ()
+#endif
 \end{code}