module Agda.TypeChecking.DeadCode (eliminateDeadCode) where

import qualified Control.Exception as E
import Control.Monad.Trans

import Data.Maybe
import Data.Monoid (All(..))
import qualified Data.Map.Strict as MapS
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.HashMap.Strict as HMap

import Agda.Interaction.Options

import qualified Agda.Syntax.Abstract as A

import Agda.Syntax.Common
import Agda.Syntax.Internal
import Agda.Syntax.Internal.MetaVars
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.TypeChecking.Reduce

import Agda.Utils.Impossible
import Agda.Utils.Lens
import Agda.Utils.WithDefault

-- | Run before serialisation to remove any definitions and
-- meta-variables that are not reachable from the module's public
-- interface.
--
-- Things that are reachable only from warnings are removed.

eliminateDeadCode ::
  BuiltinThings PrimFun -> DisplayForms -> Signature ->
  LocalMetaStore ->
  TCM (DisplayForms, Signature, RemoteMetaStore)
eliminateDeadCode :: BuiltinThings PrimFun
-> HashMap QName [LocalDisplayForm]
-> Signature
-> LocalMetaStore
-> TCM
     (HashMap QName [LocalDisplayForm], Signature, RemoteMetaStore)
eliminateDeadCode BuiltinThings PrimFun
bs HashMap QName [LocalDisplayForm]
disp Signature
sig LocalMetaStore
ms = forall (m :: * -> *) c.
MonadBench m =>
Account (BenchPhase m) -> m c -> m c
Bench.billTo [Phase
Bench.DeadCode] forall a b. (a -> b) -> a -> b
$ do
  PatternSynDefns
patsyn <- forall (m :: * -> *). ReadTCState m => m PatternSynDefns
getPatternSyns
  Set QName
public <- forall a b. (a -> b) -> Set a -> Set b
Set.mapMonotonic AbstractName -> QName
anameName forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScopeInfo -> Set AbstractName
publicNames forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). ReadTCState m => m ScopeInfo
getScope
  Bool
save   <- forall (b :: Bool). KnownBool b => WithDefault b -> Bool
collapseDefault forall b c a. (b -> c) -> (a -> b) -> a -> c
. PragmaOptions -> WithDefault 'False
optSaveMetas forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
  HashMap QName Definition
defs   <- (if Bool
save then forall (m :: * -> *) a. Monad m => a -> m a
return else forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a (m :: * -> *).
(InstantiateFull a, MonadReduce m) =>
a -> m a
instantiateFull)
                 (Signature
sig forall o i. o -> Lens' i o -> i
^. Lens' (HashMap QName Definition) Signature
sigDefinitions)
  -- #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 :: Definition -> Bool
hasCompilePragma = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> Bool
MapS.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. Definition -> CompiledRepresentation
defCompiledRep
      isPrimitive :: Defn -> Bool
isPrimitive = \case
        Primitive{}     -> Bool
True
        PrimitiveSort{} -> Bool
True
        Defn
_ -> Bool
False
      extraRootsFilter :: (a, Definition) -> Maybe a
extraRootsFilter (a
name, Definition
def)
        | Definition -> Bool
hasCompilePragma Definition
def Bool -> Bool -> Bool
|| Defn -> Bool
isPrimitive (Definition -> Defn
theDef Definition
def) = forall a. a -> Maybe a
Just a
name
        | Bool
otherwise = forall a. Maybe a
Nothing
      extraRoots :: Set QName
extraRoots =
        forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {a}. (a, Definition) -> Maybe a
extraRootsFilter forall a b. (a -> b) -> a -> b
$ forall k v. HashMap k v -> [(k, v)]
HMap.toList HashMap QName Definition
defs

      rootNames :: Set QName
rootNames = forall a. Ord a => Set a -> Set a -> Set a
Set.union Set QName
public Set QName
extraRoots
      rootMetas :: Set MetaId
rootMetas =
        if Bool -> Bool
not Bool
save then forall a. Set a
Set.empty else forall a m. (NamesIn a, Collection MetaId m) => a -> m
metasIn
          ( BuiltinThings PrimFun
bs
          , Signature
sig forall o i. o -> Lens' i o -> i
^. Lens' Sections Signature
sigSections
          , Signature
sig forall o i. o -> Lens' i o -> i
^. Lens' RewriteRuleMap Signature
sigRewriteRules
          , forall k v. (k -> v -> Bool) -> HashMap k v -> HashMap k v
HMap.filterWithKey (\QName
x [LocalDisplayForm]
_ -> forall a. Ord a => a -> Set a -> Bool
Set.member QName
x Set QName
rootNames) HashMap QName [LocalDisplayForm]
disp
          )
      (Set QName
rns, Set MetaId
rms) =
        (Set QName, Set MetaId)
-> PatternSynDefns
-> HashMap QName [LocalDisplayForm]
-> HashMap QName Definition
-> LocalMetaStore
-> (Set QName, Set MetaId)
reachableFrom (Set QName
rootNames, Set MetaId
rootMetas) PatternSynDefns
patsyn HashMap QName [LocalDisplayForm]
disp HashMap QName Definition
defs LocalMetaStore
ms
      dead :: Set QName
dead  = forall a. Ord a => [a] -> Set a
Set.fromList (forall k v. HashMap k v -> [k]
HMap.keys HashMap QName Definition
defs) forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set QName
rns
      valid :: LocalDisplayForm -> Bool
valid = All -> Bool
getAll forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a m. (NamesIn a, Monoid m) => (QName -> m) -> a -> m
namesIn' (Bool -> All
All forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set QName
dead))  -- no used name is dead
      defs' :: HashMap QName Definition
defs' = forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
HMap.map ( \ Definition
d -> Definition
d { defDisplay :: [LocalDisplayForm]
defDisplay = forall a. (a -> Bool) -> [a] -> [a]
filter LocalDisplayForm -> Bool
valid (Definition -> [LocalDisplayForm]
defDisplay Definition
d) } )
            forall a b. (a -> b) -> a -> b
$ forall k v. (k -> v -> Bool) -> HashMap k v -> HashMap k v
HMap.filterWithKey (\ QName
x Definition
_ -> forall a. Ord a => a -> Set a -> Bool
Set.member QName
x Set QName
rns) HashMap QName Definition
defs
      disp' :: HashMap QName [LocalDisplayForm]
disp' = forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
HMap.filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) forall a b. (a -> b) -> a -> b
$ forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
HMap.map (forall a. (a -> Bool) -> [a] -> [a]
filter LocalDisplayForm -> Bool
valid) HashMap QName [LocalDisplayForm]
disp
      ms' :: RemoteMetaStore
ms'   = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HMap.fromList forall a b. (a -> b) -> a -> b
$
              forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
                (\(MetaId
m, MetaVariable
mv) ->
                  if Bool -> Bool
not (forall a. Ord a => a -> Set a -> Bool
Set.member MetaId
m Set MetaId
rms)
                  then forall a. Maybe a
Nothing
                  else forall a. a -> Maybe a
Just (MetaId
m, MetaVariable -> RemoteMetaVariable
remoteMetaVariable MetaVariable
mv)) forall a b. (a -> b) -> a -> b
$
              forall k a. Map k a -> [(k, a)]
MapS.toList LocalMetaStore
ms
  -- The hashmaps are forced to WHNF to ensure that the computations
  -- are billed to the right account.
  HashMap QName [LocalDisplayForm]
disp' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO a
E.evaluate HashMap QName [LocalDisplayForm]
disp'
  HashMap QName Definition
defs' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO a
E.evaluate HashMap QName Definition
defs'
  RemoteMetaStore
ms'   <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO a
E.evaluate RemoteMetaStore
ms'
  forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"tc.dead" Int
10 forall a b. (a -> b) -> a -> b
$
    [Char]
"Removed " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall k v. HashMap k v -> Int
HMap.size HashMap QName Definition
defs forall a. Num a => a -> a -> a
- forall k v. HashMap k v -> Int
HMap.size HashMap QName Definition
defs') forall a. [a] -> [a] -> [a]
++
    [Char]
" unused definitions and " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall k a. Map k a -> Int
MapS.size LocalMetaStore
ms forall a. Num a => a -> a -> a
- forall k v. HashMap k v -> Int
HMap.size RemoteMetaStore
ms') forall a. [a] -> [a] -> [a]
++
    [Char]
" unused meta-variables."
  forall (m :: * -> *) a. Monad m => a -> m a
return (HashMap QName [LocalDisplayForm]
disp', forall i o. Lens' i o -> LensSet i o
set Lens' (HashMap QName Definition) Signature
sigDefinitions HashMap QName Definition
defs' Signature
sig, RemoteMetaStore
ms')

reachableFrom
  :: (Set QName, Set MetaId)  -- ^ Roots.
  -> A.PatternSynDefns -> DisplayForms -> Definitions -> LocalMetaStore
  -> (Set QName, Set MetaId)
reachableFrom :: (Set QName, Set MetaId)
-> PatternSynDefns
-> HashMap QName [LocalDisplayForm]
-> HashMap QName Definition
-> LocalMetaStore
-> (Set QName, Set MetaId)
reachableFrom (Set QName
ids, Set MetaId
ms) PatternSynDefns
psyns HashMap QName [LocalDisplayForm]
disp HashMap QName Definition
defs LocalMetaStore
insts =
  (Set QName, Set MetaId)
-> [Either QName MetaId] -> (Set QName, Set MetaId)
follow (Set QName
ids, Set MetaId
ms)
    (forall a b. (a -> b) -> [a] -> [b]
map forall a b. a -> Either a b
Left (forall a. Set a -> [a]
Set.toList Set QName
ids) forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a b. b -> Either a b
Right (forall a. Set a -> [a]
Set.toList Set MetaId
ms))
  where
  follow :: (Set QName, Set MetaId)
-> [Either QName MetaId] -> (Set QName, Set MetaId)
follow (Set QName, Set MetaId)
seen        []       = (Set QName, Set MetaId)
seen
  follow (!Set QName
ids, !Set MetaId
ms) (Either QName MetaId
x : [Either QName MetaId]
xs) =
    (Set QName, Set MetaId)
-> [Either QName MetaId] -> (Set QName, Set MetaId)
follow (forall a. Ord a => Set a -> Set a -> Set a
Set.union Set QName
ids'' Set QName
ids, forall a. Ord a => Set a -> Set a -> Set a
Set.union Set MetaId
ms'' Set MetaId
ms)
      (forall a b. (a -> b) -> [a] -> [b]
map forall a b. a -> Either a b
Left  (forall a. Set a -> [a]
Set.toList Set QName
ids'') forall a. [a] -> [a] -> [a]
++
       forall a b. (a -> b) -> [a] -> [b]
map forall a b. b -> Either a b
Right (forall a. Set a -> [a]
Set.toList Set MetaId
ms'')  forall a. [a] -> [a] -> [a]
++
       [Either QName MetaId]
xs)
    where
    ids'' :: Set QName
ids'' = Set QName
ids' forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set QName
ids
    ms'' :: Set MetaId
ms''  = Set MetaId
ms'  forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set MetaId
ms

    (Set QName
ids', Set MetaId
ms') = case Either QName MetaId
x of
      Left QName
x ->
        forall a m1 m2.
(NamesIn a, Collection QName m1, Collection MetaId m2) =>
a -> (m1, m2)
namesAndMetasIn
          ( forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup QName
x HashMap QName Definition
defs
          , PatternSynDefn -> PSyn
PSyn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
MapS.lookup QName
x PatternSynDefns
psyns
          , forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup QName
x HashMap QName [LocalDisplayForm]
disp
          )
      Right MetaId
m -> case forall k a. Ord k => k -> Map k a -> Maybe a
MapS.lookup MetaId
m LocalMetaStore
insts of
        Maybe MetaVariable
Nothing -> (forall a. Set a
Set.empty, forall a. Set a
Set.empty)
        Just MetaVariable
mv -> forall a m1 m2.
(NamesIn a, Collection QName m1, Collection MetaId m2) =>
a -> (m1, m2)
namesAndMetasIn (Instantiation -> Term
instBody (MetaVariable -> Instantiation
theInstantiation MetaVariable
mv))

-- | 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
  Open{}                         -> forall a. HasCallStack => a
__IMPOSSIBLE__
  OpenInstance{}                 -> forall a. HasCallStack => a
__IMPOSSIBLE__
  BlockedConst{}                 -> forall a. HasCallStack => a
__IMPOSSIBLE__
  PostponedTypeCheckingProblem{} -> 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      = forall a. LensModality a => a -> Modality
getModality MetaVariable
mv
  , rmvJudgement :: Judgement MetaId
rmvJudgement     = MetaVariable -> Judgement MetaId
mvJudgement MetaVariable
mv
  }