{-# LANGUAGE CPP #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UnliftedFFITypes #-}

{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
-- We always optimise this, otherwise performance of a non-optimised
-- compiler is severely affected

-- |
-- There are two principal string types used internally by GHC:
--
-- ['FastString']
--
--   * A compact, hash-consed, representation of character strings.
--   * Generated by 'fsLit'.
--   * You can get a 'GHC.Types.Unique.Unique' from them.
--   * Equality test is O(1) (it uses the Unique).
--   * Comparison is O(1) or O(n):
--       * O(n) but deterministic with lexical comparison (`lexicalCompareFS`)
--       * O(1) but non-deterministic with Unique comparison (`uniqCompareFS`)
--   * Turn into 'GHC.Utils.Outputable.SDoc' with 'GHC.Utils.Outputable.ftext'.
--
-- ['PtrString']
--
--   * Pointer and size of a Latin-1 encoded string.
--   * Practically no operations.
--   * Outputting them is fast.
--   * Generated by 'mkPtrString#'.
--   * Length of string literals (mkPtrString# "abc"#) is computed statically
--   * Turn into 'GHC.Utils.Outputable.SDoc' with 'GHC.Utils.Outputable.ptext'
--   * Requires manual memory management.
--     Improper use may lead to memory leaks or dangling pointers.
--   * It assumes Latin-1 as the encoding, therefore it cannot represent
--     arbitrary Unicode strings.
--
-- Use 'PtrString' unless you want the facilities of 'FastString'.
module GHC.Data.FastString
       (
        -- * ByteString
        bytesFS,
        fastStringToByteString,
        mkFastStringByteString,
        fastZStringToByteString,
        unsafeMkByteString,

        -- * ShortByteString
        fastStringToShortByteString,
        mkFastStringShortByteString,

        -- * ShortText
        fastStringToShortText,

        -- * FastZString
        FastZString,
        hPutFZS,
        zString,
        zStringTakeN,
        lengthFZS,

        -- * FastStrings
        FastString(..),     -- not abstract, for now.
        NonDetFastString (..),
        LexicalFastString (..),

        -- ** Construction
        fsLit,
        mkFastString,
        mkFastStringBytes,
        mkFastStringByteList,
        mkFastString#,

        -- ** Deconstruction
        unpackFS,           -- :: FastString -> String
        unconsFS,           -- :: FastString -> Maybe (Char, FastString)

        -- ** Encoding
        zEncodeFS,

        -- ** Operations
        uniqueOfFS,
        lengthFS,
        nullFS,
        appendFS,
        concatFS,
        consFS,
        nilFS,
        lexicalCompareFS,
        uniqCompareFS,

        -- ** Outputting
        hPutFS,

        -- ** Internal
        getFastStringTable,
        getFastStringZEncCounter,

        -- * PtrStrings
        PtrString (..),

        -- ** Construction
        mkPtrString#,

        -- ** Deconstruction
        unpackPtrString,
        unpackPtrStringTakeN,

        -- ** Operations
        lengthPS
       ) where

import GHC.Prelude.Basic as Prelude

import GHC.Utils.Encoding
import GHC.Utils.IO.Unsafe
import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
import GHC.Data.FastMutInt

import Control.Concurrent.MVar
import Control.DeepSeq
import Control.Monad
import Data.ByteString (ByteString)
import Data.ByteString.Short (ShortByteString)
import qualified Data.ByteString          as BS
import qualified Data.ByteString.Char8    as BSC
import qualified Data.ByteString.Unsafe   as BS
import qualified Data.ByteString.Short    as SBS
#if !MIN_VERSION_bytestring(0,11,0)
import qualified Data.ByteString.Short.Internal as SBS
#endif
import GHC.Data.ShortText (ShortText(..))
import Foreign.C
import System.IO
import Data.Data
import Data.IORef
import Data.Semigroup as Semi

import Foreign

#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)
import GHC.Conc.Sync    (sharedCAF)
#endif

import GHC.Exts
import GHC.IO

-- | Gives the Modified UTF-8 encoded bytes corresponding to a 'FastString'
bytesFS, fastStringToByteString :: FastString -> ByteString
{-# INLINE[1] bytesFS #-}
bytesFS :: FastString -> ByteString
bytesFS FastString
f = ShortByteString -> ByteString
SBS.fromShort (ShortByteString -> ByteString) -> ShortByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ FastString -> ShortByteString
fs_sbs FastString
f

{-# DEPRECATED fastStringToByteString "Use `bytesFS` instead" #-}
fastStringToByteString :: FastString -> ByteString
fastStringToByteString = FastString -> ByteString
bytesFS

fastStringToShortByteString :: FastString -> ShortByteString
fastStringToShortByteString :: FastString -> ShortByteString
fastStringToShortByteString = FastString -> ShortByteString
fs_sbs

fastStringToShortText :: FastString -> ShortText
fastStringToShortText :: FastString -> ShortText
fastStringToShortText = ShortByteString -> ShortText
ShortText (ShortByteString -> ShortText)
-> (FastString -> ShortByteString) -> FastString -> ShortText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> ShortByteString
fs_sbs

fastZStringToByteString :: FastZString -> ByteString
fastZStringToByteString :: FastZString -> ByteString
fastZStringToByteString (FastZString ByteString
bs) = ByteString
bs

-- This will drop information if any character > '\xFF'
unsafeMkByteString :: String -> ByteString
unsafeMkByteString :: String -> ByteString
unsafeMkByteString = String -> ByteString
BSC.pack

hashFastString :: FastString -> Int
hashFastString :: FastString -> Int
hashFastString FastString
fs = ShortByteString -> Int
hashStr (ShortByteString -> Int) -> ShortByteString -> Int
forall a b. (a -> b) -> a -> b
$ FastString -> ShortByteString
fs_sbs FastString
fs

-- -----------------------------------------------------------------------------

newtype FastZString = FastZString ByteString
  deriving FastZString -> ()
(FastZString -> ()) -> NFData FastZString
forall a. (a -> ()) -> NFData a
$crnf :: FastZString -> ()
rnf :: FastZString -> ()
NFData

hPutFZS :: Handle -> FastZString -> IO ()
hPutFZS :: Handle -> FastZString -> IO ()
hPutFZS Handle
handle (FastZString ByteString
bs) = Handle -> ByteString -> IO ()
BS.hPut Handle
handle ByteString
bs

zString :: FastZString -> String
zString :: FastZString -> String
zString (FastZString ByteString
bs) =
    IO String -> String
forall a. IO a -> a
inlinePerformIO (IO String -> String) -> IO String -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> (CStringLen -> IO String) -> IO String
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BS.unsafeUseAsCStringLen ByteString
bs CStringLen -> IO String
peekCAStringLen

-- | @zStringTakeN n = 'take' n . 'zString'@
-- but is performed in \(O(\min(n,l))\) rather than \(O(l)\),
-- where \(l\) is the length of the 'FastZString'.
zStringTakeN :: Int -> FastZString -> String
zStringTakeN :: Int -> FastZString -> String
zStringTakeN Int
n (FastZString ByteString
bs) =
    IO String -> String
forall a. IO a -> a
inlinePerformIO (IO String -> String) -> IO String -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> (CStringLen -> IO String) -> IO String
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BS.unsafeUseAsCStringLen ByteString
bs ((CStringLen -> IO String) -> IO String)
-> (CStringLen -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
cp, Int
len) ->
        CStringLen -> IO String
peekCAStringLen (Ptr CChar
cp, Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
n Int
len)

lengthFZS :: FastZString -> Int
lengthFZS :: FastZString -> Int
lengthFZS (FastZString ByteString
bs) = ByteString -> Int
BS.length ByteString
bs

mkFastZStringString :: String -> FastZString
mkFastZStringString :: String -> FastZString
mkFastZStringString String
str = ByteString -> FastZString
FastZString (String -> ByteString
BSC.pack String
str)

-- -----------------------------------------------------------------------------

{-| A 'FastString' is a Modified UTF-8 encoded string together with a unique ID.
All 'FastString's are stored in a global hashtable to support fast O(1)
comparison.

It is also associated with a lazy reference to the Z-encoding
of this string which is used by the compiler internally.
-}
data FastString = FastString {
      FastString -> Int
uniq    :: {-# UNPACK #-} !Int, -- unique id
      FastString -> Int
n_chars :: {-# UNPACK #-} !Int, -- number of chars
      FastString -> ShortByteString
fs_sbs  :: {-# UNPACK #-} !ShortByteString,
      FastString -> FastZString
fs_zenc :: FastZString
      -- ^ Lazily computed Z-encoding of this string. See Note [Z-Encoding] in
      -- GHC.Utils.Encoding.
      --
      -- Since 'FastString's are globally memoized this is computed at most
      -- once for any given string.
  }

instance Eq FastString where
  FastString
f1 == :: FastString -> FastString -> Bool
== FastString
f2  =  FastString -> Int
uniq FastString
f1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== FastString -> Int
uniq FastString
f2

-- We don't provide any "Ord FastString" instance to force you to think about
-- which ordering you want:
--    * lexical:   deterministic,     O(n). Cf lexicalCompareFS and LexicalFastString.
--    * by unique: non-deterministic, O(1). Cf uniqCompareFS    and NonDetFastString.

instance IsString FastString where
    fromString :: String -> FastString
fromString = String -> FastString
fsLit

instance Semi.Semigroup FastString where
    <> :: FastString -> FastString -> FastString
(<>) = FastString -> FastString -> FastString
appendFS

instance Monoid FastString where
    mempty :: FastString
mempty = FastString
nilFS
    mappend :: FastString -> FastString -> FastString
mappend = FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
(Semi.<>)
    mconcat :: [FastString] -> FastString
mconcat = [FastString] -> FastString
concatFS

instance Show FastString where
   show :: FastString -> String
show FastString
fs = ShowS
forall a. Show a => a -> String
show (FastString -> String
unpackFS FastString
fs)

instance Data FastString where
  -- don't traverse?
  toConstr :: FastString -> Constr
toConstr FastString
_   = String -> Constr
abstractConstr String
"FastString"
  gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c FastString
gunfold forall b r. Data b => c (b -> r) -> c r
_ forall r. r -> c r
_  = String -> Constr -> c FastString
forall a. HasCallStack => String -> a
error String
"gunfold"
  dataTypeOf :: FastString -> DataType
dataTypeOf FastString
_ = String -> DataType
mkNoRepType String
"FastString"

instance NFData FastString where
  rnf :: FastString -> ()
rnf FastString
fs = FastString -> () -> ()
forall a b. a -> b -> b
seq FastString
fs ()

-- | Compare FastString lexically
--
-- If you don't care about the lexical ordering, use `uniqCompareFS` instead.
lexicalCompareFS :: FastString -> FastString -> Ordering
lexicalCompareFS :: FastString -> FastString -> Ordering
lexicalCompareFS FastString
fs1 FastString
fs2 =
  if FastString -> Int
uniq FastString
fs1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== FastString -> Int
uniq FastString
fs2 then Ordering
EQ else
  ShortByteString -> ShortByteString -> Ordering
utf8CompareShortByteString (FastString -> ShortByteString
fs_sbs FastString
fs1) (FastString -> ShortByteString
fs_sbs FastString
fs2)
  -- perform a lexical comparison taking into account the Modified UTF-8
  -- encoding we use (cf #18562)

-- | Compare FastString by their Unique (not lexically).
--
-- Much cheaper than `lexicalCompareFS` but non-deterministic!
uniqCompareFS :: FastString -> FastString -> Ordering
uniqCompareFS :: FastString -> FastString -> Ordering
uniqCompareFS FastString
fs1 FastString
fs2 = Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (FastString -> Int
uniq FastString
fs1) (FastString -> Int
uniq FastString
fs2)

-- | Non-deterministic FastString
--
-- This is a simple FastString wrapper with an Ord instance using
-- `uniqCompareFS` (i.e. which compares FastStrings on their Uniques). Hence it
-- is not deterministic from one run to the other.
newtype NonDetFastString
   = NonDetFastString FastString
   deriving newtype (NonDetFastString -> NonDetFastString -> Bool
(NonDetFastString -> NonDetFastString -> Bool)
-> (NonDetFastString -> NonDetFastString -> Bool)
-> Eq NonDetFastString
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NonDetFastString -> NonDetFastString -> Bool
== :: NonDetFastString -> NonDetFastString -> Bool
$c/= :: NonDetFastString -> NonDetFastString -> Bool
/= :: NonDetFastString -> NonDetFastString -> Bool
Eq, Int -> NonDetFastString -> ShowS
[NonDetFastString] -> ShowS
NonDetFastString -> String
(Int -> NonDetFastString -> ShowS)
-> (NonDetFastString -> String)
-> ([NonDetFastString] -> ShowS)
-> Show NonDetFastString
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NonDetFastString -> ShowS
showsPrec :: Int -> NonDetFastString -> ShowS
$cshow :: NonDetFastString -> String
show :: NonDetFastString -> String
$cshowList :: [NonDetFastString] -> ShowS
showList :: [NonDetFastString] -> ShowS
Show)
   deriving stock Typeable NonDetFastString
Typeable NonDetFastString =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> NonDetFastString -> c NonDetFastString)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c NonDetFastString)
-> (NonDetFastString -> Constr)
-> (NonDetFastString -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c NonDetFastString))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c NonDetFastString))
-> ((forall b. Data b => b -> b)
    -> NonDetFastString -> NonDetFastString)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> NonDetFastString -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> NonDetFastString -> r)
-> (forall u.
    (forall d. Data d => d -> u) -> NonDetFastString -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> NonDetFastString -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d)
    -> NonDetFastString -> m NonDetFastString)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> NonDetFastString -> m NonDetFastString)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> NonDetFastString -> m NonDetFastString)
-> Data NonDetFastString
NonDetFastString -> Constr
NonDetFastString -> DataType
(forall b. Data b => b -> b)
-> NonDetFastString -> NonDetFastString
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u.
Int -> (forall d. Data d => d -> u) -> NonDetFastString -> u
forall u. (forall d. Data d => d -> u) -> NonDetFastString -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> NonDetFastString -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> NonDetFastString -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> NonDetFastString -> m NonDetFastString
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> NonDetFastString -> m NonDetFastString
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c NonDetFastString
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> NonDetFastString -> c NonDetFastString
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c NonDetFastString)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c NonDetFastString)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> NonDetFastString -> c NonDetFastString
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> NonDetFastString -> c NonDetFastString
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c NonDetFastString
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c NonDetFastString
$ctoConstr :: NonDetFastString -> Constr
toConstr :: NonDetFastString -> Constr
$cdataTypeOf :: NonDetFastString -> DataType
dataTypeOf :: NonDetFastString -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c NonDetFastString)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c NonDetFastString)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c NonDetFastString)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c NonDetFastString)
$cgmapT :: (forall b. Data b => b -> b)
-> NonDetFastString -> NonDetFastString
gmapT :: (forall b. Data b => b -> b)
-> NonDetFastString -> NonDetFastString
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> NonDetFastString -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> NonDetFastString -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> NonDetFastString -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> NonDetFastString -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> NonDetFastString -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> NonDetFastString -> [u]
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> NonDetFastString -> u
gmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> NonDetFastString -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> NonDetFastString -> m NonDetFastString
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> NonDetFastString -> m NonDetFastString
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> NonDetFastString -> m NonDetFastString
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> NonDetFastString -> m NonDetFastString
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> NonDetFastString -> m NonDetFastString
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> NonDetFastString -> m NonDetFastString
Data

instance Ord NonDetFastString where
   compare :: NonDetFastString -> NonDetFastString -> Ordering
compare (NonDetFastString FastString
fs1) (NonDetFastString FastString
fs2) = FastString -> FastString -> Ordering
uniqCompareFS FastString
fs1 FastString
fs2

-- | Lexical FastString
--
-- This is a simple FastString wrapper with an Ord instance using
-- `lexicalCompareFS` (i.e. which compares FastStrings on their String
-- representation). Hence it is deterministic from one run to the other.
newtype LexicalFastString
   = LexicalFastString { LexicalFastString -> FastString
getLexicalFastString :: FastString }
   deriving newtype (LexicalFastString -> LexicalFastString -> Bool
(LexicalFastString -> LexicalFastString -> Bool)
-> (LexicalFastString -> LexicalFastString -> Bool)
-> Eq LexicalFastString
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LexicalFastString -> LexicalFastString -> Bool
== :: LexicalFastString -> LexicalFastString -> Bool
$c/= :: LexicalFastString -> LexicalFastString -> Bool
/= :: LexicalFastString -> LexicalFastString -> Bool
Eq, Int -> LexicalFastString -> ShowS
[LexicalFastString] -> ShowS
LexicalFastString -> String
(Int -> LexicalFastString -> ShowS)
-> (LexicalFastString -> String)
-> ([LexicalFastString] -> ShowS)
-> Show LexicalFastString
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LexicalFastString -> ShowS
showsPrec :: Int -> LexicalFastString -> ShowS
$cshow :: LexicalFastString -> String
show :: LexicalFastString -> String
$cshowList :: [LexicalFastString] -> ShowS
showList :: [LexicalFastString] -> ShowS
Show)
   deriving stock Typeable LexicalFastString
Typeable LexicalFastString =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g)
 -> LexicalFastString
 -> c LexicalFastString)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c LexicalFastString)
-> (LexicalFastString -> Constr)
-> (LexicalFastString -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c LexicalFastString))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c LexicalFastString))
-> ((forall b. Data b => b -> b)
    -> LexicalFastString -> LexicalFastString)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> LexicalFastString -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> LexicalFastString -> r)
-> (forall u.
    (forall d. Data d => d -> u) -> LexicalFastString -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> LexicalFastString -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d)
    -> LexicalFastString -> m LexicalFastString)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> LexicalFastString -> m LexicalFastString)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> LexicalFastString -> m LexicalFastString)
-> Data LexicalFastString
LexicalFastString -> Constr
LexicalFastString -> DataType
(forall b. Data b => b -> b)
-> LexicalFastString -> LexicalFastString
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u.
Int -> (forall d. Data d => d -> u) -> LexicalFastString -> u
forall u. (forall d. Data d => d -> u) -> LexicalFastString -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> LexicalFastString -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> LexicalFastString -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> LexicalFastString -> m LexicalFastString
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> LexicalFastString -> m LexicalFastString
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c LexicalFastString
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> LexicalFastString -> c LexicalFastString
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c LexicalFastString)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c LexicalFastString)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> LexicalFastString -> c LexicalFastString
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> LexicalFastString -> c LexicalFastString
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c LexicalFastString
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c LexicalFastString
$ctoConstr :: LexicalFastString -> Constr
toConstr :: LexicalFastString -> Constr
$cdataTypeOf :: LexicalFastString -> DataType
dataTypeOf :: LexicalFastString -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c LexicalFastString)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c LexicalFastString)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c LexicalFastString)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c LexicalFastString)
$cgmapT :: (forall b. Data b => b -> b)
-> LexicalFastString -> LexicalFastString
gmapT :: (forall b. Data b => b -> b)
-> LexicalFastString -> LexicalFastString
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> LexicalFastString -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> LexicalFastString -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> LexicalFastString -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> LexicalFastString -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> LexicalFastString -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> LexicalFastString -> [u]
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> LexicalFastString -> u
gmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> LexicalFastString -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> LexicalFastString -> m LexicalFastString
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> LexicalFastString -> m LexicalFastString
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> LexicalFastString -> m LexicalFastString
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> LexicalFastString -> m LexicalFastString
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> LexicalFastString -> m LexicalFastString
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> LexicalFastString -> m LexicalFastString
Data

instance Ord LexicalFastString where
   compare :: LexicalFastString -> LexicalFastString -> Ordering
compare (LexicalFastString FastString
fs1) (LexicalFastString FastString
fs2) = FastString -> FastString -> Ordering
lexicalCompareFS FastString
fs1 FastString
fs2

instance NFData LexicalFastString where
  rnf :: LexicalFastString -> ()
rnf (LexicalFastString FastString
f) = FastString -> ()
forall a. NFData a => a -> ()
rnf FastString
f

-- -----------------------------------------------------------------------------
-- Construction

{-
Internally, the compiler will maintain a fast string symbol table, providing
sharing and fast comparison. Creation of new @FastString@s then covertly does a
lookup, re-using the @FastString@ if there was a hit.

The design of the FastString hash table allows for lockless concurrent reads
and updates to multiple buckets with low synchronization overhead.

See Note [Updating the FastString table] on how it's updated.
-}
data FastStringTable = FastStringTable
  {-# UNPACK #-} !FastMutInt
  -- ^ The unique ID counter shared with all buckets
  --
  -- We unpack the 'FastMutInt' counter as it is always consumed strictly.
  {-# NOUNPACK #-} !FastMutInt
  -- ^ Number of computed z-encodings for all buckets.
  --
  -- We mark this as 'NOUNPACK' as this 'FastMutInt' is retained by a thunk
  -- in 'mkFastStringWith' and needs to be boxed any way.
  -- If this is unpacked, then we box this single 'FastMutInt' once for each
  -- allocated FastString.
  (Array# (IORef FastStringTableSegment)) -- ^  concurrent segments

data FastStringTableSegment = FastStringTableSegment
  {-# UNPACK #-} !(MVar ())  -- the lock for write in each segment
  {-# UNPACK #-} !FastMutInt -- the number of elements
  (MutableArray# RealWorld [FastString]) -- buckets in this segment

{-
Following parameters are determined based on:

* Benchmark based on testsuite/tests/utils/should_run/T14854.hs
* Stats of @echo :browse | ghc --interactive -dfaststring-stats >/dev/null@:
  on 2018-10-24, we have 13920 entries.
-}
segmentBits, numSegments, segmentMask, initialNumBuckets :: Int
segmentBits :: Int
segmentBits = Int
8
numSegments :: Int
numSegments = Int
256   -- bit segmentBits
segmentMask :: Int
segmentMask = Int
0xff  -- bit segmentBits - 1
initialNumBuckets :: Int
initialNumBuckets = Int
64

hashToSegment# :: Int# -> Int#
hashToSegment# :: Int# -> Int#
hashToSegment# Int#
hash# = Int#
hash# Int# -> Int# -> Int#
`andI#` Int#
segmentMask#
  where
    !(I# Int#
segmentMask#) = Int
segmentMask

hashToIndex# :: MutableArray# RealWorld [FastString] -> Int# -> Int#
hashToIndex# :: MutableArray# RealWorld [FastString] -> Int# -> Int#
hashToIndex# MutableArray# RealWorld [FastString]
buckets# Int#
hash# =
  (Int#
hash# Int# -> Int# -> Int#
`uncheckedIShiftRL#` Int#
segmentBits#) Int# -> Int# -> Int#
`remInt#` Int#
size#
  where
    !(I# Int#
segmentBits#) = Int
segmentBits
    size# :: Int#
size# = MutableArray# RealWorld [FastString] -> Int#
forall d a. MutableArray# d a -> Int#
sizeofMutableArray# MutableArray# RealWorld [FastString]
buckets#

maybeResizeSegment :: IORef FastStringTableSegment -> IO FastStringTableSegment
maybeResizeSegment :: IORef FastStringTableSegment -> IO FastStringTableSegment
maybeResizeSegment IORef FastStringTableSegment
segmentRef = do
  segment@(FastStringTableSegment lock counter old#) <- IORef FastStringTableSegment -> IO FastStringTableSegment
forall a. IORef a -> IO a
readIORef IORef FastStringTableSegment
segmentRef
  let oldSize# = MutableArray# RealWorld [FastString] -> Int#
forall d a. MutableArray# d a -> Int#
sizeofMutableArray# MutableArray# RealWorld [FastString]
old#
      newSize# = Int#
oldSize# Int# -> Int# -> Int#
*# Int#
2#
  (I# n#) <- readFastMutInt counter
  if isTrue# (n# <# newSize#) -- maximum load of 1
  then return segment
  else do
    resizedSegment@(FastStringTableSegment _ _ new#) <- IO $ \State# RealWorld
s1# ->
      case Int#
-> [FastString]
-> State# RealWorld
-> (# State# RealWorld, MutableArray# RealWorld [FastString] #)
forall a d.
Int# -> a -> State# d -> (# State# d, MutableArray# d a #)
newArray# Int#
newSize# [] State# RealWorld
s1# of
        (# State# RealWorld
s2#, MutableArray# RealWorld [FastString]
arr# #) -> (# State# RealWorld
s2#, MVar ()
-> FastMutInt
-> MutableArray# RealWorld [FastString]
-> FastStringTableSegment
FastStringTableSegment MVar ()
lock FastMutInt
counter MutableArray# RealWorld [FastString]
arr# #)
    forM_ [0 .. (I# oldSize#) - 1] $ \(I# Int#
i#) -> do
      fsList <- (State# RealWorld -> (# State# RealWorld, [FastString] #))
-> IO [FastString]
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, [FastString] #))
 -> IO [FastString])
-> (State# RealWorld -> (# State# RealWorld, [FastString] #))
-> IO [FastString]
forall a b. (a -> b) -> a -> b
$ MutableArray# RealWorld [FastString]
-> Int# -> State# RealWorld -> (# State# RealWorld, [FastString] #)
forall d a.
MutableArray# d a -> Int# -> State# d -> (# State# d, a #)
readArray# MutableArray# RealWorld [FastString]
old# Int#
i#
      forM_ fsList $ \FastString
fs -> do
        let -- Shall we store in hash value in FastString instead?
            !(I# Int#
hash#) = FastString -> Int
hashFastString FastString
fs
            idx# :: Int#
idx# = MutableArray# RealWorld [FastString] -> Int# -> Int#
hashToIndex# MutableArray# RealWorld [FastString]
new# Int#
hash#
        (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, () #)) -> IO ())
-> (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s1# ->
          case MutableArray# RealWorld [FastString]
-> Int# -> State# RealWorld -> (# State# RealWorld, [FastString] #)
forall d a.
MutableArray# d a -> Int# -> State# d -> (# State# d, a #)
readArray# MutableArray# RealWorld [FastString]
new# Int#
idx# State# RealWorld
s1# of
            (# State# RealWorld
s2#, [FastString]
bucket #) -> case MutableArray# RealWorld [FastString]
-> Int# -> [FastString] -> State# RealWorld -> State# RealWorld
forall d a. MutableArray# d a -> Int# -> a -> State# d -> State# d
writeArray# MutableArray# RealWorld [FastString]
new# Int#
idx# (FastString
fsFastString -> [FastString] -> [FastString]
forall a. a -> [a] -> [a]
: [FastString]
bucket) State# RealWorld
s2# of
              State# RealWorld
s3# -> (# State# RealWorld
s3#, () #)
    writeIORef segmentRef resizedSegment
    return resizedSegment

{-# NOINLINE stringTable #-}
stringTable :: FastStringTable
stringTable :: FastStringTable
stringTable = IO FastStringTable -> FastStringTable
forall a. IO a -> a
unsafePerformIO (IO FastStringTable -> FastStringTable)
-> IO FastStringTable -> FastStringTable
forall a b. (a -> b) -> a -> b
$ do
  let !(I# Int#
numSegments#) = Int
numSegments
      !(I# Int#
initialNumBuckets#) = Int
initialNumBuckets
      loop :: MutableArray# RealWorld (IORef FastStringTableSegment)
-> Int# -> State# RealWorld -> State# RealWorld
loop MutableArray# RealWorld (IORef FastStringTableSegment)
a# Int#
i# State# RealWorld
s1#
        | Int# -> Bool
isTrue# (Int#
i# Int# -> Int# -> Int#
==# Int#
numSegments#) = State# RealWorld
s1#
        | Bool
otherwise = case () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar () IO (MVar ()) -> State# RealWorld -> (# State# RealWorld, MVar () #)
forall a. IO a -> State# RealWorld -> (# State# RealWorld, a #)
`unIO` State# RealWorld
s1# of
            (# State# RealWorld
s2#, MVar ()
lock #) -> case Int -> IO FastMutInt
newFastMutInt Int
0 IO FastMutInt
-> State# RealWorld -> (# State# RealWorld, FastMutInt #)
forall a. IO a -> State# RealWorld -> (# State# RealWorld, a #)
`unIO` State# RealWorld
s2# of
              (# State# RealWorld
s3#, FastMutInt
counter #) -> case Int#
-> [FastString]
-> State# RealWorld
-> (# State# RealWorld, MutableArray# RealWorld [FastString] #)
forall a d.
Int# -> a -> State# d -> (# State# d, MutableArray# d a #)
newArray# Int#
initialNumBuckets# [] State# RealWorld
s3# of
                (# State# RealWorld
s4#, MutableArray# RealWorld [FastString]
buckets# #) -> case FastStringTableSegment -> IO (IORef FastStringTableSegment)
forall a. a -> IO (IORef a)
newIORef
                    (MVar ()
-> FastMutInt
-> MutableArray# RealWorld [FastString]
-> FastStringTableSegment
FastStringTableSegment MVar ()
lock FastMutInt
counter MutableArray# RealWorld [FastString]
buckets#) IO (IORef FastStringTableSegment)
-> State# RealWorld
-> (# State# RealWorld, IORef FastStringTableSegment #)
forall a. IO a -> State# RealWorld -> (# State# RealWorld, a #)
`unIO` State# RealWorld
s4# of
                  (# State# RealWorld
s5#, IORef FastStringTableSegment
segment #) -> case MutableArray# RealWorld (IORef FastStringTableSegment)
-> Int#
-> IORef FastStringTableSegment
-> State# RealWorld
-> State# RealWorld
forall d a. MutableArray# d a -> Int# -> a -> State# d -> State# d
writeArray# MutableArray# RealWorld (IORef FastStringTableSegment)
a# Int#
i# IORef FastStringTableSegment
segment State# RealWorld
s5# of
                    State# RealWorld
s6# -> MutableArray# RealWorld (IORef FastStringTableSegment)
-> Int# -> State# RealWorld -> State# RealWorld
loop MutableArray# RealWorld (IORef FastStringTableSegment)
a# (Int#
i# Int# -> Int# -> Int#
+# Int#
1#) State# RealWorld
s6#
  uid <- Int -> IO FastMutInt
newFastMutInt Int
603979776 -- ord '$' * 0x01000000
  n_zencs <- newFastMutInt 0
  tab <- IO $ \State# RealWorld
s1# ->
    case Int#
-> IORef FastStringTableSegment
-> State# RealWorld
-> (# State# RealWorld,
      MutableArray# RealWorld (IORef FastStringTableSegment) #)
forall a d.
Int# -> a -> State# d -> (# State# d, MutableArray# d a #)
newArray# Int#
numSegments# (String -> IORef FastStringTableSegment
forall a. HasCallStack => String -> a
panic String
"string_table") State# RealWorld
s1# of
      (# State# RealWorld
s2#, MutableArray# RealWorld (IORef FastStringTableSegment)
arr# #) -> case MutableArray# RealWorld (IORef FastStringTableSegment)
-> Int# -> State# RealWorld -> State# RealWorld
loop MutableArray# RealWorld (IORef FastStringTableSegment)
arr# Int#
0# State# RealWorld
s2# of
        State# RealWorld
s3# -> case MutableArray# RealWorld (IORef FastStringTableSegment)
-> State# RealWorld
-> (# State# RealWorld, Array# (IORef FastStringTableSegment) #)
forall d a.
MutableArray# d a -> State# d -> (# State# d, Array# a #)
unsafeFreezeArray# MutableArray# RealWorld (IORef FastStringTableSegment)
arr# State# RealWorld
s3# of
          (# State# RealWorld
s4#, Array# (IORef FastStringTableSegment)
segments# #) ->
            (# State# RealWorld
s4#, FastMutInt
-> FastMutInt
-> Array# (IORef FastStringTableSegment)
-> FastStringTable
FastStringTable FastMutInt
uid FastMutInt
n_zencs Array# (IORef FastStringTableSegment)
segments# #)

  -- use the support wired into the RTS to share this CAF among all images of
  -- libHSghc
#if !MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)
  return tab
#else
  sharedCAF tab getOrSetLibHSghcFastStringTable

-- from the 9.3 RTS; the previous RTS before might not have this symbol.  The
-- right way to do this however would be to define some HAVE_FAST_STRING_TABLE
-- or similar rather than use (odd parity) development versions.
foreign import ccall unsafe "getOrSetLibHSghcFastStringTable"
  getOrSetLibHSghcFastStringTable :: Ptr a -> IO (Ptr a)
#endif

{-

We include the FastString table in the `sharedCAF` mechanism because we'd like
FastStrings created by a Core plugin to have the same uniques as corresponding
strings created by the host compiler itself.  For example, this allows plugins
to lookup known names (eg `mkTcOcc "MySpecialType"`) in the GlobalRdrEnv or
even re-invoke the parser.

In particular, the following little sanity test was failing in a plugin
prototyping safe newtype-coercions: GHC.NT.Type.NT was imported, but could not
be looked up /by the plugin/.

   let rdrName = mkModuleName "GHC.NT.Type" `mkRdrQual` mkTcOcc "NT"
   putMsgS $ showSDoc dflags $ ppr $
     lookupGRE (mg_rdr_env guts) (LookupRdrName rdrName AllRelevantGREs)

`mkTcOcc` involves the lookup (or creation) of a FastString.  Since the
plugin's FastString.string_table is empty, constructing the RdrName also
allocates new uniques for the FastStrings "GHC.NT.Type" and "NT".  These
uniques are almost certainly unequal to the ones that the host compiler
originally assigned to those FastStrings.  Thus the lookup fails since the
domain of the GlobalRdrEnv is affected by the RdrName's OccName's FastString's
unique.

Maintaining synchronization of the two instances of this global is rather
difficult because of the uses of `unsafePerformIO` in this module.  Not
synchronizing them risks breaking the rather major invariant that two
FastStrings with the same unique have the same string. Thus we use the
lower-level `sharedCAF` mechanism that relies on Globals.c.

-}

mkFastString# :: Addr# -> FastString
{-# INLINE mkFastString# #-}
mkFastString# :: Addr# -> FastString
mkFastString# Addr#
a# = Ptr Word8 -> Int -> FastString
mkFastStringBytes Ptr Word8
ptr (Ptr Word8 -> Int
ptrStrLength Ptr Word8
ptr)
  where ptr :: Ptr Word8
ptr = Addr# -> Ptr Word8
forall a. Addr# -> Ptr a
Ptr Addr#
a#

{- Note [Updating the FastString table]
   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We use a concurrent hashtable which contains multiple segments, each hash value
always maps to the same segment. Read is lock-free, write to the a segment
should acquire a lock for that segment to avoid race condition, writes to
different segments are independent.

The procedure goes like this:

1. Find out which segment to operate on based on the hash value
2. Read the relevant bucket and perform a look up of the string.
3. If it exists, return it.
4. Otherwise grab a unique ID, create a new FastString and atomically attempt
   to update the relevant segment with this FastString:

   * Resize the segment by doubling the number of buckets when the number of
     FastStrings in this segment grows beyond the threshold.
   * Double check that the string is not in the bucket. Another thread may have
     inserted it while we were creating our string.
   * Return the existing FastString if it exists. The one we preemptively
     created will get GCed.
   * Otherwise, insert and return the string we created.
-}

mkFastStringWith
    :: (Int -> FastMutInt-> IO FastString) -> ShortByteString -> IO FastString
mkFastStringWith :: (Int -> FastMutInt -> IO FastString)
-> ShortByteString -> IO FastString
mkFastStringWith Int -> FastMutInt -> IO FastString
mk_fs ShortByteString
sbs = do
  FastStringTableSegment lock _ buckets# <- IORef FastStringTableSegment -> IO FastStringTableSegment
forall a. IORef a -> IO a
readIORef IORef FastStringTableSegment
segmentRef
  let idx# = MutableArray# RealWorld [FastString] -> Int# -> Int#
hashToIndex# MutableArray# RealWorld [FastString]
buckets# Int#
hash#
  bucket <- IO $ readArray# buckets# idx#
  case bucket_match bucket sbs of
    Just FastString
found -> FastString -> IO FastString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FastString
found
    Maybe FastString
Nothing -> do
      -- The withMVar below is not dupable. It can lead to deadlock if it is
      -- only run partially and putMVar is not called after takeMVar.
      IO ()
noDuplicate
      n <- IO Int
get_uid
      new_fs <- mk_fs n n_zencs
      withMVar lock $ \()
_ -> FastString -> IO FastString
insert FastString
new_fs
  where
    !(FastStringTable FastMutInt
uid FastMutInt
n_zencs Array# (IORef FastStringTableSegment)
segments#) = FastStringTable
stringTable
    get_uid :: IO Int
get_uid = FastMutInt -> Int -> IO Int
atomicFetchAddFastMut FastMutInt
uid Int
1

    !(I# Int#
hash#) = ShortByteString -> Int
hashStr ShortByteString
sbs
    (# IORef FastStringTableSegment
segmentRef #) = Array# (IORef FastStringTableSegment)
-> Int# -> (# IORef FastStringTableSegment #)
forall a. Array# a -> Int# -> (# a #)
indexArray# Array# (IORef FastStringTableSegment)
segments# (Int# -> Int#
hashToSegment# Int#
hash#)
    insert :: FastString -> IO FastString
insert FastString
fs = do
      FastStringTableSegment _ counter buckets# <- IORef FastStringTableSegment -> IO FastStringTableSegment
maybeResizeSegment IORef FastStringTableSegment
segmentRef
      let idx# = MutableArray# RealWorld [FastString] -> Int# -> Int#
hashToIndex# MutableArray# RealWorld [FastString]
buckets# Int#
hash#
      bucket <- IO $ readArray# buckets# idx#
      case bucket_match bucket sbs of
        -- The FastString was added by another thread after previous read and
        -- before we acquired the write lock.
        Just FastString
found -> FastString -> IO FastString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FastString
found
        Maybe FastString
Nothing -> do
          (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, () #)) -> IO ())
-> (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s1# ->
            case MutableArray# RealWorld [FastString]
-> Int# -> [FastString] -> State# RealWorld -> State# RealWorld
forall d a. MutableArray# d a -> Int# -> a -> State# d -> State# d
writeArray# MutableArray# RealWorld [FastString]
buckets# Int#
idx# (FastString
fs FastString -> [FastString] -> [FastString]
forall a. a -> [a] -> [a]
: [FastString]
bucket) State# RealWorld
s1# of
              State# RealWorld
s2# -> (# State# RealWorld
s2#, () #)
          _ <- FastMutInt -> Int -> IO Int
atomicFetchAddFastMut FastMutInt
counter Int
1
          return fs

bucket_match :: [FastString] -> ShortByteString -> Maybe FastString
bucket_match :: [FastString] -> ShortByteString -> Maybe FastString
bucket_match [FastString]
fs ShortByteString
sbs = [FastString] -> Maybe FastString
go [FastString]
fs
  where go :: [FastString] -> Maybe FastString
go [] = Maybe FastString
forall a. Maybe a
Nothing
        go (fs :: FastString
fs@(FastString {fs_sbs :: FastString -> ShortByteString
fs_sbs=ShortByteString
fs_sbs}) : [FastString]
ls)
          | ShortByteString
fs_sbs ShortByteString -> ShortByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ShortByteString
sbs = FastString -> Maybe FastString
forall a. a -> Maybe a
Just FastString
fs
          | Bool
otherwise     = [FastString] -> Maybe FastString
go [FastString]
ls
-- bucket_match used to inline before changes to instance Eq ShortByteString
-- in bytestring-0.12, which made it slightly larger than inlining threshold.
-- Non-inlining causes a small, but measurable performance regression, so let's force it.
{-# INLINE bucket_match #-}

mkFastStringBytes :: Ptr Word8 -> Int -> FastString
mkFastStringBytes :: Ptr Word8 -> Int -> FastString
mkFastStringBytes !Ptr Word8
ptr !Int
len =
    -- NB: Might as well use unsafeDupablePerformIO, since mkFastStringWith is
    -- idempotent.
    IO FastString -> FastString
forall a. IO a -> a
unsafeDupablePerformIO (IO FastString -> FastString) -> IO FastString -> FastString
forall a b. (a -> b) -> a -> b
$ do
        sbs <- Ptr Word8 -> Int -> IO ShortByteString
forall a. Ptr a -> Int -> IO ShortByteString
newSBSFromPtr Ptr Word8
ptr Int
len
        mkFastStringWith (mkNewFastStringShortByteString sbs) sbs

newSBSFromPtr :: Ptr a -> Int -> IO ShortByteString
newSBSFromPtr :: forall a. Ptr a -> Int -> IO ShortByteString
newSBSFromPtr (Ptr Addr#
src#) (I# Int#
len#) =
  (State# RealWorld -> (# State# RealWorld, ShortByteString #))
-> IO ShortByteString
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, ShortByteString #))
 -> IO ShortByteString)
-> (State# RealWorld -> (# State# RealWorld, ShortByteString #))
-> IO ShortByteString
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
    case Int#
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newByteArray# Int#
len# State# RealWorld
s of { (# State# RealWorld
s, MutableByteArray# RealWorld
dst# #) ->
    case Addr#
-> MutableByteArray# RealWorld
-> Int#
-> Int#
-> State# RealWorld
-> State# RealWorld
forall d.
Addr#
-> MutableByteArray# d -> Int# -> Int# -> State# d -> State# d
copyAddrToByteArray# Addr#
src# MutableByteArray# RealWorld
dst# Int#
0# Int#
len# State# RealWorld
s of { State# RealWorld
s ->
    case MutableByteArray# RealWorld
-> State# RealWorld -> (# State# RealWorld, ByteArray# #)
forall d.
MutableByteArray# d -> State# d -> (# State# d, ByteArray# #)
unsafeFreezeByteArray# MutableByteArray# RealWorld
dst# State# RealWorld
s of { (# State# RealWorld
s, ByteArray#
ba# #) ->
    (# State# RealWorld
s, ByteArray# -> ShortByteString
SBS.SBS ByteArray#
ba# #) }}}

-- | Create a 'FastString' by copying an existing 'ByteString'
mkFastStringByteString :: ByteString -> FastString
mkFastStringByteString :: ByteString -> FastString
mkFastStringByteString ByteString
bs =
  let sbs :: ShortByteString
sbs = ByteString -> ShortByteString
SBS.toShort ByteString
bs in
  IO FastString -> FastString
forall a. IO a -> a
inlinePerformIO (IO FastString -> FastString) -> IO FastString -> FastString
forall a b. (a -> b) -> a -> b
$
      (Int -> FastMutInt -> IO FastString)
-> ShortByteString -> IO FastString
mkFastStringWith (ShortByteString -> Int -> FastMutInt -> IO FastString
mkNewFastStringShortByteString ShortByteString
sbs) ShortByteString
sbs

-- | Create a 'FastString' from an existing 'ShortByteString' without
-- copying.
mkFastStringShortByteString :: ShortByteString -> FastString
mkFastStringShortByteString :: ShortByteString -> FastString
mkFastStringShortByteString ShortByteString
sbs =
  IO FastString -> FastString
forall a. IO a -> a
inlinePerformIO (IO FastString -> FastString) -> IO FastString -> FastString
forall a b. (a -> b) -> a -> b
$ (Int -> FastMutInt -> IO FastString)
-> ShortByteString -> IO FastString
mkFastStringWith (ShortByteString -> Int -> FastMutInt -> IO FastString
mkNewFastStringShortByteString ShortByteString
sbs) ShortByteString
sbs

-- | Creates a UTF-8 encoded 'FastString' from a 'String'
mkFastString :: String -> FastString
{-# NOINLINE[1] mkFastString #-}
mkFastString :: String -> FastString
mkFastString String
str =
  IO FastString -> FastString
forall a. IO a -> a
inlinePerformIO (IO FastString -> FastString) -> IO FastString -> FastString
forall a b. (a -> b) -> a -> b
$ do
    let !sbs :: ShortByteString
sbs = String -> ShortByteString
utf8EncodeShortByteString String
str
    (Int -> FastMutInt -> IO FastString)
-> ShortByteString -> IO FastString
mkFastStringWith (ShortByteString -> Int -> FastMutInt -> IO FastString
mkNewFastStringShortByteString ShortByteString
sbs) ShortByteString
sbs

-- The following rule is used to avoid polluting the non-reclaimable FastString
-- table with transient strings when we only want their encoding.
{-# RULES
"bytesFS/mkFastString" forall x. bytesFS (mkFastString x) = utf8EncodeByteString x #-}

-- | Creates a 'FastString' from a UTF-8 encoded @[Word8]@
mkFastStringByteList :: [Word8] -> FastString
mkFastStringByteList :: [Word8] -> FastString
mkFastStringByteList [Word8]
str = ShortByteString -> FastString
mkFastStringShortByteString ([Word8] -> ShortByteString
SBS.pack [Word8]
str)

-- | Creates a (lazy) Z-encoded 'FastString' from a 'ShortByteString' and
-- account the number of forced z-strings into the passed 'FastMutInt'.
mkZFastString :: FastMutInt -> ShortByteString -> FastZString
mkZFastString :: FastMutInt -> ShortByteString -> FastZString
mkZFastString FastMutInt
n_zencs ShortByteString
sbs = IO FastZString -> FastZString
forall a. IO a -> a
unsafePerformIO (IO FastZString -> FastZString) -> IO FastZString -> FastZString
forall a b. (a -> b) -> a -> b
$ do
  _ <- FastMutInt -> Int -> IO Int
atomicFetchAddFastMut FastMutInt
n_zencs Int
1
  return $ mkFastZStringString (zEncodeString (utf8DecodeShortByteString sbs))

mkNewFastStringShortByteString :: ShortByteString -> Int
                               -> FastMutInt -> IO FastString
mkNewFastStringShortByteString :: ShortByteString -> Int -> FastMutInt -> IO FastString
mkNewFastStringShortByteString ShortByteString
sbs Int
uid FastMutInt
n_zencs = do
  let zstr :: FastZString
zstr = FastMutInt -> ShortByteString -> FastZString
mkZFastString FastMutInt
n_zencs ShortByteString
sbs
      chars :: Int
chars = ShortByteString -> Int
utf8CountCharsShortByteString ShortByteString
sbs
  FastString -> IO FastString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Int -> ShortByteString -> FastZString -> FastString
FastString Int
uid Int
chars ShortByteString
sbs FastZString
zstr)

hashStr  :: ShortByteString -> Int
 -- produce a hash value between 0 & m (inclusive)
hashStr :: ShortByteString -> Int
hashStr sbs :: ShortByteString
sbs@(SBS.SBS ByteArray#
ba#) = Int# -> Int# -> Int
loop Int#
0# Int#
0#
   where
    !(I# Int#
len#) = ShortByteString -> Int
SBS.length ShortByteString
sbs
    loop :: Int# -> Int# -> Int
loop Int#
h Int#
n =
      if Int# -> Bool
isTrue# (Int#
n Int# -> Int# -> Int#
==# Int#
len#) then
        Int# -> Int
I# Int#
h
      else
        let
          -- DO NOT move this let binding! indexCharOffAddr# reads from the
          -- pointer so we need to evaluate this based on the length check
          -- above. Not doing this right caused #17909.
          !c :: Int#
c = Int8# -> Int#
int8ToInt# (ByteArray# -> Int# -> Int8#
indexInt8Array# ByteArray#
ba# Int#
n)
          !h2 :: Int#
h2 = (Int#
h Int# -> Int# -> Int#
*# Int#
16777619#) Int# -> Int# -> Int#
`xorI#` Int#
c
        in
          Int# -> Int# -> Int
loop Int#
h2 (Int#
n Int# -> Int# -> Int#
+# Int#
1#)

-- -----------------------------------------------------------------------------
-- Operations

-- | Returns the length of the 'FastString' in characters
lengthFS :: FastString -> Int
lengthFS :: FastString -> Int
lengthFS FastString
fs = FastString -> Int
n_chars FastString
fs

-- | Returns @True@ if the 'FastString' is empty
nullFS :: FastString -> Bool
nullFS :: FastString -> Bool
nullFS FastString
fs = ShortByteString -> Bool
SBS.null (ShortByteString -> Bool) -> ShortByteString -> Bool
forall a b. (a -> b) -> a -> b
$ FastString -> ShortByteString
fs_sbs FastString
fs

-- | Lazily unpacks and decodes the FastString
unpackFS :: FastString -> String
unpackFS :: FastString -> String
unpackFS FastString
fs = ShortByteString -> String
utf8DecodeShortByteString (ShortByteString -> String) -> ShortByteString -> String
forall a b. (a -> b) -> a -> b
$ FastString -> ShortByteString
fs_sbs FastString
fs

-- | Returns a Z-encoded version of a 'FastString'.  This might be the
-- original, if it was already Z-encoded.  The first time this
-- function is applied to a particular 'FastString', the results are
-- memoized.
--
zEncodeFS :: FastString -> FastZString
zEncodeFS :: FastString -> FastZString
zEncodeFS FastString
fs = FastString -> FastZString
fs_zenc FastString
fs

appendFS :: FastString -> FastString -> FastString
appendFS :: FastString -> FastString -> FastString
appendFS FastString
fs1 FastString
fs2 = ShortByteString -> FastString
mkFastStringShortByteString
                 (ShortByteString -> FastString) -> ShortByteString -> FastString
forall a b. (a -> b) -> a -> b
$ ShortByteString -> ShortByteString -> ShortByteString
forall a. Semigroup a => a -> a -> a
(Semi.<>) (FastString -> ShortByteString
fs_sbs FastString
fs1) (FastString -> ShortByteString
fs_sbs FastString
fs2)

concatFS :: [FastString] -> FastString
concatFS :: [FastString] -> FastString
concatFS = ShortByteString -> FastString
mkFastStringShortByteString (ShortByteString -> FastString)
-> ([FastString] -> ShortByteString) -> [FastString] -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ShortByteString] -> ShortByteString
forall a. Monoid a => [a] -> a
mconcat ([ShortByteString] -> ShortByteString)
-> ([FastString] -> [ShortByteString])
-> [FastString]
-> ShortByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FastString -> ShortByteString)
-> [FastString] -> [ShortByteString]
forall a b. (a -> b) -> [a] -> [b]
map FastString -> ShortByteString
fs_sbs

consFS :: Char -> FastString -> FastString
consFS :: Char -> FastString -> FastString
consFS Char
c FastString
fs = String -> FastString
mkFastString (Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: FastString -> String
unpackFS FastString
fs)

unconsFS :: FastString -> Maybe (Char, FastString)
unconsFS :: FastString -> Maybe (Char, FastString)
unconsFS FastString
fs =
  case FastString -> String
unpackFS FastString
fs of
    []          -> Maybe (Char, FastString)
forall a. Maybe a
Nothing
    (Char
chr : String
str) -> (Char, FastString) -> Maybe (Char, FastString)
forall a. a -> Maybe a
Just (Char
chr, String -> FastString
mkFastString String
str)

uniqueOfFS :: FastString -> Int
uniqueOfFS :: FastString -> Int
uniqueOfFS FastString
fs = FastString -> Int
uniq FastString
fs

nilFS :: FastString
nilFS :: FastString
nilFS = String -> FastString
mkFastString String
""

-- -----------------------------------------------------------------------------
-- Stats

getFastStringTable :: IO [[[FastString]]]
getFastStringTable :: IO [[[FastString]]]
getFastStringTable =
  [Int] -> (Int -> IO [[FastString]]) -> IO [[[FastString]]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
0 .. Int
numSegments Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> IO [[FastString]]) -> IO [[[FastString]]])
-> (Int -> IO [[FastString]]) -> IO [[[FastString]]]
forall a b. (a -> b) -> a -> b
$ \(I# Int#
i#) -> do
    let (# IORef FastStringTableSegment
segmentRef #) = Array# (IORef FastStringTableSegment)
-> Int# -> (# IORef FastStringTableSegment #)
forall a. Array# a -> Int# -> (# a #)
indexArray# Array# (IORef FastStringTableSegment)
segments# Int#
i#
    FastStringTableSegment _ _ buckets# <- IORef FastStringTableSegment -> IO FastStringTableSegment
forall a. IORef a -> IO a
readIORef IORef FastStringTableSegment
segmentRef
    let bucketSize = Int# -> Int
I# (MutableArray# RealWorld [FastString] -> Int#
forall d a. MutableArray# d a -> Int#
sizeofMutableArray# MutableArray# RealWorld [FastString]
buckets#)
    forM [0 .. bucketSize - 1] $ \(I# Int#
j#) ->
      (State# RealWorld -> (# State# RealWorld, [FastString] #))
-> IO [FastString]
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, [FastString] #))
 -> IO [FastString])
-> (State# RealWorld -> (# State# RealWorld, [FastString] #))
-> IO [FastString]
forall a b. (a -> b) -> a -> b
$ MutableArray# RealWorld [FastString]
-> Int# -> State# RealWorld -> (# State# RealWorld, [FastString] #)
forall d a.
MutableArray# d a -> Int# -> State# d -> (# State# d, a #)
readArray# MutableArray# RealWorld [FastString]
buckets# Int#
j#
  where
    !(FastStringTable FastMutInt
_ FastMutInt
_ Array# (IORef FastStringTableSegment)
segments#) = FastStringTable
stringTable

getFastStringZEncCounter :: IO Int
getFastStringZEncCounter :: IO Int
getFastStringZEncCounter = FastMutInt -> IO Int
readFastMutInt FastMutInt
n_zencs
  where
    !(FastStringTable FastMutInt
_ FastMutInt
n_zencs Array# (IORef FastStringTableSegment)
_) = FastStringTable
stringTable

-- -----------------------------------------------------------------------------
-- Outputting 'FastString's

-- |Outputs a 'FastString' with /no decoding at all/, that is, you
-- get the actual bytes in the 'FastString' written to the 'Handle'.
hPutFS :: Handle -> FastString -> IO ()
hPutFS :: Handle -> FastString -> IO ()
hPutFS Handle
handle FastString
fs = Handle -> ByteString -> IO ()
BS.hPut Handle
handle (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ FastString -> ByteString
bytesFS FastString
fs

-- ToDo: we'll probably want an hPutFSLocal, or something, to output
-- in the current locale's encoding (for error messages and suchlike).

-- -----------------------------------------------------------------------------
-- PtrStrings, here for convenience only.

-- | A 'PtrString' is a pointer to some array of Latin-1 encoded chars.
data PtrString = PtrString !(Ptr Word8) !Int

-- | Wrap an unboxed address into a 'PtrString'.
mkPtrString# :: Addr# -> PtrString
{-# INLINE mkPtrString# #-}
mkPtrString# :: Addr# -> PtrString
mkPtrString# Addr#
a# = Ptr Word8 -> Int -> PtrString
PtrString (Addr# -> Ptr Word8
forall a. Addr# -> Ptr a
Ptr Addr#
a#) (Ptr Word8 -> Int
ptrStrLength (Addr# -> Ptr Word8
forall a. Addr# -> Ptr a
Ptr Addr#
a#))

-- | Decode a 'PtrString' back into a 'String' using Latin-1 encoding.
-- This does not free the memory associated with 'PtrString'.
unpackPtrString :: PtrString -> String
unpackPtrString :: PtrString -> String
unpackPtrString (PtrString (Ptr Addr#
p#) (I# Int#
n#)) = Addr# -> Int# -> String
unpackNBytes# Addr#
p# Int#
n#

-- | @unpackPtrStringTakeN n = 'take' n . 'unpackPtrString'@
-- but is performed in \(O(\min(n,l))\) rather than \(O(l)\),
-- where \(l\) is the length of the 'PtrString'.
unpackPtrStringTakeN :: Int -> PtrString -> String
unpackPtrStringTakeN :: Int -> PtrString -> String
unpackPtrStringTakeN Int
n (PtrString (Ptr Addr#
p#) Int
len) =
  case Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
n Int
len of
    I# Int#
n# -> Addr# -> Int# -> String
unpackNBytes# Addr#
p# Int#
n#

-- | Return the length of a 'PtrString'
lengthPS :: PtrString -> Int
lengthPS :: PtrString -> Int
lengthPS (PtrString Ptr Word8
_ Int
n) = Int
n

-- -----------------------------------------------------------------------------
-- under the carpet

#if !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
foreign import ccall unsafe "strlen"
  cstringLength# :: Addr# -> Int#
#endif

ptrStrLength :: Ptr Word8 -> Int
{-# INLINE ptrStrLength #-}
ptrStrLength :: Ptr Word8 -> Int
ptrStrLength (Ptr Addr#
a) = Int# -> Int
I# (Addr# -> Int#
cstringLength# Addr#
a)

{-# NOINLINE fsLit #-}
fsLit :: String -> FastString
fsLit :: String -> FastString
fsLit String
x = String -> FastString
mkFastString String
x

{-# RULES "fslit"
    forall x . fsLit (unpackCString# x) = mkFastString# x #-}