module FastString
(
bytesFS,
fastStringToByteString,
mkFastStringByteString,
fastZStringToByteString,
unsafeMkByteString,
FastZString,
hPutFZS,
zString,
lengthFZS,
FastString(..),
fsLit,
mkFastString,
mkFastStringBytes,
mkFastStringByteList,
mkFastStringForeignPtr,
mkFastString#,
unpackFS,
zEncodeFS,
uniqueOfFS,
lengthFS,
nullFS,
appendFS,
headFS,
tailFS,
concatFS,
consFS,
nilFS,
isUnderscoreFS,
hPutFS,
getFastStringTable,
getFastStringZEncCounter,
PtrString (..),
sLit,
mkPtrString#,
mkPtrString,
unpackPtrString,
lengthPS
) where
#include "HsVersions.h"
import GhcPrelude as Prelude
import Encoding
import FastFunctions
import PlainPanic
import Util
import Control.Concurrent.MVar
import Control.DeepSeq
import Control.Monad
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Internal as BS
import qualified Data.ByteString.Unsafe as BS
import Foreign.C
import GHC.Exts
import System.IO
import Data.Data
import Data.IORef
import Data.Char
import Data.Semigroup as Semi
import GHC.IO
import Foreign
#if GHC_STAGE >= 2
import GHC.Conc.Sync (sharedCAF)
#endif
import GHC.Base ( unpackCString#, unpackNBytes# )
bytesFS :: FastString -> ByteString
bytesFS f = fs_bs f
fastStringToByteString :: FastString -> ByteString
fastStringToByteString = bytesFS
fastZStringToByteString :: FastZString -> ByteString
fastZStringToByteString (FastZString bs) = bs
unsafeMkByteString :: String -> ByteString
unsafeMkByteString = BSC.pack
hashFastString :: FastString -> Int
hashFastString (FastString _ _ bs _)
= inlinePerformIO $ BS.unsafeUseAsCStringLen bs $ \(ptr, len) ->
return $ hashStr (castPtr ptr) len
newtype FastZString = FastZString ByteString
deriving NFData
hPutFZS :: Handle -> FastZString -> IO ()
hPutFZS handle (FastZString bs) = BS.hPut handle bs
zString :: FastZString -> String
zString (FastZString bs) =
inlinePerformIO $ BS.unsafeUseAsCStringLen bs peekCAStringLen
lengthFZS :: FastZString -> Int
lengthFZS (FastZString bs) = BS.length bs
mkFastZStringString :: String -> FastZString
mkFastZStringString str = FastZString (BSC.pack str)
data FastString = FastString {
uniq :: !Int,
n_chars :: !Int,
fs_bs :: !ByteString,
fs_zenc :: FastZString
}
instance Eq FastString where
f1 == f2 = uniq f1 == uniq f2
instance Ord FastString where
a <= b = case cmpFS a b of { LT -> True; EQ -> True; GT -> False }
a < b = case cmpFS a b of { LT -> True; EQ -> False; GT -> False }
a >= b = case cmpFS a b of { LT -> False; EQ -> True; GT -> True }
a > b = case cmpFS a b of { LT -> False; EQ -> False; GT -> True }
max x y | x >= y = x
| otherwise = y
min x y | x <= y = x
| otherwise = y
compare a b = cmpFS a b
instance IsString FastString where
fromString = fsLit
instance Semi.Semigroup FastString where
(<>) = appendFS
instance Monoid FastString where
mempty = nilFS
mappend = (Semi.<>)
mconcat = concatFS
instance Show FastString where
show fs = show (unpackFS fs)
instance Data FastString where
toConstr _ = abstractConstr "FastString"
gunfold _ _ = error "gunfold"
dataTypeOf _ = mkNoRepType "FastString"
instance NFData FastString where
rnf fs = seq fs ()
cmpFS :: FastString -> FastString -> Ordering
cmpFS f1@(FastString u1 _ _ _) f2@(FastString u2 _ _ _) =
if u1 == u2 then EQ else
compare (bytesFS f1) (bytesFS f2)
foreign import ccall unsafe "memcmp"
memcmp :: Ptr a -> Ptr b -> CSize -> IO CInt
data FastStringTable = FastStringTable
!(IORef Int)
!(IORef Int)
(Array# (IORef FastStringTableSegment))
data FastStringTableSegment = FastStringTableSegment
!(MVar ())
!(IORef Int)
(MutableArray# RealWorld [FastString])
segmentBits, numSegments, segmentMask, initialNumBuckets :: Int
segmentBits = 8
numSegments = 256
segmentMask = 0xff
initialNumBuckets = 64
hashToSegment# :: Int# -> Int#
hashToSegment# hash# = hash# `andI#` segmentMask#
where
!(I# segmentMask#) = segmentMask
hashToIndex# :: MutableArray# RealWorld [FastString] -> Int# -> Int#
hashToIndex# buckets# hash# =
(hash# `uncheckedIShiftRL#` segmentBits#) `remInt#` size#
where
!(I# segmentBits#) = segmentBits
size# = sizeofMutableArray# buckets#
maybeResizeSegment :: IORef FastStringTableSegment -> IO FastStringTableSegment
maybeResizeSegment segmentRef = do
segment@(FastStringTableSegment lock counter old#) <- readIORef segmentRef
let oldSize# = sizeofMutableArray# old#
newSize# = oldSize# *# 2#
(I# n#) <- readIORef counter
if isTrue# (n# <# newSize#)
then return segment
else do
resizedSegment@(FastStringTableSegment _ _ new#) <- IO $ \s1# ->
case newArray# newSize# [] s1# of
(# s2#, arr# #) -> (# s2#, FastStringTableSegment lock counter arr# #)
forM_ [0 .. (I# oldSize#) 1] $ \(I# i#) -> do
fsList <- IO $ readArray# old# i#
forM_ fsList $ \fs -> do
let
!(I# hash#) = hashFastString fs
idx# = hashToIndex# new# hash#
IO $ \s1# ->
case readArray# new# idx# s1# of
(# s2#, bucket #) -> case writeArray# new# idx# (fs: bucket) s2# of
s3# -> (# s3#, () #)
writeIORef segmentRef resizedSegment
return resizedSegment
stringTable :: FastStringTable
stringTable = unsafePerformIO $ do
let !(I# numSegments#) = numSegments
!(I# initialNumBuckets#) = initialNumBuckets
loop a# i# s1#
| isTrue# (i# ==# numSegments#) = s1#
| otherwise = case newMVar () `unIO` s1# of
(# s2#, lock #) -> case newIORef 0 `unIO` s2# of
(# s3#, counter #) -> case newArray# initialNumBuckets# [] s3# of
(# s4#, buckets# #) -> case newIORef
(FastStringTableSegment lock counter buckets#) `unIO` s4# of
(# s5#, segment #) -> case writeArray# a# i# segment s5# of
s6# -> loop a# (i# +# 1#) s6#
uid <- newIORef 603979776
n_zencs <- newIORef 0
tab <- IO $ \s1# ->
case newArray# numSegments# (panic "string_table") s1# of
(# s2#, arr# #) -> case loop arr# 0# s2# of
s3# -> case unsafeFreezeArray# arr# s3# of
(# s4#, segments# #) ->
(# s4#, FastStringTable uid n_zencs segments# #)
#if GHC_STAGE < 2
return tab
#else
sharedCAF tab getOrSetLibHSghcFastStringTable
foreign import ccall unsafe "getOrSetLibHSghcFastStringTable"
getOrSetLibHSghcFastStringTable :: Ptr a -> IO (Ptr a)
#endif
mkFastString# :: Addr# -> FastString
mkFastString# a# = mkFastStringBytes ptr (fromIntegral (ptrStrLength ptr))
where ptr = Ptr a#
mkFastStringWith
:: (Int -> IORef Int-> IO FastString) -> Ptr Word8 -> Int -> IO FastString
mkFastStringWith mk_fs !ptr !len = do
FastStringTableSegment lock _ buckets# <- readIORef segmentRef
let idx# = hashToIndex# buckets# hash#
bucket <- IO $ readArray# buckets# idx#
res <- bucket_match bucket len ptr
case res of
Just found -> return found
Nothing -> do
noDuplicate
n <- get_uid
new_fs <- mk_fs n n_zencs
withMVar lock $ \_ -> insert new_fs
where
!(FastStringTable uid n_zencs segments#) = stringTable
get_uid = atomicModifyIORef' uid $ \n -> (n+1,n)
!(I# hash#) = hashStr ptr len
(# segmentRef #) = indexArray# segments# (hashToSegment# hash#)
insert fs = do
FastStringTableSegment _ counter buckets# <- maybeResizeSegment segmentRef
let idx# = hashToIndex# buckets# hash#
bucket <- IO $ readArray# buckets# idx#
res <- bucket_match bucket len ptr
case res of
Just found -> return found
Nothing -> do
IO $ \s1# ->
case writeArray# buckets# idx# (fs: bucket) s1# of
s2# -> (# s2#, () #)
modifyIORef' counter succ
return fs
bucket_match :: [FastString] -> Int -> Ptr Word8 -> IO (Maybe FastString)
bucket_match [] _ _ = return Nothing
bucket_match (v@(FastString _ _ bs _):ls) len ptr
| len == BS.length bs = do
b <- BS.unsafeUseAsCString bs $ \buf ->
cmpStringPrefix ptr (castPtr buf) len
if b then return (Just v)
else bucket_match ls len ptr
| otherwise =
bucket_match ls len ptr
mkFastStringBytes :: Ptr Word8 -> Int -> FastString
mkFastStringBytes !ptr !len =
unsafeDupablePerformIO $
mkFastStringWith (copyNewFastString ptr len) ptr len
mkFastStringForeignPtr :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO FastString
mkFastStringForeignPtr ptr !fp len
= mkFastStringWith (mkNewFastString fp ptr len) ptr len
mkFastStringByteString :: ByteString -> FastString
mkFastStringByteString bs =
inlinePerformIO $
BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> do
let ptr' = castPtr ptr
mkFastStringWith (mkNewFastStringByteString bs ptr' len) ptr' len
mkFastString :: String -> FastString
mkFastString str =
inlinePerformIO $ do
let l = utf8EncodedLength str
buf <- mallocForeignPtrBytes l
withForeignPtr buf $ \ptr -> do
utf8EncodeString ptr str
mkFastStringForeignPtr ptr buf l
mkFastStringByteList :: [Word8] -> FastString
mkFastStringByteList str = mkFastStringByteString (BS.pack str)
mkZFastString :: IORef Int -> ByteString -> FastZString
mkZFastString n_zencs bs = unsafePerformIO $ do
atomicModifyIORef' n_zencs $ \n -> (n+1, ())
return $ mkFastZStringString (zEncodeString (utf8DecodeByteString bs))
mkNewFastString :: ForeignPtr Word8 -> Ptr Word8 -> Int -> Int
-> IORef Int -> IO FastString
mkNewFastString fp ptr len uid n_zencs = do
let bs = BS.fromForeignPtr fp 0 len
zstr = mkZFastString n_zencs bs
n_chars <- countUTF8Chars ptr len
return (FastString uid n_chars bs zstr)
mkNewFastStringByteString :: ByteString -> Ptr Word8 -> Int -> Int
-> IORef Int -> IO FastString
mkNewFastStringByteString bs ptr len uid n_zencs = do
let zstr = mkZFastString n_zencs bs
n_chars <- countUTF8Chars ptr len
return (FastString uid n_chars bs zstr)
copyNewFastString :: Ptr Word8 -> Int -> Int -> IORef Int -> IO FastString
copyNewFastString ptr len uid n_zencs = do
fp <- copyBytesToForeignPtr ptr len
let bs = BS.fromForeignPtr fp 0 len
zstr = mkZFastString n_zencs bs
n_chars <- countUTF8Chars ptr len
return (FastString uid n_chars bs zstr)
copyBytesToForeignPtr :: Ptr Word8 -> Int -> IO (ForeignPtr Word8)
copyBytesToForeignPtr ptr len = do
fp <- mallocForeignPtrBytes len
withForeignPtr fp $ \ptr' -> copyBytes ptr' ptr len
return fp
cmpStringPrefix :: Ptr Word8 -> Ptr Word8 -> Int -> IO Bool
cmpStringPrefix ptr1 ptr2 len =
do r <- memcmp ptr1 ptr2 (fromIntegral len)
return (r == 0)
hashStr :: Ptr Word8 -> Int -> Int
hashStr (Ptr a#) (I# len#) = loop 0# 0#
where
loop h n =
if isTrue# (n ==# len#) then
I# h
else
let
!c = ord# (indexCharOffAddr# a# n)
!h2 = (h *# 16777619#) `xorI#` c
in
loop h2 (n +# 1#)
lengthFS :: FastString -> Int
lengthFS f = n_chars f
nullFS :: FastString -> Bool
nullFS f = BS.null (fs_bs f)
unpackFS :: FastString -> String
unpackFS (FastString _ _ bs _) = utf8DecodeByteString bs
zEncodeFS :: FastString -> FastZString
zEncodeFS (FastString _ _ _ ref) = ref
appendFS :: FastString -> FastString -> FastString
appendFS fs1 fs2 = mkFastStringByteString
$ BS.append (bytesFS fs1) (bytesFS fs2)
concatFS :: [FastString] -> FastString
concatFS = mkFastStringByteString . BS.concat . map fs_bs
headFS :: FastString -> Char
headFS (FastString _ 0 _ _) = panic "headFS: Empty FastString"
headFS (FastString _ _ bs _) =
inlinePerformIO $ BS.unsafeUseAsCString bs $ \ptr ->
return (fst (utf8DecodeChar (castPtr ptr)))
tailFS :: FastString -> FastString
tailFS (FastString _ 0 _ _) = panic "tailFS: Empty FastString"
tailFS (FastString _ _ bs _) =
inlinePerformIO $ BS.unsafeUseAsCString bs $ \ptr ->
do let (_, n) = utf8DecodeChar (castPtr ptr)
return $! mkFastStringByteString (BS.drop n bs)
consFS :: Char -> FastString -> FastString
consFS c fs = mkFastString (c : unpackFS fs)
uniqueOfFS :: FastString -> Int
uniqueOfFS (FastString u _ _ _) = u
nilFS :: FastString
nilFS = mkFastString ""
isUnderscoreFS :: FastString -> Bool
isUnderscoreFS fs = fs == fsLit "_"
getFastStringTable :: IO [[[FastString]]]
getFastStringTable =
forM [0 .. numSegments 1] $ \(I# i#) -> do
let (# segmentRef #) = indexArray# segments# i#
FastStringTableSegment _ _ buckets# <- readIORef segmentRef
let bucketSize = I# (sizeofMutableArray# buckets#)
forM [0 .. bucketSize 1] $ \(I# j#) ->
IO $ readArray# buckets# j#
where
!(FastStringTable _ _ segments#) = stringTable
getFastStringZEncCounter :: IO Int
getFastStringZEncCounter = readIORef n_zencs
where
!(FastStringTable _ n_zencs _) = stringTable
hPutFS :: Handle -> FastString -> IO ()
hPutFS handle fs = BS.hPut handle $ bytesFS fs
data PtrString = PtrString !(Ptr Word8) !Int
mkPtrString# :: Addr# -> PtrString
mkPtrString# a# = PtrString (Ptr a#) (fromIntegral (ptrStrLength (Ptr a#)))
mkPtrString :: String -> PtrString
mkPtrString s =
unsafePerformIO (do
let len = length s
p <- mallocBytes len
let
loop :: Int -> String -> IO ()
loop !_ [] = return ()
loop n (c:cs) = do
pokeByteOff p n (fromIntegral (ord c) :: Word8)
loop (1+n) cs
loop 0 s
return (PtrString p len)
)
unpackPtrString :: PtrString -> String
unpackPtrString (PtrString (Ptr p#) (I# n#)) = unpackNBytes# p# n#
lengthPS :: PtrString -> Int
lengthPS (PtrString _ n) = n
foreign import ccall unsafe "strlen"
ptrStrLength :: Ptr Word8 -> CSize
sLit :: String -> PtrString
sLit x = mkPtrString x
fsLit :: String -> FastString
fsLit x = mkFastString x