{-# OPTIONS_GHC -Wunused-imports #-}

module Agda.TypeChecking.DeadCode (eliminateDeadCode) where

import Control.Monad ((<$!>), filterM)
import Control.Monad.Trans

import Data.Maybe
import qualified Data.Map as Map
import qualified Data.Map.Strict as MapS
import qualified Data.HashMap.Strict as HMap

import Agda.Syntax.Common
import Agda.Syntax.Internal
import Agda.Syntax.Internal.Names
import Agda.Syntax.Scope.Base

import qualified Agda.Benchmarking as Bench
import qualified Agda.TypeChecking.Monad.Benchmark as Bench

import Agda.TypeChecking.Monad

import Agda.Utils.Monad (mapMaybeM)
import Agda.Utils.Impossible
import Agda.Utils.Lens

import Agda.Utils.HashTable (HashTable)
import qualified Agda.Utils.HashTable as HT

-- | Run before serialisation to remove data that's not reachable from the
--   public interface. We do not compute reachable data precisely, because that
--   would be very expensive, mainly because of rewrite rules. The following
--   things are assumed to be "roots":
--     - public names (for definitions and pattern synonyms)
--     - definitions marked as primitive
--     - definitions with COMPILE pragma
--     - parameter sections of public modules
--     - local builtins
--     - all rewrite rules
--   We only ever prune dead metavariables and definitions. The reachable ones
--   are returned from this function.
eliminateDeadCode :: ScopeInfo -> TCM (RemoteMetaStore, Definitions)
eliminateDeadCode :: ScopeInfo -> TCM (RemoteMetaStore, Definitions)
eliminateDeadCode !ScopeInfo
scope = Account (BenchPhase (TCMT IO))
-> TCM (RemoteMetaStore, Definitions)
-> TCM (RemoteMetaStore, Definitions)
forall (m :: * -> *) c.
MonadBench m =>
Account (BenchPhase m) -> m c -> m c
Bench.billTo [BenchPhase (TCMT IO)
Phase
Bench.DeadCode] (TCM (RemoteMetaStore, Definitions)
 -> TCM (RemoteMetaStore, Definitions))
-> TCM (RemoteMetaStore, Definitions)
-> TCM (RemoteMetaStore, Definitions)
forall a b. (a -> b) -> a -> b
$ do
  !sig <- TCMT IO Signature
forall (m :: * -> *). ReadTCState m => m Signature
getSignature
  let !defs = Signature
sig Signature -> Lens' Signature Definitions -> Definitions
forall o i. o -> Lens' o i -> i
^. (Definitions -> f Definitions) -> Signature -> f Signature
Lens' Signature Definitions
sigDefinitions
  !psyns <- getPatternSyns
  !metas <- useR stSolvedMetaStore

  -- #2921: Eliminating definitions with attached COMPILE pragmas results in
  -- the pragmas not being checked. Simple solution: don't eliminate these.
  -- #6022 (Andreas, 2022-09-30): Eliminating cubical primitives can lead to crashes.
  -- Simple solution: retain all primitives (shouldn't be many).
  let hasCompilePragma = Bool -> Bool
not (Bool -> Bool) -> (Definition -> Bool) -> Definition -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map BackendName [CompilerPragma] -> Bool
forall k a. Map k a -> Bool
MapS.null (Map BackendName [CompilerPragma] -> Bool)
-> (Definition -> Map BackendName [CompilerPragma])
-> Definition
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Definition -> Map BackendName [CompilerPragma]
defCompiledRep

      isPrimitive = \case
        Primitive{}     -> Bool
True
        PrimitiveSort{} -> Bool
True
        Defn
_               -> Bool
False

      extraRootsFilter (a
name, Definition
def)
        | Definition -> Bool
hasCompilePragma Definition
def Bool -> Bool -> Bool
|| Defn -> Bool
isPrimitive (Definition -> Defn
theDef Definition
def) = a -> Maybe a
forall a. a -> Maybe a
Just a
name
        | Bool
otherwise = Maybe a
forall a. Maybe a
Nothing

  let !pubModules = ScopeInfo -> Map ModuleName Scope
publicModules ScopeInfo
scope

  let !rootPubNames  = (AbstractName -> QName) -> [AbstractName] -> [QName]
forall a b. (a -> b) -> [a] -> [b]
map AbstractName -> QName
anameName ([AbstractName] -> [QName]) -> [AbstractName] -> [QName]
forall a b. (a -> b) -> a -> b
$ Map ModuleName Scope -> [AbstractName]
publicNamesOfModules Map ModuleName Scope
pubModules
  let !rootExtraDefs = ((QName, Definition) -> Maybe QName)
-> [(QName, Definition)] -> [QName]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (QName, Definition) -> Maybe QName
forall {a}. (a, Definition) -> Maybe a
extraRootsFilter ([(QName, Definition)] -> [QName])
-> [(QName, Definition)] -> [QName]
forall a b. (a -> b) -> a -> b
$ Definitions -> [(QName, Definition)]
forall k v. HashMap k v -> [(k, v)]
HMap.toList Definitions
defs
  let !rootRewrites  = Signature
sig Signature -> Lens' Signature RewriteRuleMap -> RewriteRuleMap
forall o i. o -> Lens' o i -> i
^. (RewriteRuleMap -> f RewriteRuleMap) -> Signature -> f Signature
Lens' Signature RewriteRuleMap
sigRewriteRules

  -- Andreas, Oskar, 2023-10-19, issue #6931:
  -- Needed to avoid deleting parameter sections of empty modules.
  let !rootModSections = (Signature
sig Signature
-> Lens' Signature (Map ModuleName Section)
-> Map ModuleName Section
forall o i. o -> Lens' o i -> i
^. (Map ModuleName Section -> f (Map ModuleName Section))
-> Signature -> f Signature
Lens' Signature (Map ModuleName Section)
sigSections) Map ModuleName Section
-> Map ModuleName Scope -> Map ModuleName Section
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.intersection` Map ModuleName Scope
pubModules
  !rootBuiltins <- useTC stLocalBuiltins

  !seenNames <- liftIO HT.empty :: TCM (HashTable QName ())
  !seenMetas <- liftIO HT.empty :: TCM (HashTable MetaId ())

  let goName :: QName -> IO ()
      goName !QName
x = HashTable QName () -> QName -> IO (Maybe ())
forall k v.
(Eq k, Hashable k) =>
HashTable k v -> k -> IO (Maybe v)
HT.lookup HashTable QName ()
seenNames QName
x IO (Maybe ()) -> (Maybe () -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just ()
_ ->
          () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Maybe ()
Nothing -> do
          HashTable QName () -> QName -> () -> IO ()
forall k v. (Eq k, Hashable k) => HashTable k v -> k -> v -> IO ()
HT.insert HashTable QName ()
seenNames QName
x ()
          Maybe Definition -> IO ()
forall a. NamesIn a => a -> IO ()
go (QName -> Definitions -> Maybe Definition
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup QName
x Definitions
defs)
          Maybe PSyn -> IO ()
forall a. NamesIn a => a -> IO ()
go (PatternSynDefn -> PSyn
PSyn (PatternSynDefn -> PSyn) -> Maybe PatternSynDefn -> Maybe PSyn
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> QName -> PatternSynDefns -> Maybe PatternSynDefn
forall k a. Ord k => k -> Map k a -> Maybe a
MapS.lookup QName
x PatternSynDefns
psyns)

      goMeta :: MetaId -> IO ()
      goMeta !MetaId
m = HashTable MetaId () -> MetaId -> IO (Maybe ())
forall k v.
(Eq k, Hashable k) =>
HashTable k v -> k -> IO (Maybe v)
HT.lookup HashTable MetaId ()
seenMetas MetaId
m IO (Maybe ()) -> (Maybe () -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just ()
_ ->
          () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Maybe ()
Nothing -> do
          HashTable MetaId () -> MetaId -> () -> IO ()
forall k v. (Eq k, Hashable k) => HashTable k v -> k -> v -> IO ()
HT.insert HashTable MetaId ()
seenMetas MetaId
m ()
          case MetaId -> Map MetaId MetaVariable -> Maybe MetaVariable
forall k a. Ord k => k -> Map k a -> Maybe a
MapS.lookup MetaId
m Map MetaId MetaVariable
metas of
            Maybe MetaVariable
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Just MetaVariable
mv -> do
              Term -> IO ()
forall a. NamesIn a => a -> IO ()
go (Instantiation -> Term
instBody (MetaVariable -> Instantiation
theInstantiation MetaVariable
mv))
              Type -> IO ()
forall a. NamesIn a => a -> IO ()
go (Judgement MetaId -> Type
forall a. Judgement a -> Type
jMetaType (MetaVariable -> Judgement MetaId
mvJudgement MetaVariable
mv))

      go :: NamesIn a => a -> IO ()
      go !a
x = (Either QName MetaId -> IO ()) -> a -> IO ()
forall m. Monoid m => (Either QName MetaId -> m) -> a -> m
forall a m.
(NamesIn a, Monoid m) =>
(Either QName MetaId -> m) -> a -> m
namesAndMetasIn' ((QName -> IO ())
-> (MetaId -> IO ()) -> Either QName MetaId -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either QName -> IO ()
goName MetaId -> IO ()
goMeta) a
x
      {-# INLINE go #-}

  Bench.billTo [Bench.DeadCode, Bench.DeadCodeReachable] $ liftIO $ do
    foldMap goName rootPubNames
    foldMap goName rootExtraDefs
    go rootRewrites
    go rootModSections
    go rootBuiltins

  let filterMeta :: (MetaId, MetaVariable) -> IO (Maybe (MetaId, RemoteMetaVariable))
      filterMeta (!MetaId
i, !MetaVariable
m) = HashTable MetaId () -> MetaId -> IO (Maybe ())
forall k v.
(Eq k, Hashable k) =>
HashTable k v -> k -> IO (Maybe v)
HT.lookup HashTable MetaId ()
seenMetas MetaId
i IO (Maybe ())
-> (Maybe () -> IO (Maybe (MetaId, RemoteMetaVariable)))
-> IO (Maybe (MetaId, RemoteMetaVariable))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe ()
Nothing -> Maybe (MetaId, RemoteMetaVariable)
-> IO (Maybe (MetaId, RemoteMetaVariable))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (MetaId, RemoteMetaVariable)
forall a. Maybe a
Nothing
        Just ()
_  -> let !m' :: RemoteMetaVariable
m' = MetaVariable -> RemoteMetaVariable
remoteMetaVariable MetaVariable
m in Maybe (MetaId, RemoteMetaVariable)
-> IO (Maybe (MetaId, RemoteMetaVariable))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (MetaId, RemoteMetaVariable)
 -> IO (Maybe (MetaId, RemoteMetaVariable)))
-> Maybe (MetaId, RemoteMetaVariable)
-> IO (Maybe (MetaId, RemoteMetaVariable))
forall a b. (a -> b) -> a -> b
$ (MetaId, RemoteMetaVariable) -> Maybe (MetaId, RemoteMetaVariable)
forall a. a -> Maybe a
Just (MetaId
i, RemoteMetaVariable
m')

      filterDef :: (QName, Definition) -> IO Bool
      filterDef (!QName
x, !Definition
d) = HashTable QName () -> QName -> IO (Maybe ())
forall k v.
(Eq k, Hashable k) =>
HashTable k v -> k -> IO (Maybe v)
HT.lookup HashTable QName ()
seenNames QName
x IO (Maybe ()) -> (Maybe () -> IO Bool) -> IO Bool
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe ()
Nothing -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
        Just ()
_  -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

  !metas <- liftIO $ HMap.fromList <$> mapMaybeM filterMeta (MapS.toList metas)
  !defs  <- liftIO $ HMap.fromList <$> filterM filterDef (HMap.toList defs)
  pure (metas, defs)

-- | Returns the instantiation.
--   Precondition: The instantiation must be of the form @'InstV' inst@.
theInstantiation :: MetaVariable -> Instantiation
theInstantiation :: MetaVariable -> Instantiation
theInstantiation MetaVariable
mv = case MetaVariable -> MetaInstantiation
mvInstantiation MetaVariable
mv of
  InstV Instantiation
inst                     -> Instantiation
inst
  OpenMeta{}                     -> Instantiation
forall a. HasCallStack => a
__IMPOSSIBLE__
  BlockedConst{}                 -> Instantiation
forall a. HasCallStack => a
__IMPOSSIBLE__
  PostponedTypeCheckingProblem{} -> Instantiation
forall a. HasCallStack => a
__IMPOSSIBLE__

-- | Converts from 'MetaVariable' to 'RemoteMetaVariable'.
--   Precondition: The instantiation must be of the form @'InstV' inst@.
remoteMetaVariable :: MetaVariable -> RemoteMetaVariable
remoteMetaVariable :: MetaVariable -> RemoteMetaVariable
remoteMetaVariable !MetaVariable
mv = RemoteMetaVariable
  { rmvInstantiation :: Instantiation
rmvInstantiation = MetaVariable -> Instantiation
theInstantiation MetaVariable
mv
  , rmvModality :: Modality
rmvModality      = MetaVariable -> Modality
forall a. LensModality a => a -> Modality
getModality MetaVariable
mv
  , rmvJudgement :: Judgement MetaId
rmvJudgement     = MetaVariable -> Judgement MetaId
mvJudgement MetaVariable
mv
  }