SymbolCache.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RecordWildCards #-}

-- | The SymbolCache is used to cache lookups for specific symbols when using
-- the interpreter.
module GHC.Runtime.Interpreter.Types.SymbolCache (
     InterpSymbolCache(..)
   , mkInterpSymbolCache
   , lookupInterpSymbolCache
   , updateInterpSymbolCache
   , purgeInterpSymbolCache
   , InterpSymbol(..)
   , SuffixOrInterpreted(..)
   , interpSymbolName
   , interpSymbolSuffix
   , eliminateInterpSymbol
   , interpretedInterpSymbol
   ) where

import GHC.Prelude

import GHC.Types.Unique.FM
import GHC.Types.Name
import GHC.Data.FastString
import Foreign

import Control.Concurrent
import GHC.Utils.Outputable
import GHC.TypeLits


-- The symbols records the suffix which each cache deals with.
newtype SymbolCache (s :: Symbol) = SymbolCache { _getSymbolCache :: UniqFM Name (Ptr ()) }

-- Each cache is keyed by Name, there is one cache for each type of symbol we will
-- potentially lookup. The caches are keyed by 'Name' so that it is not necessary to consult
-- a complicated `FastString` each time.
data InterpSymbolCache = InterpSymbolCache {
        interpClosureCache :: MVar (SymbolCache "closure")
      , interpConInfoCache :: MVar (SymbolCache "con_info")
      , interpStaticInfoCache :: MVar (SymbolCache "static_info")
      , interpBytesCache   :: MVar (SymbolCache "bytes")
      , interpFaststringCache   :: MVar (UniqFM FastString (Ptr ()))
      }

data SuffixOrInterpreted = Suffix Symbol | Interpreted

data InterpSymbol (s :: SuffixOrInterpreted) where
  IClosureSymbol :: Name -> InterpSymbol (Suffix "closure")
  IConInfoSymbol :: Name -> InterpSymbol (Suffix "con_info")
  IStaticInfoSymbol :: Name -> InterpSymbol (Suffix "static_info")
  IBytesSymbol   :: Name -> InterpSymbol (Suffix "bytes")
  IFaststringSymbol   :: FastString -> InterpSymbol Interpreted

instance Outputable (InterpSymbol s) where
  ppr s = eliminateInterpSymbol s
            (\(IFaststringSymbol s) -> text "interpreted:" <> ppr s)
            (\s -> text (interpSymbolSuffix s) <> colon <> ppr (interpSymbolName s))

eliminateInterpSymbol :: InterpSymbol s -> (InterpSymbol Interpreted -> r)
                                        -> (forall x . InterpSymbol (Suffix x) -> r)
                                        -> r
eliminateInterpSymbol s k1 k2 =
  case s of
    IFaststringSymbol {} -> k1 s
    IBytesSymbol {}      -> k2 s
    IStaticInfoSymbol {} -> k2 s
    IConInfoSymbol {}    -> k2 s
    IClosureSymbol {}    -> k2 s


interpSymbolName :: InterpSymbol (Suffix s) -> Name
interpSymbolName (IClosureSymbol n) = n
interpSymbolName (IConInfoSymbol n) = n
interpSymbolName (IStaticInfoSymbol n) = n
interpSymbolName (IBytesSymbol n) = n

interpretedInterpSymbol :: InterpSymbol Interpreted -> FastString
interpretedInterpSymbol (IFaststringSymbol s) = s

interpSymbolSuffix :: InterpSymbol (Suffix s) -> String
interpSymbolSuffix (IClosureSymbol {}) = "closure"
interpSymbolSuffix (IConInfoSymbol {}) = "con_info"
interpSymbolSuffix (IStaticInfoSymbol {}) = "static_info"
interpSymbolSuffix (IBytesSymbol {})      = "bytes"

emptySymbolCache :: SymbolCache s
emptySymbolCache = SymbolCache emptyUFM

lookupSymbolCache :: InterpSymbol (Suffix s) -> SymbolCache s -> Maybe (Ptr ())
lookupSymbolCache s (SymbolCache cache) = lookupUFM cache (interpSymbolName s)

insertSymbolCache :: InterpSymbol (Suffix s) -> Ptr () -> SymbolCache s -> SymbolCache s
insertSymbolCache s v (SymbolCache cache) = SymbolCache (addToUFM cache (interpSymbolName s) v)

lookupInterpSymbolCache :: InterpSymbol s -> InterpSymbolCache -> IO (Maybe (Ptr ()))
lookupInterpSymbolCache = withInterpSymbolCache
                            (\(IFaststringSymbol f) mvar_var -> (\cache -> lookupUFM cache f) <$> readMVar mvar_var)
                            (\s mvar_var -> lookupSymbolCache s <$> readMVar mvar_var)


updateInterpSymbolCache :: InterpSymbol s
                                 -> InterpSymbolCache -> Ptr () -> IO ()
updateInterpSymbolCache = withInterpSymbolCache
                            (\(IFaststringSymbol f) mvar_var v -> modifyMVar_ mvar_var (\cache -> pure $ addToUFM cache f v))
                            (\s mvar_var v -> modifyMVar_ mvar_var (\cache -> pure $ insertSymbolCache s v cache))

withInterpSymbolCache ::
                (InterpSymbol Interpreted -> MVar (UniqFM FastString (Ptr ())) -> r)
                -> (forall x . InterpSymbol (Suffix x) -> MVar (SymbolCache x) -> r)
                -> InterpSymbol s
                -> InterpSymbolCache
                -> r
withInterpSymbolCache k1 k2 key InterpSymbolCache{..} =
  case key of
    IClosureSymbol {} -> k2 key interpClosureCache
    IConInfoSymbol {} -> k2 key interpConInfoCache
    IStaticInfoSymbol {} -> k2 key interpStaticInfoCache
    IBytesSymbol {} -> k2 key interpBytesCache
    IFaststringSymbol {} -> k1 key interpFaststringCache

-- | Clear all symbol caches.
purgeInterpSymbolCache :: InterpSymbolCache -> IO ()
purgeInterpSymbolCache (InterpSymbolCache a b c d e) = do
  modifyMVar_ a (\_ ->  do
    modifyMVar_ b (\_ -> do
      modifyMVar_ c (\_ -> do
        modifyMVar_ d (\_ -> do
          modifyMVar_ e (\_ -> pure emptyUFM)
          pure emptySymbolCache)
        pure emptySymbolCache)
      pure emptySymbolCache)
    pure emptySymbolCache)

mkInterpSymbolCache :: IO InterpSymbolCache
mkInterpSymbolCache = do
  InterpSymbolCache <$> newMVar emptySymbolCache
                    <*> newMVar emptySymbolCache
                    <*> newMVar emptySymbolCache
                    <*> newMVar emptySymbolCache
                    <*> newMVar emptyUFM