    {-# LANGUAGE RankNTypes #-}

    -- | The Name Cache
    module GHC.Types.Name.Cache
      ( NameCache (..)
      , initNameCache
      , takeUniqFromNameCache
      , updateNameCache'
      , updateNameCache

      -- * OrigNameCache
      , OrigNameCache
      , lookupOrigNameCache
      , extendOrigNameCache'
      , extendOrigNameCache
      )
    where

    import GHC.Prelude

    import GHC.Unit.Module
    import GHC.Types.Name
    import GHC.Types.Unique.Supply
    import GHC.Builtin.Types
    import GHC.Builtin.Names

    import GHC.Utils.Outputable
    import GHC.Utils.Panic

    import Control.Concurrent.MVar
    import Control.Monad

    {-

    Note [The Name Cache]
    ~~~~~~~~~~~~~~~~~~~~~
    The Name Cache makes sure that, during any invocation of GHC, each
    External Name "M.x" has one, and only one globally-agreed Unique.

    * The first time we come across M.x we make up a Unique and record that
      association in the Name Cache.

    * When we come across "M.x" again, we look it up in the Name Cache,
      and get a hit.

    The functions newGlobalBinder, allocateGlobalBinder do the main work.
    When you make an External name, you should probably be calling one
    of them.

    Names in a NameCache are always stored as a Global, and have the SrcLoc of their
    binding locations.  Actually that's not quite right.  When we first encounter
    the original name, we might not be at its binding site (e.g. we are reading an
    interface file); so we give it 'noSrcLoc' then.  Later, when we find its binding
    site, we fix it up.

    Note [Built-in syntax and the OrigNameCache]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Built-in syntax like tuples and unboxed sums are quite ubiquitous. To lower
    their cost we use two tricks,

      a. We specially encode tuple and sum Names in interface files' symbol tables
         to avoid having to look up their names while loading interface files.
         Namely these names are encoded as by their Uniques. We know how to get from
         a Unique back to the Name which it represents via the mapping defined in
         the SumTupleUniques module. See Note [Symbol table representation of names]
         in GHC.Iface.Binary and for details.

      b. We don't include them in the Orig name cache but instead parse their
         OccNames (in isBuiltInOcc_maybe) to avoid bloating the name cache with
         them.

    Why is the second measure necessary? Good question; afterall, 1) the parser
    emits built-in syntax directly as Exact RdrNames, and 2) built-in syntax never
    needs to looked-up during interface loading due to (a). It turns out that there
    are two reasons why we might look up an Orig RdrName for built-in syntax,

      * If you use setRdrNameSpace on an Exact RdrName it may be
        turned into an Orig RdrName.

      * Template Haskell turns a BuiltInSyntax Name into a TH.NameG
        (GHC.HsToCore.Quote.globalVar), and parses a NameG into an Orig RdrName
        (GHC.ThToHs.thRdrName).  So, e.g. $(do { reify '(,); ... }) will
        go this route (#8954).

    -}
    -- | The NameCache makes sure that there is just one Unique assigned for
    -- each original name; i.e. (module-name, occ-name) pair and provides
    -- something of a lookup mechanism for those names.
    data NameCache = NameCache
      { NameCache -> Char
    nsUniqChar :: {-# UNPACK #-} !Char
      , NameCache -> MVar OrigNameCache
    nsNames    :: {-# UNPACK #-} !(MVar OrigNameCache)
      }

    -- | Per-module cache of original 'OccName's given 'Name's
    type OrigNameCache   = ModuleEnv (OccEnv Name)

    takeUniqFromNameCache :: NameCache -> IO Unique
    takeUniqFromNameCache :: NameCache -> IO Unique
    takeUniqFromNameCache (NameCache Char
    c MVar OrigNameCache
    _) = Char -> IO Unique
    uniqFromMask Char
    c

    lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name
    lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name
    lookupOrigNameCache OrigNameCache
    nc Module
    mod OccName
    occ
      | Module
    mod Module -> Module -> Bool
    forall a. Eq a => a -> a -> Bool
    == Module
    gHC_TYPES Bool -> Bool -> Bool
    || Module
    mod Module -> Module -> Bool
    forall a. Eq a => a -> a -> Bool
    == Module
    gHC_PRIM Bool -> Bool -> Bool
    || Module
    mod Module -> Module -> Bool
    forall a. Eq a => a -> a -> Bool
    == Module
    gHC_TUPLE_PRIM
      , Just Name
    name <- OccName -> Maybe Name
    isBuiltInOcc_maybe OccName
    occ
      =     -- See Note [Known-key names], 3(c) in GHC.Builtin.Names
            -- Special case for tuples; there are too many
            -- of them to pre-populate the original-name cache
        Name -> Maybe Name
    forall a. a -> Maybe a
    Just Name
    name

      | Bool
    otherwise
      = case OrigNameCache -> Module -> Maybe (OccEnv Name)
    forall a. ModuleEnv a -> Module -> Maybe a
    lookupModuleEnv OrigNameCache
    nc Module
    mod of
            Maybe (OccEnv Name)
    Nothing      -> Maybe Name
    forall a. Maybe a
    Nothing
            Just OccEnv Name
    occ_env -> OccEnv Name -> OccName -> Maybe Name
    forall a. OccEnv a -> OccName -> Maybe a
    lookupOccEnv OccEnv Name
    occ_env OccName
    occ

    extendOrigNameCache' :: OrigNameCache -> Name -> OrigNameCache
    extendOrigNameCache' :: OrigNameCache -> Name -> OrigNameCache
    extendOrigNameCache' OrigNameCache
    nc Name
    name
      = Bool -> SDoc -> OrigNameCache -> OrigNameCache
    forall a. HasCallStack => Bool -> SDoc -> a -> a
    assertPpr (Name -> Bool
    isExternalName Name
    name) (Name -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Name
    name) (OrigNameCache -> OrigNameCache) -> OrigNameCache -> OrigNameCache
    forall a b. (a -> b) -> a -> b
    $
        OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
    extendOrigNameCache OrigNameCache
    nc ((() :: Constraint) => Name -> Module
    Name -> Module
    nameModule Name
    name) (Name -> OccName
    nameOccName Name
    name) Name
    name

    extendOrigNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
    extendOrigNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
    extendOrigNameCache OrigNameCache
    nc Module
    mod OccName
    occ Name
    name
      = (OccEnv Name -> OccEnv Name -> OccEnv Name)
    -> OrigNameCache -> Module -> OccEnv Name -> OrigNameCache
    forall a.
    (a -> a -> a) -> ModuleEnv a -> Module -> a -> ModuleEnv a
    extendModuleEnvWith OccEnv Name -> OccEnv Name -> OccEnv Name
    combine OrigNameCache
    nc Module
    mod (OccName -> Name -> OccEnv Name
    forall a. OccName -> a -> OccEnv a
    unitOccEnv OccName
    occ Name
    name)
      where
        combine :: OccEnv Name -> OccEnv Name -> OccEnv Name
    combine OccEnv Name
    _ OccEnv Name
    occ_env = OccEnv Name -> OccName -> Name -> OccEnv Name
    forall a. OccEnv a -> OccName -> a -> OccEnv a
    extendOccEnv OccEnv Name
    occ_env OccName
    occ Name
    name

    initNameCache :: Char -> [Name] -> IO NameCache
    initNameCache :: Char -> [Name] -> IO NameCache
    initNameCache Char
    c [Name]
    names = Char -> MVar OrigNameCache -> NameCache
    NameCache Char
    c (MVar OrigNameCache -> NameCache)
    -> IO (MVar OrigNameCache) -> IO NameCache
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> OrigNameCache -> IO (MVar OrigNameCache)
    forall a. a -> IO (MVar a)
    newMVar ([Name] -> OrigNameCache
    initOrigNames [Name]
    names)

    initOrigNames :: [Name] -> OrigNameCache
    initOrigNames :: [Name] -> OrigNameCache
    initOrigNames [Name]
    names = (OrigNameCache -> Name -> OrigNameCache)
    -> OrigNameCache -> [Name] -> OrigNameCache
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' OrigNameCache -> Name -> OrigNameCache
    extendOrigNameCache' OrigNameCache
    forall a. ModuleEnv a
    emptyModuleEnv [Name]
    names

    -- | Update the name cache with the given function
    updateNameCache'
      :: NameCache
      -> (OrigNameCache -> IO (OrigNameCache, c))  -- The updating function
      -> IO c
    updateNameCache' :: forall c.
    NameCache -> (OrigNameCache -> IO (OrigNameCache, c)) -> IO c
    updateNameCache' (NameCache Char
    _c MVar OrigNameCache
    nc) OrigNameCache -> IO (OrigNameCache, c)
    upd_fn = MVar OrigNameCache
    -> (OrigNameCache -> IO (OrigNameCache, c)) -> IO c
    forall a b. MVar a -> (a -> IO (a, b)) -> IO b
    modifyMVar' MVar OrigNameCache
    nc OrigNameCache -> IO (OrigNameCache, c)
    upd_fn

    -- this should be in `base`
    modifyMVar' :: MVar a -> (a -> IO (a,b)) -> IO b
    modifyMVar' :: forall a b. MVar a -> (a -> IO (a, b)) -> IO b
    modifyMVar' MVar a
    m a -> IO (a, b)
    f = MVar a -> (a -> IO (a, b)) -> IO b
    forall a b. MVar a -> (a -> IO (a, b)) -> IO b
    modifyMVar MVar a
    m ((a -> IO (a, b)) -> IO b) -> (a -> IO (a, b)) -> IO b
    forall a b. (a -> b) -> a -> b
    $ a -> IO (a, b)
    f (a -> IO (a, b)) -> ((a, b) -> IO (a, b)) -> a -> IO (a, b)
    forall (m :: * -> *) a b c.
    Monad m =>
    (a -> m b) -> (b -> m c) -> a -> m c
    >=> \(a, b)
    c -> (a, b) -> a
    forall a b. (a, b) -> a
    fst (a, b)
    c a -> IO (a, b) -> IO (a, b)
    forall a b. a -> b -> b
    `seq` (a, b) -> IO (a, b)
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (a, b)
    c

    -- | Update the name cache with the given function
    --
    -- Additionally, it ensures that the given Module and OccName are evaluated.
    -- If not, chaos can ensue:
    --      we read the name-cache
    --      then pull on mod (say)
    --      which does some stuff that modifies the name cache
    -- This did happen, with tycon_mod in GHC.IfaceToCore.tcIfaceAlt (DataAlt..)
    updateNameCache
      :: NameCache
      -> Module
      -> OccName
      -> (OrigNameCache -> IO (OrigNameCache, c))
      -> IO c
    updateNameCache :: forall c.
    NameCache
    -> Module
    -> OccName
    -> (OrigNameCache -> IO (OrigNameCache, c))
    -> IO c
    updateNameCache NameCache
    name_cache !Module
    _mod !OccName
    _occ OrigNameCache -> IO (OrigNameCache, c)
    upd_fn
      = NameCache -> (OrigNameCache -> IO (OrigNameCache, c)) -> IO c
    forall c.
    NameCache -> (OrigNameCache -> IO (OrigNameCache, c)) -> IO c
    updateNameCache' NameCache
    name_cache OrigNameCache -> IO (OrigNameCache, c)
    upd_fn