update to current master againwip/T13904

1 files changed, 25 insertions, 20 deletions

diff --git a/compiler/utils/FastString.hs b/compiler/utils/FastString.hs
index 8653485e0c..6ca3043668 100644
--- a/compiler/utils/FastString.hs
+++ b/compiler/utils/FastString.hs
@@ -2,7 +2,7 @@
 
 {-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples,
     GeneralizedNewtypeDeriving #-}
-{-# OPTIONS_GHC -O -funbox-strict-fields #-}
+{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
 -- We always optimise this, otherwise performance of a non-optimised
 -- compiler is severely affected
 
@@ -18,7 +18,7 @@
 --
 -- ['LitString']
 --
---   * Just a wrapper for the @Addr#@ of a C string (@Ptr CChar@).
+--   * Pointer and size of a Latin-1 encoded string.
 --   * Practically no operations.
 --   * Outputing them is fast.
 --   * Generated by 'sLit'.
@@ -81,7 +81,7 @@ module FastString
         hasZEncoding,
 
         -- * LitStrings
-        LitString,
+        LitString (..),
 
         -- ** Construction
         sLit,
@@ -97,6 +97,8 @@ module FastString
 
 #include "HsVersions.h"
 
+import GhcPrelude as Prelude
+
 import Encoding
 import FastFunctions
 import Panic
@@ -118,6 +120,7 @@ import Data.IORef       ( IORef, newIORef, readIORef, atomicModifyIORef' )
 import Data.Maybe       ( isJust )
 import Data.Char
 import Data.List        ( elemIndex )
+import Data.Semigroup as Semi
 
 import GHC.IO           ( IO(..), unsafeDupablePerformIO )
 
@@ -127,7 +130,7 @@ import Foreign
 import GHC.Conc.Sync    (sharedCAF)
 #endif
 
-import GHC.Base         ( unpackCString# )
+import GHC.Base         ( unpackCString#, unpackNBytes# )
 
 #define hASH_TBL_SIZE          4091
 #define hASH_TBL_SIZE_UNBOXED  4091#
@@ -202,9 +205,12 @@ instance Ord FastString where
 instance IsString FastString where
     fromString = fsLit
 
+instance Semi.Semigroup FastString where
+    (<>) = appendFS
+
 instance Monoid FastString where
     mempty = nilFS
-    mappend = appendFS
+    mappend = (Semi.<>)
     mconcat = concatFS
 
 instance Show FastString where
@@ -221,7 +227,7 @@ cmpFS f1@(FastString u1 _ _ _) f2@(FastString u2 _ _ _) =
   if u1 == u2 then EQ else
   compare (fastStringToByteString f1) (fastStringToByteString f2)
 
-foreign import ccall unsafe "ghc_memcmp"
+foreign import ccall unsafe "memcmp"
   memcmp :: Ptr a -> Ptr b -> Int -> IO Int
 
 -- -----------------------------------------------------------------------------
@@ -562,15 +568,12 @@ hPutFS handle fs = BS.hPut handle $ fastStringToByteString fs
 -- -----------------------------------------------------------------------------
 -- LitStrings, here for convenience only.
 
--- | A 'LitString' is a pointer to some null-terminated array of bytes.
-type LitString = Ptr Word8
---Why do we recalculate length every time it's requested?
---If it's commonly needed, we should perhaps have
---data LitString = LitString {-#UNPACK#-}!Addr# {-#UNPACK#-}!Int#
+-- | A 'LitString' is a pointer to some array of Latin-1 encoded chars.
+data LitString = LitString !(Ptr Word8) !Int
 
 -- | Wrap an unboxed address into a 'LitString'.
 mkLitString# :: Addr# -> LitString
-mkLitString# a# = Ptr a#
+mkLitString# a# = LitString (Ptr a#) (ptrStrLength (Ptr a#))
 
 -- | Encode a 'String' into a newly allocated 'LitString' using Latin-1
 -- encoding.  The original string must not contain non-Latin-1 characters
@@ -578,32 +581,34 @@ mkLitString# a# = Ptr a#
 {-# INLINE mkLitString #-}
 mkLitString :: String -> LitString
 mkLitString s =
+ -- we don't use `unsafeDupablePerformIO` here to avoid potential memory leaks
+ -- and because someone might be using `eqAddr#` to check for string equality.
  unsafePerformIO (do
-   p <- mallocBytes (length s + 1)
+   let len = length s
+   p <- mallocBytes len
    let
      loop :: Int -> String -> IO ()
-     loop !n [] = pokeByteOff p n (0 :: Word8)
+     loop !_ []    = return ()
      loop n (c:cs) = do
         pokeByteOff p n (fromIntegral (ord c) :: Word8)
         loop (1+n) cs
    loop 0 s
-   return p
+   return (LitString p len)
  )
 
 -- | Decode a 'LitString' back into a 'String' using Latin-1 encoding.
 -- This does not free the memory associated with 'LitString'.
 unpackLitString :: LitString -> String
-unpackLitString (Ptr p) = unpackCString# p
+unpackLitString (LitString (Ptr p#) (I# n#)) = unpackNBytes# p# n#
 
--- | Compute the length of a 'LitString', which must necessarily be
--- null-terminated.
+-- | Return the length of a 'LitString'
 lengthLS :: LitString -> Int
-lengthLS = ptrStrLength
+lengthLS (LitString _ n) = n
 
 -- -----------------------------------------------------------------------------
 -- under the carpet
 
-foreign import ccall unsafe "ghc_strlen"
+foreign import ccall unsafe "strlen"
   ptrStrLength :: Ptr Word8 -> Int
 
 {-# NOINLINE sLit #-}