X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Futils%2FStringBuffer.lhs;h=5d1bfa60861781e17bf8528ad1bb7e33bdeceebd;hp=f3b1c2273f119b6170435d54599032d999b0fc4a;hb=d0faaa6fa0cecd23c5670fd199e9206275313666;hpb=2b56761f97edb4ceb017a09d2049a6158c1e5e8e

diff --git a/compiler/utils/StringBuffer.lhs b/compiler/utils/StringBuffer.lhs
index f3b1c22..5d1bfa6 100644
--- a/compiler/utils/StringBuffer.lhs
+++ b/compiler/utils/StringBuffer.lhs
@@ -6,12 +6,10 @@
 Buffers for scanning string input stored in external arrays.
 
 \begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
+{-# LANGUAGE BangPatterns #-}
+{-# OPTIONS_GHC -O -funbox-strict-fields #-}
+-- We always optimise this, otherwise performance of a non-optimised
+-- compiler is severely affected
 
 module StringBuffer
        (
@@ -56,15 +54,7 @@ import System.IO                ( hGetBuf, hFileSize,IOMode(ReadMode), hClose
 
 import GHC.Exts
 
-#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ >= 601
 import System.IO                ( openBinaryFile )
-#else
-import IOExts                   ( openFileEx, IOModeEx(..) )
-#endif
-
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 601
-openBinaryFile fp mode = openFileEx fp (BinaryMode mode)
-#endif
 
 -- -----------------------------------------------------------------------------
 -- The StringBuffer type
@@ -90,7 +80,7 @@ data StringBuffer
 instance Show StringBuffer where
         showsPrec _ s = showString "<stringbuffer("
                       . shows (len s) . showString "," . shows (cur s)
-                      . showString ">"
+                      . showString ")>"
 
 -- -----------------------------------------------------------------------------
 -- Creation / Destruction
@@ -140,15 +130,18 @@ appendStringBuffers sb1 sb2
          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)
+             do copyArray ptr (sb1Ptr `advancePtr` cur sb1) sb1_len
+                copyArray (ptr `advancePtr` sb1_len) (sb2Ptr `advancePtr` cur sb2) sb2_len
                 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
+    where sb1_len = calcLen sb1
+          sb2_len = calcLen sb2
+          calcLen sb = len sb - cur sb
+          size =  sb1_len + sb2_len
+
+stringToStringBuffer :: String -> StringBuffer
+stringToStringBuffer str =
+ unsafePerformIO $ do
   let size = utf8EncodedLength str
   buf <- mallocForeignPtrArray (size+3)
   withForeignPtr buf $ \ptr -> do
@@ -175,8 +168,8 @@ currentChar :: StringBuffer -> Char
 currentChar = fst . nextChar
 
 prevChar :: StringBuffer -> Char -> Char
-prevChar (StringBuffer buf len 0)   deflt = deflt
-prevChar (StringBuffer buf len cur) deflt =
+prevChar (StringBuffer _   _   0)   deflt = deflt
+prevChar (StringBuffer buf _   cur) _     =
   inlinePerformIO $ do
     withForeignPtr buf $ \p -> do
       p' <- utf8PrevChar (p `plusPtr` cur)
@@ -233,11 +226,11 @@ parseUnsignedInteger (StringBuffer buf _ cur) len radix char_to_int
     --LOL, in implementations where the indexing needs slow unsafePerformIO,
     --this is less (not more) efficient than using the IO monad explicitly
     --here.
-    byteOff p i = cBox (indexWord8OffFastPtrAsFastChar
-                         (pUnbox ptr) (iUnbox (cur+i)))
+    !ptr' = pUnbox ptr
+    byteOff i = cBox (indexWord8OffFastPtrAsFastChar ptr' (iUnbox (cur + i)))
     go i x | i == len  = x
-           | otherwise = case byteOff ptr i of
-               char -> go (i+1) (x * radix + toInteger (char_to_int char))
+           | otherwise = case byteOff i of
+               char -> go (i + 1) (x * radix + toInteger (char_to_int char))
   in go 0 0
 
 \end{code}