-- (c) The University of Glasgow, 1997-2006

{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples,
    GeneralizedNewtypeDeriving #-}
{-# 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.
--   * Comparison is O(1), and you can get a 'Unique.Unique' from them.
--   * Generated by 'fsLit'.
--   * Turn into 'Outputable.SDoc' with 'Outputable.ftext'.
--
-- ['PtrString']
--
--   * Pointer and size of a Latin-1 encoded string.
--   * Practically no operations.
--   * Outputing them is fast.
--   * Generated by 'sLit'.
--   * Turn into 'Outputable.SDoc' with '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 FastString
       (
        -- * ByteString
        fastStringToByteString,
        mkFastStringByteString,
        fastZStringToByteString,
        unsafeMkByteString,

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

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

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

        -- ** Deconstruction
        unpackFS,           -- :: FastString -> String
        bytesFS,            -- :: FastString -> [Word8]

        -- ** Encoding
        zEncodeFS,

        -- ** Operations
        uniqueOfFS,
        lengthFS,
        nullFS,
        appendFS,
        headFS,
        tailFS,
        concatFS,
        consFS,
        nilFS,
        isUnderscoreFS,

        -- ** Outputing
        hPutFS,

        -- ** Internal
        getFastStringTable,
        hasZEncoding,

        -- * PtrStrings
        PtrString (..),

        -- ** Construction
        sLit,
        mkPtrString#,
        mkPtrString,

        -- ** Deconstruction
        unpackPtrString,

        -- ** Operations
        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.Maybe       ( isJust )
import Data.Char
import Data.Semigroup as Semi

import GHC.IO

import Foreign

#if STAGE >= 2
import GHC.Conc.Sync    (sharedCAF)
#endif

import GHC.Base         ( unpackCString#, unpackNBytes# )


fastStringToByteString :: FastString -> ByteString
fastStringToByteString :: FastString -> ByteString
fastStringToByteString f :: FastString
f = FastString -> ByteString
fs_bs FastString
f

fastZStringToByteString :: FastZString -> ByteString
fastZStringToByteString :: FastZString -> ByteString
fastZStringToByteString (FastZString bs :: 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 _ _ bs :: ByteString
bs _)
    = IO Int -> Int
forall a. IO a -> a
inlinePerformIO (IO Int -> Int) -> IO Int -> Int
forall a b. (a -> b) -> a -> b
$ ByteString -> (CStringLen -> IO Int) -> IO Int
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BS.unsafeUseAsCStringLen ByteString
bs ((CStringLen -> IO Int) -> IO Int)
-> (CStringLen -> IO Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ \(ptr :: Ptr CChar
ptr, len :: Int
len) ->
      Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Ptr Word8 -> Int -> Int
hashStr (Ptr CChar -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
ptr) Int
len

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

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

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

zString :: FastZString -> String
zString :: FastZString -> String
zString (FastZString bs :: 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

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

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

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

{-|
A 'FastString' is an array of bytes, hashed to support fast O(1)
comparison.  It is also associated with a character encoding, so that
we know how to convert a 'FastString' to the local encoding, or to the
Z-encoding used by the compiler internally.

'FastString's support a memoized conversion to the Z-encoding via zEncodeFS.
-}

data FastString = FastString {
      FastString -> Int
uniq    :: {-# UNPACK #-} !Int, -- unique id
      FastString -> Int
n_chars :: {-# UNPACK #-} !Int, -- number of chars
      FastString -> ByteString
fs_bs   :: {-# UNPACK #-} !ByteString,
      FastString -> IORef (Maybe FastZString)
fs_ref  :: {-# UNPACK #-} !(IORef (Maybe FastZString))
  }

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

instance Ord FastString where
    -- Compares lexicographically, not by unique
    a :: FastString
a <= :: FastString -> FastString -> Bool
<= b :: FastString
b = case FastString -> FastString -> Ordering
cmpFS FastString
a FastString
b of { LT -> Bool
True;  EQ -> Bool
True;  GT -> Bool
False }
    a :: FastString
a < :: FastString -> FastString -> Bool
<  b :: FastString
b = case FastString -> FastString -> Ordering
cmpFS FastString
a FastString
b of { LT -> Bool
True;  EQ -> Bool
False; GT -> Bool
False }
    a :: FastString
a >= :: FastString -> FastString -> Bool
>= b :: FastString
b = case FastString -> FastString -> Ordering
cmpFS FastString
a FastString
b of { LT -> Bool
False; EQ -> Bool
True;  GT -> Bool
True  }
    a :: FastString
a > :: FastString -> FastString -> Bool
>  b :: FastString
b = case FastString -> FastString -> Ordering
cmpFS FastString
a FastString
b of { LT -> Bool
False; EQ -> Bool
False; GT -> Bool
True  }
    max :: FastString -> FastString -> FastString
max x :: FastString
x y :: FastString
y | FastString
x FastString -> FastString -> Bool
forall a. Ord a => a -> a -> Bool
>= FastString
y    =  FastString
x
            | Bool
otherwise =  FastString
y
    min :: FastString -> FastString -> FastString
min x :: FastString
x y :: FastString
y | FastString
x FastString -> FastString -> Bool
forall a. Ord a => a -> a -> Bool
<= FastString
y    =  FastString
x
            | Bool
otherwise =  FastString
y
    compare :: FastString -> FastString -> Ordering
compare a :: FastString
a b :: FastString
b = FastString -> FastString -> Ordering
cmpFS FastString
a FastString
b

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 fs :: 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 _   = String -> Constr
abstractConstr "FastString"
  gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c FastString
gunfold _ _  = String -> Constr -> c FastString
forall a. HasCallStack => String -> a
error "gunfold"
  dataTypeOf :: FastString -> DataType
dataTypeOf _ = String -> DataType
mkNoRepType "FastString"

cmpFS :: FastString -> FastString -> Ordering
cmpFS :: FastString -> FastString -> Ordering
cmpFS f1 :: FastString
f1@(FastString u1 :: Int
u1 _ _ _) f2 :: FastString
f2@(FastString u2 :: Int
u2 _ _ _) =
  if Int
u1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
u2 then Ordering
EQ else
  ByteString -> ByteString -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (FastString -> ByteString
fastStringToByteString FastString
f1) (FastString -> ByteString
fastStringToByteString FastString
f2)

foreign import ccall unsafe "memcmp"
  memcmp :: Ptr a -> Ptr b -> Int -> IO Int

-- -----------------------------------------------------------------------------
-- 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 #-} !(IORef Int) -- the unique ID counter shared with all buckets
  (Array# (IORef FastStringTableSegment)) -- concurrent segments

data FastStringTableSegment = FastStringTableSegment
  {-# UNPACK #-} !(MVar ()) -- the lock for write in each segment
  {-# UNPACK #-} !(IORef Int) -- 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 = 8
numSegments :: Int
numSegments = 256   -- bit segmentBits
segmentMask :: Int
segmentMask = 0xff  -- bit segmentBits - 1
initialNumBuckets :: Int
initialNumBuckets = 64

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

hashToIndex# :: MutableArray# RealWorld [FastString] -> Int# -> Int#
hashToIndex# :: MutableArray# RealWorld [FastString] -> Int# -> Int#
hashToIndex# buckets# :: MutableArray# RealWorld [FastString]
buckets# hash# :: Int#
hash# =
  (Int#
hash# Int# -> Int# -> Int#
`uncheckedIShiftRL#` Int#
segmentBits#) Int# -> Int# -> Int#
`remInt#` Int#
size#
  where
    !(I# segmentBits# :: 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 segmentRef :: IORef FastStringTableSegment
segmentRef = do
  segment :: FastStringTableSegment
segment@(FastStringTableSegment lock :: MVar ()
lock counter :: IORef Int
counter old# :: MutableArray# RealWorld [FastString]
old#) <- IORef FastStringTableSegment -> IO FastStringTableSegment
forall a. IORef a -> IO a
readIORef IORef FastStringTableSegment
segmentRef
  let oldSize# :: Int#
oldSize# = MutableArray# RealWorld [FastString] -> Int#
forall d a. MutableArray# d a -> Int#
sizeofMutableArray# MutableArray# RealWorld [FastString]
old#
      newSize# :: Int#
newSize# = Int#
oldSize# Int# -> Int# -> Int#
*# 2#
  (I# n# :: Int#
n#) <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
counter
  if Int# -> Bool
isTrue# (Int#
n# Int# -> Int# -> Int#
<# Int#
newSize#) -- maximum load of 1
  then FastStringTableSegment -> IO FastStringTableSegment
forall (m :: * -> *) a. Monad m => a -> m a
return FastStringTableSegment
segment
  else do
    resizedSegment :: FastStringTableSegment
resizedSegment@(FastStringTableSegment _ _ new# :: MutableArray# RealWorld [FastString]
new#) <- (State# RealWorld
 -> (# State# RealWorld, FastStringTableSegment #))
-> IO FastStringTableSegment
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld
  -> (# State# RealWorld, FastStringTableSegment #))
 -> IO FastStringTableSegment)
-> (State# RealWorld
    -> (# State# RealWorld, FastStringTableSegment #))
-> IO FastStringTableSegment
forall a b. (a -> b) -> a -> b
$ \s1# :: 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
        (# s2# :: State# RealWorld
s2#, arr# :: MutableArray# RealWorld [FastString]
arr# #) -> (# State# RealWorld
s2#, MVar ()
-> IORef Int
-> MutableArray# RealWorld [FastString]
-> FastStringTableSegment
FastStringTableSegment MVar ()
lock IORef Int
counter MutableArray# RealWorld [FastString]
arr# #)
    [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [0 .. (Int# -> Int
I# Int#
oldSize#) Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(I# i# :: Int#
i#) -> do
      [FastString]
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#
      [FastString] -> (FastString -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FastString]
fsList ((FastString -> IO ()) -> IO ()) -> (FastString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \fs :: FastString
fs -> do
        let -- Shall we store in hash value in FastString instead?
            !(I# hash# :: 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
$ \s1# :: 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
            (# s2# :: State# RealWorld
s2#, bucket :: [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
              s3# :: State# RealWorld
s3# -> (# State# RealWorld
s3#, () #)
    IORef FastStringTableSegment -> FastStringTableSegment -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef FastStringTableSegment
segmentRef FastStringTableSegment
resizedSegment
    FastStringTableSegment -> IO FastStringTableSegment
forall (m :: * -> *) a. Monad m => a -> m a
return FastStringTableSegment
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# numSegments# :: Int#
numSegments#) = Int
numSegments
      !(I# initialNumBuckets# :: Int#
initialNumBuckets#) = Int
initialNumBuckets
      loop :: MutableArray# RealWorld (IORef FastStringTableSegment)
-> Int# -> State# RealWorld -> State# RealWorld
loop a# :: MutableArray# RealWorld (IORef FastStringTableSegment)
a# i# :: Int#
i# s1# :: 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
            (# s2# :: State# RealWorld
s2#, lock :: MVar ()
lock #) -> case Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef 0 IO (IORef Int)
-> State# RealWorld -> (# State# RealWorld, IORef Int #)
forall a. IO a -> State# RealWorld -> (# State# RealWorld, a #)
`unIO` State# RealWorld
s2# of
              (# s3# :: State# RealWorld
s3#, counter :: IORef Int
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
                (# s4# :: State# RealWorld
s4#, buckets# :: MutableArray# RealWorld [FastString]
buckets# #) -> case FastStringTableSegment -> IO (IORef FastStringTableSegment)
forall a. a -> IO (IORef a)
newIORef
                    (MVar ()
-> IORef Int
-> MutableArray# RealWorld [FastString]
-> FastStringTableSegment
FastStringTableSegment MVar ()
lock IORef Int
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
                  (# s5# :: State# RealWorld
s5#, segment :: 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
                    s6# :: State# RealWorld
s6# -> MutableArray# RealWorld (IORef FastStringTableSegment)
-> Int# -> State# RealWorld -> State# RealWorld
loop MutableArray# RealWorld (IORef FastStringTableSegment)
a# (Int#
i# Int# -> Int# -> Int#
+# 1#) State# RealWorld
s6#
  IORef Int
uid <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef 603979776 -- ord '$' * 0x01000000
  FastStringTable
tab <- (State# RealWorld -> (# State# RealWorld, FastStringTable #))
-> IO FastStringTable
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, FastStringTable #))
 -> IO FastStringTable)
-> (State# RealWorld -> (# State# RealWorld, FastStringTable #))
-> IO FastStringTable
forall a b. (a -> b) -> a -> b
$ \s1# :: 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. String -> a
panic "string_table") State# RealWorld
s1# of
      (# s2# :: State# RealWorld
s2#, arr# :: MutableArray# RealWorld (IORef FastStringTableSegment)
arr# #) -> case MutableArray# RealWorld (IORef FastStringTableSegment)
-> Int# -> State# RealWorld -> State# RealWorld
loop MutableArray# RealWorld (IORef FastStringTableSegment)
arr# 0# State# RealWorld
s2# of
        s3# :: 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
          (# s4# :: State# RealWorld
s4#, segments# :: Array# (IORef FastStringTableSegment)
segments# #) -> (# State# RealWorld
s4#, IORef Int
-> Array# (IORef FastStringTableSegment) -> FastStringTable
FastStringTable IORef Int
uid Array# (IORef FastStringTableSegment)
segments# #)

  -- use the support wired into the RTS to share this CAF among all images of
  -- libHSghc
#if STAGE < 2
  return tab
#else
  FastStringTable
-> (Ptr FastStringTable -> IO (Ptr FastStringTable))
-> IO FastStringTable
forall a. a -> (Ptr a -> IO (Ptr a)) -> IO a
sharedCAF FastStringTable
tab Ptr FastStringTable -> IO (Ptr FastStringTable)
forall a. Ptr a -> IO (Ptr a)
getOrSetLibHSghcFastStringTable

-- from the RTS; thus we cannot use this mechanism when STAGE<2; the previous
-- RTS might not have this symbol
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_RdrName rdrName $ mg_rdr_env guts

`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
mkFastString# :: Addr# -> FastString
mkFastString# a# :: Addr#
a# = Ptr Word8 -> Int -> FastString
mkFastStringBytes Ptr Word8
forall a. Ptr a
ptr (Ptr Word8 -> Int
ptrStrLength Ptr Word8
forall a. Ptr a
ptr)
  where ptr :: Ptr a
ptr = Addr# -> Ptr a
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 -> IO FastString) -> Ptr Word8 -> Int -> IO FastString
mkFastStringWith :: (Int -> IO FastString) -> Ptr Word8 -> Int -> IO FastString
mkFastStringWith mk_fs :: Int -> IO FastString
mk_fs !Ptr Word8
ptr !Int
len = do
  FastStringTableSegment lock :: MVar ()
lock _ buckets# :: MutableArray# RealWorld [FastString]
buckets# <- IORef FastStringTableSegment -> IO FastStringTableSegment
forall a. IORef a -> IO a
readIORef IORef FastStringTableSegment
segmentRef
  let idx# :: Int#
idx# = MutableArray# RealWorld [FastString] -> Int# -> Int#
hashToIndex# MutableArray# RealWorld [FastString]
buckets# Int#
hash#
  [FastString]
bucket <- (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#
idx#
  Maybe FastString
res <- [FastString] -> Int -> Ptr Word8 -> IO (Maybe FastString)
bucket_match [FastString]
bucket Int
len Ptr Word8
ptr
  case Maybe FastString
res of
    Just found :: FastString
found -> FastString -> IO FastString
forall (m :: * -> *) a. Monad m => a -> m a
return FastString
found
    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
      Int
n <- IO Int
get_uid
      FastString
new_fs <- Int -> IO FastString
mk_fs Int
n
      MVar () -> (() -> IO FastString) -> IO FastString
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
lock ((() -> IO FastString) -> IO FastString)
-> (() -> IO FastString) -> IO FastString
forall a b. (a -> b) -> a -> b
$ \_ -> FastString -> IO FastString
insert FastString
new_fs
  where
    !(FastStringTable uid :: IORef Int
uid segments# :: Array# (IORef FastStringTableSegment)
segments#) = FastStringTable
stringTable
    get_uid :: IO Int
get_uid = IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
uid ((Int -> (Int, Int)) -> IO Int) -> (Int -> (Int, Int)) -> IO Int
forall a b. (a -> b) -> a -> b
$ \n :: Int
n -> (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1,Int
n)

    !(I# hash# :: Int#
hash#) = Ptr Word8 -> Int -> Int
hashStr Ptr Word8
ptr Int
len
    (# segmentRef :: 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 fs :: FastString
fs = do
      FastStringTableSegment _ counter :: IORef Int
counter buckets# :: MutableArray# RealWorld [FastString]
buckets# <- IORef FastStringTableSegment -> IO FastStringTableSegment
maybeResizeSegment IORef FastStringTableSegment
segmentRef
      let idx# :: Int#
idx# = MutableArray# RealWorld [FastString] -> Int# -> Int#
hashToIndex# MutableArray# RealWorld [FastString]
buckets# Int#
hash#
      [FastString]
bucket <- (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#
idx#
      Maybe FastString
res <- [FastString] -> Int -> Ptr Word8 -> IO (Maybe FastString)
bucket_match [FastString]
bucket Int
len Ptr Word8
ptr
      case Maybe FastString
res of
        -- The FastString was added by another thread after previous read and
        -- before we acquired the write lock.
        Just found :: FastString
found -> FastString -> IO FastString
forall (m :: * -> *) a. Monad m => a -> m a
return FastString
found
        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
$ \s1# :: 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
fsFastString -> [FastString] -> [FastString]
forall a. a -> [a] -> [a]
: [FastString]
bucket) State# RealWorld
s1# of
              s2# :: State# RealWorld
s2# -> (# State# RealWorld
s2#, () #)
          IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Int
counter Int -> Int
forall a. Enum a => a -> a
succ
          FastString -> IO FastString
forall (m :: * -> *) a. Monad m => a -> m a
return FastString
fs

bucket_match :: [FastString] -> Int -> Ptr Word8 -> IO (Maybe FastString)
bucket_match :: [FastString] -> Int -> Ptr Word8 -> IO (Maybe FastString)
bucket_match [] _ _ = Maybe FastString -> IO (Maybe FastString)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FastString
forall a. Maybe a
Nothing
bucket_match (v :: FastString
v@(FastString _ _ bs :: ByteString
bs _):ls :: [FastString]
ls) len :: Int
len ptr :: Ptr Word8
ptr
      | Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Int
BS.length ByteString
bs = do
         Bool
b <- ByteString -> (Ptr CChar -> IO Bool) -> IO Bool
forall a. ByteString -> (Ptr CChar -> IO a) -> IO a
BS.unsafeUseAsCString ByteString
bs ((Ptr CChar -> IO Bool) -> IO Bool)
-> (Ptr CChar -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \buf :: Ptr CChar
buf ->
             Ptr Word8 -> Ptr Word8 -> Int -> IO Bool
cmpStringPrefix Ptr Word8
ptr (Ptr CChar -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
buf) Int
len
         if Bool
b then Maybe FastString -> IO (Maybe FastString)
forall (m :: * -> *) a. Monad m => a -> m a
return (FastString -> Maybe FastString
forall a. a -> Maybe a
Just FastString
v)
              else [FastString] -> Int -> Ptr Word8 -> IO (Maybe FastString)
bucket_match [FastString]
ls Int
len Ptr Word8
ptr
      | Bool
otherwise =
         [FastString] -> Int -> Ptr Word8 -> IO (Maybe FastString)
bucket_match [FastString]
ls Int
len Ptr Word8
ptr

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
$
        (Int -> IO FastString) -> Ptr Word8 -> Int -> IO FastString
mkFastStringWith (Ptr Word8 -> Int -> Int -> IO FastString
copyNewFastString Ptr Word8
ptr Int
len) Ptr Word8
ptr Int
len

-- | Create a 'FastString' from an existing 'ForeignPtr'; the difference
-- between this and 'mkFastStringBytes' is that we don't have to copy
-- the bytes if the string is new to the table.
mkFastStringForeignPtr :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO FastString
mkFastStringForeignPtr :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO FastString
mkFastStringForeignPtr ptr :: Ptr Word8
ptr !ForeignPtr Word8
fp len :: Int
len
    = (Int -> IO FastString) -> Ptr Word8 -> Int -> IO FastString
mkFastStringWith (ForeignPtr Word8 -> Ptr Word8 -> Int -> Int -> IO FastString
mkNewFastString ForeignPtr Word8
fp Ptr Word8
ptr Int
len) Ptr Word8
ptr Int
len

-- | Create a 'FastString' from an existing 'ForeignPtr'; the difference
-- between this and 'mkFastStringBytes' is that we don't have to copy
-- the bytes if the string is new to the table.
mkFastStringByteString :: ByteString -> FastString
mkFastStringByteString :: ByteString -> FastString
mkFastStringByteString bs :: ByteString
bs =
    IO FastString -> FastString
forall a. IO a -> a
inlinePerformIO (IO FastString -> FastString) -> IO FastString -> FastString
forall a b. (a -> b) -> a -> b
$
      ByteString -> (CStringLen -> IO FastString) -> IO FastString
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BS.unsafeUseAsCStringLen ByteString
bs ((CStringLen -> IO FastString) -> IO FastString)
-> (CStringLen -> IO FastString) -> IO FastString
forall a b. (a -> b) -> a -> b
$ \(ptr :: Ptr CChar
ptr, len :: Int
len) -> do
        let ptr' :: Ptr b
ptr' = Ptr CChar -> Ptr b
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
ptr
        (Int -> IO FastString) -> Ptr Word8 -> Int -> IO FastString
mkFastStringWith (ByteString -> Ptr Word8 -> Int -> Int -> IO FastString
mkNewFastStringByteString ByteString
bs Ptr Word8
forall a. Ptr a
ptr' Int
len) Ptr Word8
forall a. Ptr a
ptr' Int
len

-- | Creates a UTF-8 encoded 'FastString' from a 'String'
mkFastString :: String -> FastString
mkFastString :: String -> FastString
mkFastString str :: 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 l :: Int
l = String -> Int
utf8EncodedLength String
str
    ForeignPtr Word8
buf <- Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
l
    ForeignPtr Word8 -> (Ptr Word8 -> IO FastString) -> IO FastString
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
buf ((Ptr Word8 -> IO FastString) -> IO FastString)
-> (Ptr Word8 -> IO FastString) -> IO FastString
forall a b. (a -> b) -> a -> b
$ \ptr :: Ptr Word8
ptr -> do
      Ptr Word8 -> String -> IO ()
utf8EncodeString Ptr Word8
ptr String
str
      Ptr Word8 -> ForeignPtr Word8 -> Int -> IO FastString
mkFastStringForeignPtr Ptr Word8
ptr ForeignPtr Word8
buf Int
l

-- | Creates a 'FastString' from a UTF-8 encoded @[Word8]@
mkFastStringByteList :: [Word8] -> FastString
mkFastStringByteList :: [Word8] -> FastString
mkFastStringByteList str :: [Word8]
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 l :: Int
l = [Word8] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [Word8]
str
    ForeignPtr Word8
buf <- Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
l
    ForeignPtr Word8 -> (Ptr Word8 -> IO FastString) -> IO FastString
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
buf ((Ptr Word8 -> IO FastString) -> IO FastString)
-> (Ptr Word8 -> IO FastString) -> IO FastString
forall a b. (a -> b) -> a -> b
$ \ptr :: Ptr Word8
ptr -> do
      Ptr Word8 -> [Word8] -> IO ()
forall a. Storable a => Ptr a -> [a] -> IO ()
pokeArray (Ptr Word8 -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
ptr) [Word8]
str
      Ptr Word8 -> ForeignPtr Word8 -> Int -> IO FastString
mkFastStringForeignPtr Ptr Word8
ptr ForeignPtr Word8
buf Int
l

-- | Creates a Z-encoded 'FastString' from a 'String'
mkZFastString :: String -> FastZString
mkZFastString :: String -> FastZString
mkZFastString = String -> FastZString
mkFastZStringString

mkNewFastString :: ForeignPtr Word8 -> Ptr Word8 -> Int -> Int
                -> IO FastString
mkNewFastString :: ForeignPtr Word8 -> Ptr Word8 -> Int -> Int -> IO FastString
mkNewFastString fp :: ForeignPtr Word8
fp ptr :: Ptr Word8
ptr len :: Int
len uid :: Int
uid = do
  IORef (Maybe FastZString)
ref <- Maybe FastZString -> IO (IORef (Maybe FastZString))
forall a. a -> IO (IORef a)
newIORef Maybe FastZString
forall a. Maybe a
Nothing
  Int
n_chars <- Ptr Word8 -> Int -> IO Int
countUTF8Chars Ptr Word8
ptr Int
len
  FastString -> IO FastString
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Int -> ByteString -> IORef (Maybe FastZString) -> FastString
FastString Int
uid Int
n_chars (ForeignPtr Word8 -> Int -> Int -> ByteString
BS.fromForeignPtr ForeignPtr Word8
fp 0 Int
len) IORef (Maybe FastZString)
ref)

mkNewFastStringByteString :: ByteString -> Ptr Word8 -> Int -> Int
                          -> IO FastString
mkNewFastStringByteString :: ByteString -> Ptr Word8 -> Int -> Int -> IO FastString
mkNewFastStringByteString bs :: ByteString
bs ptr :: Ptr Word8
ptr len :: Int
len uid :: Int
uid = do
  IORef (Maybe FastZString)
ref <- Maybe FastZString -> IO (IORef (Maybe FastZString))
forall a. a -> IO (IORef a)
newIORef Maybe FastZString
forall a. Maybe a
Nothing
  Int
n_chars <- Ptr Word8 -> Int -> IO Int
countUTF8Chars Ptr Word8
ptr Int
len
  FastString -> IO FastString
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Int -> ByteString -> IORef (Maybe FastZString) -> FastString
FastString Int
uid Int
n_chars ByteString
bs IORef (Maybe FastZString)
ref)

copyNewFastString :: Ptr Word8 -> Int -> Int -> IO FastString
copyNewFastString :: Ptr Word8 -> Int -> Int -> IO FastString
copyNewFastString ptr :: Ptr Word8
ptr len :: Int
len uid :: Int
uid = do
  ForeignPtr Word8
fp <- Ptr Word8 -> Int -> IO (ForeignPtr Word8)
copyBytesToForeignPtr Ptr Word8
ptr Int
len
  IORef (Maybe FastZString)
ref <- Maybe FastZString -> IO (IORef (Maybe FastZString))
forall a. a -> IO (IORef a)
newIORef Maybe FastZString
forall a. Maybe a
Nothing
  Int
n_chars <- Ptr Word8 -> Int -> IO Int
countUTF8Chars Ptr Word8
ptr Int
len
  FastString -> IO FastString
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Int -> ByteString -> IORef (Maybe FastZString) -> FastString
FastString Int
uid Int
n_chars (ForeignPtr Word8 -> Int -> Int -> ByteString
BS.fromForeignPtr ForeignPtr Word8
fp 0 Int
len) IORef (Maybe FastZString)
ref)

copyBytesToForeignPtr :: Ptr Word8 -> Int -> IO (ForeignPtr Word8)
copyBytesToForeignPtr :: Ptr Word8 -> Int -> IO (ForeignPtr Word8)
copyBytesToForeignPtr ptr :: Ptr Word8
ptr len :: Int
len = do
  ForeignPtr Word8
fp <- Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
len
  ForeignPtr Word8 -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ptr' :: Ptr Word8
ptr' -> Ptr Word8 -> Ptr Word8 -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes Ptr Word8
ptr' Ptr Word8
ptr Int
len
  ForeignPtr Word8 -> IO (ForeignPtr Word8)
forall (m :: * -> *) a. Monad m => a -> m a
return ForeignPtr Word8
fp

cmpStringPrefix :: Ptr Word8 -> Ptr Word8 -> Int -> IO Bool
cmpStringPrefix :: Ptr Word8 -> Ptr Word8 -> Int -> IO Bool
cmpStringPrefix ptr1 :: Ptr Word8
ptr1 ptr2 :: Ptr Word8
ptr2 len :: Int
len =
 do Int
r <- Ptr Word8 -> Ptr Word8 -> Int -> IO Int
forall a b. Ptr a -> Ptr b -> Int -> IO Int
memcmp Ptr Word8
ptr1 Ptr Word8
ptr2 Int
len
    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0)


hashStr  :: Ptr Word8 -> Int -> Int
 -- use the Addr to produce a hash value between 0 & m (inclusive)
hashStr :: Ptr Word8 -> Int -> Int
hashStr (Ptr a# :: Addr#
a#) (I# len# :: Int#
len#) = Int# -> Int# -> Int
loop 0# 0#
   where
    loop :: Int# -> Int# -> Int
loop h :: Int#
h n :: Int#
n | Int# -> Bool
isTrue# (Int#
n Int# -> Int# -> Int#
==# Int#
len#) = Int# -> Int
I# Int#
h
             | Bool
otherwise  = Int# -> Int# -> Int
loop Int#
h2 (Int#
n Int# -> Int# -> Int#
+# 1#)
          where
            !c :: Int#
c = Char# -> Int#
ord# (Addr# -> Int# -> Char#
indexCharOffAddr# Addr#
a# Int#
n)
            !h2 :: Int#
h2 = (Int#
h Int# -> Int# -> Int#
*# 16777619#) Int# -> Int# -> Int#
`xorI#` Int#
c

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

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

-- | Returns @True@ if this 'FastString' is not Z-encoded but already has
-- a Z-encoding cached (used in producing stats).
hasZEncoding :: FastString -> Bool
hasZEncoding :: FastString -> Bool
hasZEncoding (FastString _ _ _ ref :: IORef (Maybe FastZString)
ref) =
      IO Bool -> Bool
forall a. IO a -> a
inlinePerformIO (IO Bool -> Bool) -> IO Bool -> Bool
forall a b. (a -> b) -> a -> b
$ do
        Maybe FastZString
m <- IORef (Maybe FastZString) -> IO (Maybe FastZString)
forall a. IORef a -> IO a
readIORef IORef (Maybe FastZString)
ref
        Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FastZString -> Bool
forall a. Maybe a -> Bool
isJust Maybe FastZString
m)

-- | Returns @True@ if the 'FastString' is empty
nullFS :: FastString -> Bool
nullFS :: FastString -> Bool
nullFS f :: FastString
f = ByteString -> Bool
BS.null (FastString -> ByteString
fs_bs FastString
f)

-- | Unpacks and decodes the FastString
unpackFS :: FastString -> String
unpackFS :: FastString -> String
unpackFS (FastString _ _ bs :: ByteString
bs _) = ByteString -> String
utf8DecodeByteString ByteString
bs

-- | Gives the UTF-8 encoded bytes corresponding to a 'FastString'
bytesFS :: FastString -> [Word8]
bytesFS :: FastString -> [Word8]
bytesFS fs :: FastString
fs = ByteString -> [Word8]
BS.unpack (ByteString -> [Word8]) -> ByteString -> [Word8]
forall a b. (a -> b) -> a -> b
$ FastString -> ByteString
fastStringToByteString 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 fs :: FastString
fs@(FastString _ _ _ ref :: IORef (Maybe FastZString)
ref) =
      IO FastZString -> FastZString
forall a. IO a -> a
inlinePerformIO (IO FastZString -> FastZString) -> IO FastZString -> FastZString
forall a b. (a -> b) -> a -> b
$ do
        Maybe FastZString
m <- IORef (Maybe FastZString) -> IO (Maybe FastZString)
forall a. IORef a -> IO a
readIORef IORef (Maybe FastZString)
ref
        case Maybe FastZString
m of
          Just zfs :: FastZString
zfs -> FastZString -> IO FastZString
forall (m :: * -> *) a. Monad m => a -> m a
return FastZString
zfs
          Nothing -> do
            IORef (Maybe FastZString)
-> (Maybe FastZString -> (Maybe FastZString, FastZString))
-> IO FastZString
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Maybe FastZString)
ref ((Maybe FastZString -> (Maybe FastZString, FastZString))
 -> IO FastZString)
-> (Maybe FastZString -> (Maybe FastZString, FastZString))
-> IO FastZString
forall a b. (a -> b) -> a -> b
$ \m' :: Maybe FastZString
m' -> case Maybe FastZString
m' of
              Nothing  -> let zfs :: FastZString
zfs = String -> FastZString
mkZFastString (ShowS
zEncodeString (FastString -> String
unpackFS FastString
fs))
                          in (FastZString -> Maybe FastZString
forall a. a -> Maybe a
Just FastZString
zfs, FastZString
zfs)
              Just zfs :: FastZString
zfs -> (Maybe FastZString
m', FastZString
zfs)

appendFS :: FastString -> FastString -> FastString
appendFS :: FastString -> FastString -> FastString
appendFS fs1 :: FastString
fs1 fs2 :: FastString
fs2 = ByteString -> FastString
mkFastStringByteString
                 (ByteString -> FastString) -> ByteString -> FastString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> ByteString
BS.append (FastString -> ByteString
fastStringToByteString FastString
fs1)
                             (FastString -> ByteString
fastStringToByteString FastString
fs2)

concatFS :: [FastString] -> FastString
concatFS :: [FastString] -> FastString
concatFS = ByteString -> FastString
mkFastStringByteString (ByteString -> FastString)
-> ([FastString] -> ByteString) -> [FastString] -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
BS.concat ([ByteString] -> ByteString)
-> ([FastString] -> [ByteString]) -> [FastString] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FastString -> ByteString) -> [FastString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map FastString -> ByteString
fs_bs

headFS :: FastString -> Char
headFS :: FastString -> Char
headFS (FastString _ 0 _ _) = String -> Char
forall a. String -> a
panic "headFS: Empty FastString"
headFS (FastString _ _ bs :: ByteString
bs _) =
  IO Char -> Char
forall a. IO a -> a
inlinePerformIO (IO Char -> Char) -> IO Char -> Char
forall a b. (a -> b) -> a -> b
$ ByteString -> (Ptr CChar -> IO Char) -> IO Char
forall a. ByteString -> (Ptr CChar -> IO a) -> IO a
BS.unsafeUseAsCString ByteString
bs ((Ptr CChar -> IO Char) -> IO Char)
-> (Ptr CChar -> IO Char) -> IO Char
forall a b. (a -> b) -> a -> b
$ \ptr :: Ptr CChar
ptr ->
         Char -> IO Char
forall (m :: * -> *) a. Monad m => a -> m a
return ((Char, Int) -> Char
forall a b. (a, b) -> a
fst (Ptr Word8 -> (Char, Int)
utf8DecodeChar (Ptr CChar -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
ptr)))

tailFS :: FastString -> FastString
tailFS :: FastString -> FastString
tailFS (FastString _ 0 _ _) = String -> FastString
forall a. String -> a
panic "tailFS: Empty FastString"
tailFS (FastString _ _ bs :: ByteString
bs _) =
    IO FastString -> FastString
forall a. IO a -> a
inlinePerformIO (IO FastString -> FastString) -> IO FastString -> FastString
forall a b. (a -> b) -> a -> b
$ ByteString -> (Ptr CChar -> IO FastString) -> IO FastString
forall a. ByteString -> (Ptr CChar -> IO a) -> IO a
BS.unsafeUseAsCString ByteString
bs ((Ptr CChar -> IO FastString) -> IO FastString)
-> (Ptr CChar -> IO FastString) -> IO FastString
forall a b. (a -> b) -> a -> b
$ \ptr :: Ptr CChar
ptr ->
    do let (_, n :: Int
n) = Ptr Word8 -> (Char, Int)
utf8DecodeChar (Ptr CChar -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
ptr)
       FastString -> IO FastString
forall (m :: * -> *) a. Monad m => a -> m a
return (FastString -> IO FastString) -> FastString -> IO FastString
forall a b. (a -> b) -> a -> b
$! ByteString -> FastString
mkFastStringByteString (Int -> ByteString -> ByteString
BS.drop Int
n ByteString
bs)

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

uniqueOfFS :: FastString -> Int
uniqueOfFS :: FastString -> Int
uniqueOfFS (FastString u :: Int
u _ _ _) = Int
u

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

isUnderscoreFS :: FastString -> Bool
isUnderscoreFS :: FastString -> Bool
isUnderscoreFS fs :: FastString
fs = FastString
fs FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== String -> FastString
fsLit "_"

-- -----------------------------------------------------------------------------
-- 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 [0 .. Int
numSegments Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1] ((Int -> IO [[FastString]]) -> IO [[[FastString]]])
-> (Int -> IO [[FastString]]) -> IO [[[FastString]]]
forall a b. (a -> b) -> a -> b
$ \(I# i# :: Int#
i#) -> do
    let (# segmentRef :: IORef FastStringTableSegment
segmentRef #) = Array# (IORef FastStringTableSegment)
-> Int# -> (# IORef FastStringTableSegment #)
forall a. Array# a -> Int# -> (# a #)
indexArray# Array# (IORef FastStringTableSegment)
segments# Int#
i#
    FastStringTableSegment _ _ buckets# :: MutableArray# RealWorld [FastString]
buckets# <- IORef FastStringTableSegment -> IO FastStringTableSegment
forall a. IORef a -> IO a
readIORef IORef FastStringTableSegment
segmentRef
    let bucketSize :: Int
bucketSize = Int# -> Int
I# (MutableArray# RealWorld [FastString] -> Int#
forall d a. MutableArray# d a -> Int#
sizeofMutableArray# MutableArray# RealWorld [FastString]
buckets#)
    [Int] -> (Int -> IO [FastString]) -> IO [[FastString]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [0 .. Int
bucketSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1] ((Int -> IO [FastString]) -> IO [[FastString]])
-> (Int -> IO [FastString]) -> IO [[FastString]]
forall a b. (a -> b) -> a -> b
$ \(I# j# :: 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 _ segments# :: Array# (IORef FastStringTableSegment)
segments#) = 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
handle fs :: FastString
fs = Handle -> ByteString -> IO ()
BS.hPut Handle
handle (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ FastString -> ByteString
fastStringToByteString 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
mkPtrString# :: Addr# -> PtrString
mkPtrString# a# :: 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#))

-- | Encode a 'String' into a newly allocated 'PtrString' using Latin-1
-- encoding.  The original string must not contain non-Latin-1 characters
-- (above codepoint @0xff@).
{-# INLINE mkPtrString #-}
mkPtrString :: String -> PtrString
mkPtrString :: String -> PtrString
mkPtrString s :: String
s =
 -- we don't use `unsafeDupablePerformIO` here to avoid potential memory leaks
 -- and because someone might be using `eqAddr#` to check for string equality.
 IO PtrString -> PtrString
forall a. IO a -> a
unsafePerformIO (do
   let len :: Int
len = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s
   Ptr Word8
p <- Int -> IO (Ptr Word8)
forall a. Int -> IO (Ptr a)
mallocBytes Int
len
   let
     loop :: Int -> String -> IO ()
     loop :: Int -> String -> IO ()
loop !Int
_ []    = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
     loop n :: Int
n (c :: Char
c:cs :: String
cs) = do
        Ptr Word8 -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
p Int
n (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c) :: Word8)
        Int -> String -> IO ()
loop (1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
n) String
cs
   Int -> String -> IO ()
loop 0 String
s
   PtrString -> IO PtrString
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr Word8 -> Int -> PtrString
PtrString Ptr Word8
p Int
len)
 )

-- | 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 p# :: Addr#
p#) (I# n# :: Int#
n#)) = Addr# -> Int# -> String
unpackNBytes# Addr#
p# Int#
n#

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

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

foreign import ccall unsafe "strlen"
  ptrStrLength :: Ptr Word8 -> Int

{-# NOINLINE sLit #-}
sLit :: String -> PtrString
sLit :: String -> PtrString
sLit x :: String
x  = String -> PtrString
mkPtrString String
x

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

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