-- | This module implements some analyses of Core expressions necessary for
-- "Test.Inspection". Normally, users of this package can ignore this module.
{-# LANGUAGE CPP, FlexibleContexts #-}
module Test.Inspection.Core
  ( slice
  , pprSlice
  , pprSliceDifference
  , eqSlice
  , freeOfType
  , freeOfTerm
  , doesNotAllocate
  , doesNotContainTypeClasses
  ) where

#if MIN_VERSION_ghc(9,0,0)
import GHC.Core
import GHC.Core.Utils
import GHC.Core.TyCo.Rep
import GHC.Core.Type
import GHC.Types.Var as Var
import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.Var.Env
import GHC.Utils.Outputable as Outputable
import GHC.Core.Ppr
import GHC.Core.Coercion
import GHC.Utils.Misc
import GHC.Core.DataCon
import GHC.Core.TyCon (TyCon, isClassTyCon)
#else
import CoreSyn
import CoreUtils
import TyCoRep
import Type
import Var
import Id
import Name
import VarEnv
import Outputable
import PprCore
import Coercion
import Util
import DataCon
import TyCon (TyCon, isClassTyCon)
#endif

import qualified Data.Set as S
import Control.Monad.State.Strict
import Control.Monad.Trans.Maybe
import Data.List (nub)
import Data.Maybe

type Slice = [(Var, CoreExpr)]

-- | Selects those bindings that define the given variable (with this variable first)
slice :: [(Var, CoreExpr)] -> Var -> Slice
slice :: [(Var, CoreExpr)] -> Var -> [(Var, CoreExpr)]
slice [(Var, CoreExpr)]
binds Var
v
    | Just CoreExpr
e <- Var -> [(Var, CoreExpr)] -> Maybe CoreExpr
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Var
v [(Var, CoreExpr)]
binds
    = (Var
v,CoreExpr
e) (Var, CoreExpr) -> [(Var, CoreExpr)] -> [(Var, CoreExpr)]
forall a. a -> [a] -> [a]
: [(Var
v',CoreExpr
e) | (Var
v',CoreExpr
e) <- [(Var, CoreExpr)]
binds, Var
v' Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
/= Var
v, Var
v' Var -> Set Var -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Var
used ]
    | Bool
otherwise
    = [Char] -> [(Var, CoreExpr)]
forall a. HasCallStack => [Char] -> a
error [Char]
"slice: cannot find given variable in bindings"
  where
    used :: Set Var
used = State (Set Var) () -> Set Var -> Set Var
forall s a. State s a -> s -> s
execState (Var -> State (Set Var) ()
forall (m :: * -> *). MonadState (Set Var) m => Var -> m ()
goV Var
v) Set Var
forall a. Set a
S.empty

    local :: Set Var
local = [Var] -> Set Var
forall a. Ord a => [a] -> Set a
S.fromList (((Var, CoreExpr) -> Var) -> [(Var, CoreExpr)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, CoreExpr) -> Var
forall a b. (a, b) -> a
fst [(Var, CoreExpr)]
binds)
    goV :: Var -> m ()
goV Var
v | Var
v Var -> Set Var -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Var
local = do
        Bool
seen <- (Set Var -> Bool) -> m Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Var
v Var -> Set Var -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member`)
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
seen (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            (Set Var -> Set Var) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Var -> Set Var -> Set Var
forall a. Ord a => a -> Set a -> Set a
S.insert Var
v)
            let Just CoreExpr
e = Var -> [(Var, CoreExpr)] -> Maybe CoreExpr
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Var
v [(Var, CoreExpr)]
binds
            CoreExpr -> m ()
go CoreExpr
e
          | Bool
otherwise = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    go :: CoreExpr -> m ()
go (Var Var
v)                     = Var -> m ()
goV Var
v
    go (Lit Literal
_ )                    = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    go (App CoreExpr
e CoreExpr
arg) | CoreExpr -> Bool
forall b. Expr b -> Bool
isTyCoArg CoreExpr
arg = CoreExpr -> m ()
go CoreExpr
e
    go (App CoreExpr
e CoreExpr
arg)                 = CoreExpr -> m ()
go CoreExpr
e m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CoreExpr -> m ()
go CoreExpr
arg
    go (Lam Var
_ CoreExpr
e)                   = CoreExpr -> m ()
go CoreExpr
e
    go (Let Bind Var
bind CoreExpr
body)             = (CoreExpr -> m ()) -> [CoreExpr] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CoreExpr -> m ()
go (Bind Var -> [CoreExpr]
forall b. Bind b -> [Expr b]
rhssOfBind Bind Var
bind) m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CoreExpr -> m ()
go CoreExpr
body
    go (Case CoreExpr
s Var
_ Type
_ [Alt Var]
alts)           = CoreExpr -> m ()
go CoreExpr
s m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Alt Var -> m ()) -> [Alt Var] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Alt Var -> m ()
goA [Alt Var]
alts
    go (Cast CoreExpr
e Coercion
_)                  = CoreExpr -> m ()
go CoreExpr
e
    go (Tick Tickish Var
_ CoreExpr
e)                  = CoreExpr -> m ()
go CoreExpr
e
    go (Type Type
_)                    = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    go (Coercion Coercion
_)                = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    goA :: Alt Var -> m ()
goA (AltCon
_, [Var]
_, CoreExpr
e) = CoreExpr -> m ()
go CoreExpr
e

-- | Pretty-print a slice
pprSlice :: Slice -> SDoc
pprSlice :: [(Var, CoreExpr)] -> SDoc
pprSlice [(Var, CoreExpr)]
slice =
    SDoc -> SDoc
withLessDetail (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [Bind Var] -> SDoc
forall b. OutputableBndr b => [Bind b] -> SDoc
pprCoreBindings [ Var -> CoreExpr -> Bind Var
forall b. b -> Expr b -> Bind b
NonRec Var
v CoreExpr
e  | (Var
v,CoreExpr
e) <- [(Var, CoreExpr)]
slice ]

-- | Pretty-print two slices, after removing variables occurring in both
pprSliceDifference :: Slice -> Slice -> SDoc
pprSliceDifference :: [(Var, CoreExpr)] -> [(Var, CoreExpr)] -> SDoc
pprSliceDifference [(Var, CoreExpr)]
slice1 [(Var, CoreExpr)]
slice2 =
    Int -> SDoc -> SDoc
nest Int
4 (SDoc -> Int -> SDoc -> SDoc
hang ([Char] -> SDoc
text [Char]
"LHS" SDoc -> SDoc -> SDoc
Outputable.<> SDoc
colon) Int
4 ([(Var, CoreExpr)] -> SDoc
pprSlice [(Var, CoreExpr)]
slice1')) SDoc -> SDoc -> SDoc
$$
    Int -> SDoc -> SDoc
nest Int
4 (SDoc -> Int -> SDoc -> SDoc
hang ([Char] -> SDoc
text [Char]
"RHS" SDoc -> SDoc -> SDoc
Outputable.<> SDoc
colon) Int
4 ([(Var, CoreExpr)] -> SDoc
pprSlice [(Var, CoreExpr)]
slice2'))
  where
    both :: Set Var
both = Set Var -> Set Var -> Set Var
forall a. Ord a => Set a -> Set a -> Set a
S.intersection ([Var] -> Set Var
forall a. Ord a => [a] -> Set a
S.fromList (((Var, CoreExpr) -> Var) -> [(Var, CoreExpr)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, CoreExpr) -> Var
forall a b. (a, b) -> a
fst [(Var, CoreExpr)]
slice1)) ([Var] -> Set Var
forall a. Ord a => [a] -> Set a
S.fromList (((Var, CoreExpr) -> Var) -> [(Var, CoreExpr)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, CoreExpr) -> Var
forall a b. (a, b) -> a
fst [(Var, CoreExpr)]
slice2))
    slice1' :: [(Var, CoreExpr)]
slice1' = ((Var, CoreExpr) -> Bool) -> [(Var, CoreExpr)] -> [(Var, CoreExpr)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Var
v,CoreExpr
_) -> Var
v Var -> Set Var -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set Var
both) [(Var, CoreExpr)]
slice1
    slice2' :: [(Var, CoreExpr)]
slice2' = ((Var, CoreExpr) -> Bool) -> [(Var, CoreExpr)] -> [(Var, CoreExpr)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Var
v,CoreExpr
_) -> Var
v Var -> Set Var -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set Var
both) [(Var, CoreExpr)]
slice2

withLessDetail :: SDoc -> SDoc
#if MIN_VERSION_GLASGOW_HASKELL(8,2,0,0) && !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
withLessDetail :: SDoc -> SDoc
withLessDetail SDoc
sdoc = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
     PprStyle -> SDoc -> SDoc
withPprStyle (DynFlags -> PprStyle
defaultUserStyle DynFlags
dflags) SDoc
sdoc
#else
withLessDetail sdoc = withPprStyle defaultUserStyle sdoc
#endif

type VarPair = (Var, Var)
type VarPairSet = S.Set VarPair

-- | This is a heuristic, which only works if both slices
-- have auxiliary variables in the right order.
-- (This is mostly to work-around the buggy CSE in GHC-8.0)
-- It also breaks if there is shadowing.
eqSlice :: Bool {- ^ ignore types and hpc ticks -} -> Slice -> Slice -> Bool
eqSlice :: Bool -> [(Var, CoreExpr)] -> [(Var, CoreExpr)] -> Bool
eqSlice Bool
_ [(Var, CoreExpr)]
slice1 [(Var, CoreExpr)]
slice2 | [(Var, CoreExpr)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Var, CoreExpr)]
slice1 Bool -> Bool -> Bool
|| [(Var, CoreExpr)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Var, CoreExpr)]
slice2 = [(Var, CoreExpr)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Var, CoreExpr)]
slice1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== [(Var, CoreExpr)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Var, CoreExpr)]
slice2
  -- Mostly defensive programming (slices should not be empty)
eqSlice Bool
it [(Var, CoreExpr)]
slice1 [(Var, CoreExpr)]
slice2
  = VarPairSet -> VarPairSet -> Bool
step ((Var, Var) -> VarPairSet
forall a. a -> Set a
S.singleton ((Var, CoreExpr) -> Var
forall a b. (a, b) -> a
fst ([(Var, CoreExpr)] -> (Var, CoreExpr)
forall a. [a] -> a
head [(Var, CoreExpr)]
slice1), (Var, CoreExpr) -> Var
forall a b. (a, b) -> a
fst ([(Var, CoreExpr)] -> (Var, CoreExpr)
forall a. [a] -> a
head [(Var, CoreExpr)]
slice2))) VarPairSet
forall a. Set a
S.empty
  where
    step :: VarPairSet -> VarPairSet -> Bool
    step :: VarPairSet -> VarPairSet -> Bool
step VarPairSet
wanted VarPairSet
done
        | VarPairSet
wanted VarPairSet -> VarPairSet -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`S.isSubsetOf` VarPairSet
done
        = Bool
True -- done
        | (Var
x,Var
y) : [(Var, Var)]
_ <- VarPairSet -> [(Var, Var)]
forall a. Set a -> [a]
S.toList (VarPairSet
wanted VarPairSet -> VarPairSet -> VarPairSet
forall a. Ord a => Set a -> Set a -> Set a
`S.difference` VarPairSet
done)
        , (Just ()
_, VarPairSet
wanted') <- State VarPairSet (Maybe ()) -> VarPairSet -> (Maybe (), VarPairSet)
forall s a. State s a -> s -> (a, s)
runState (MaybeT (State VarPairSet) () -> State VarPairSet (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (Var -> Var -> MaybeT (State VarPairSet) ()
equate Var
x Var
y)) VarPairSet
wanted
        = VarPairSet -> VarPairSet -> Bool
step VarPairSet
wanted' ((Var, Var) -> VarPairSet -> VarPairSet
forall a. Ord a => a -> Set a -> Set a
S.insert (Var
x,Var
y) VarPairSet
done)
        | Bool
otherwise
        = Bool
False


    equate :: Var -> Var -> MaybeT (State VarPairSet) ()
    equate :: Var -> Var -> MaybeT (State VarPairSet) ()
equate Var
x Var
y
        | Just CoreExpr
e1 <- Var -> [(Var, CoreExpr)] -> Maybe CoreExpr
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Var
x [(Var, CoreExpr)]
slice1
        , Just Var
x' <- CoreExpr -> Maybe Var
essentiallyVar CoreExpr
e1
        , Var
x' Var -> [Var] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((Var, CoreExpr) -> Var) -> [(Var, CoreExpr)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, CoreExpr) -> Var
forall a b. (a, b) -> a
fst [(Var, CoreExpr)]
slice1
        = State VarPairSet () -> MaybeT (State VarPairSet) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (State VarPairSet () -> MaybeT (State VarPairSet) ())
-> State VarPairSet () -> MaybeT (State VarPairSet) ()
forall a b. (a -> b) -> a -> b
$ (VarPairSet -> VarPairSet) -> State VarPairSet ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Var, Var) -> VarPairSet -> VarPairSet
forall a. Ord a => a -> Set a -> Set a
S.insert (Var
x',Var
y))
        | Just CoreExpr
e2 <- Var -> [(Var, CoreExpr)] -> Maybe CoreExpr
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Var
y [(Var, CoreExpr)]
slice2
        , Just Var
y' <- CoreExpr -> Maybe Var
essentiallyVar CoreExpr
e2
        , Var
y' Var -> [Var] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((Var, CoreExpr) -> Var) -> [(Var, CoreExpr)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, CoreExpr) -> Var
forall a b. (a, b) -> a
fst [(Var, CoreExpr)]
slice2
        = State VarPairSet () -> MaybeT (State VarPairSet) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (State VarPairSet () -> MaybeT (State VarPairSet) ())
-> State VarPairSet () -> MaybeT (State VarPairSet) ()
forall a b. (a -> b) -> a -> b
$ (VarPairSet -> VarPairSet) -> State VarPairSet ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Var, Var) -> VarPairSet -> VarPairSet
forall a. Ord a => a -> Set a -> Set a
S.insert (Var
x,Var
y'))
        | Just CoreExpr
e1 <- Var -> [(Var, CoreExpr)] -> Maybe CoreExpr
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Var
x [(Var, CoreExpr)]
slice1
        , Just CoreExpr
e2 <- Var -> [(Var, CoreExpr)] -> Maybe CoreExpr
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Var
y [(Var, CoreExpr)]
slice2
        = RnEnv2 -> CoreExpr -> CoreExpr -> MaybeT (State VarPairSet) ()
go (InScopeSet -> RnEnv2
mkRnEnv2 InScopeSet
emptyInScopeSet) CoreExpr
e1 CoreExpr
e2
    equate Var
_ Var
_ = MaybeT (State VarPairSet) ()
forall (m :: * -> *) a. MonadPlus m => m a
mzero

    equated :: Var -> Var -> MaybeT (State VarPairSet) ()
    equated :: Var -> Var -> MaybeT (State VarPairSet) ()
equated Var
x Var
y | Var
x Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
y = () -> MaybeT (State VarPairSet) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    equated Var
x Var
y = State VarPairSet () -> MaybeT (State VarPairSet) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (State VarPairSet () -> MaybeT (State VarPairSet) ())
-> State VarPairSet () -> MaybeT (State VarPairSet) ()
forall a b. (a -> b) -> a -> b
$ (VarPairSet -> VarPairSet) -> State VarPairSet ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Var, Var) -> VarPairSet -> VarPairSet
forall a. Ord a => a -> Set a -> Set a
S.insert (Var
x,Var
y))

    essentiallyVar :: CoreExpr -> Maybe Var
    essentiallyVar :: CoreExpr -> Maybe Var
essentiallyVar (App CoreExpr
e CoreExpr
a)  | Bool
it, CoreExpr -> Bool
forall b. Expr b -> Bool
isTyCoArg CoreExpr
a = CoreExpr -> Maybe Var
essentiallyVar CoreExpr
e
    essentiallyVar (Lam Var
v CoreExpr
e)  | Bool
it, Var -> Bool
isTyCoVar Var
v = CoreExpr -> Maybe Var
essentiallyVar CoreExpr
e
    essentiallyVar (Cast CoreExpr
e Coercion
_) | Bool
it              = CoreExpr -> Maybe Var
essentiallyVar CoreExpr
e
    essentiallyVar (Var Var
v)                      = Var -> Maybe Var
forall a. a -> Maybe a
Just Var
v
    essentiallyVar (Tick HpcTick{} CoreExpr
e) | Bool
it      = CoreExpr -> Maybe Var
essentiallyVar CoreExpr
e
    essentiallyVar CoreExpr
_                            = Maybe Var
forall a. Maybe a
Nothing

    go :: RnEnv2 -> CoreExpr -> CoreExpr -> MaybeT (State (S.Set (Var,Var))) ()
    go :: RnEnv2 -> CoreExpr -> CoreExpr -> MaybeT (State VarPairSet) ()
go RnEnv2
env (Var Var
v1) (Var Var
v2) | RnEnv2 -> Var -> Var
rnOccL RnEnv2
env Var
v1 Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== RnEnv2 -> Var -> Var
rnOccR RnEnv2
env Var
v2 = () -> MaybeT (State VarPairSet) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                             | Bool
otherwise = Var -> Var -> MaybeT (State VarPairSet) ()
equated Var
v1 Var
v2
    go RnEnv2
_   (Lit Literal
lit1)    (Lit Literal
lit2)        = Bool -> MaybeT (State VarPairSet) ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> MaybeT (State VarPairSet) ())
-> Bool -> MaybeT (State VarPairSet) ()
forall a b. (a -> b) -> a -> b
$ Literal
lit1 Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== Literal
lit2
    go RnEnv2
env (Type Type
t1)     (Type Type
t2)         = Bool -> MaybeT (State VarPairSet) ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> MaybeT (State VarPairSet) ())
-> Bool -> MaybeT (State VarPairSet) ()
forall a b. (a -> b) -> a -> b
$ RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env Type
t1 Type
t2
    go RnEnv2
env (Coercion Coercion
co1) (Coercion Coercion
co2)   = Bool -> MaybeT (State VarPairSet) ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> MaybeT (State VarPairSet) ())
-> Bool -> MaybeT (State VarPairSet) ()
forall a b. (a -> b) -> a -> b
$ RnEnv2 -> Coercion -> Coercion -> Bool
eqCoercionX RnEnv2
env Coercion
co1 Coercion
co2

    go RnEnv2
env (Cast CoreExpr
e1 Coercion
_) CoreExpr
e2 | Bool
it             = RnEnv2 -> CoreExpr -> CoreExpr -> MaybeT (State VarPairSet) ()
go RnEnv2
env CoreExpr
e1 CoreExpr
e2
    go RnEnv2
env CoreExpr
e1 (Cast CoreExpr
e2 Coercion
_) | Bool
it             = RnEnv2 -> CoreExpr -> CoreExpr -> MaybeT (State VarPairSet) ()
go RnEnv2
env CoreExpr
e1 CoreExpr
e2
    go RnEnv2
env (Cast CoreExpr
e1 Coercion
co1) (Cast CoreExpr
e2 Coercion
co2)     = do Bool -> MaybeT (State VarPairSet) ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (RnEnv2 -> Coercion -> Coercion -> Bool
eqCoercionX RnEnv2
env Coercion
co1 Coercion
co2)
                                                RnEnv2 -> CoreExpr -> CoreExpr -> MaybeT (State VarPairSet) ()
go RnEnv2
env CoreExpr
e1 CoreExpr
e2

    go RnEnv2
env (App CoreExpr
e1 CoreExpr
a) CoreExpr
e2 | Bool
it, CoreExpr -> Bool
forall b. Expr b -> Bool
isTyCoArg CoreExpr
a = RnEnv2 -> CoreExpr -> CoreExpr -> MaybeT (State VarPairSet) ()
go RnEnv2
env CoreExpr
e1 CoreExpr
e2
    go RnEnv2
env CoreExpr
e1 (App CoreExpr
e2 CoreExpr
a) | Bool
it, CoreExpr -> Bool
forall b. Expr b -> Bool
isTyCoArg CoreExpr
a = RnEnv2 -> CoreExpr -> CoreExpr -> MaybeT (State VarPairSet) ()
go RnEnv2
env CoreExpr
e1 CoreExpr
e2
    go RnEnv2
env (App CoreExpr
f1 CoreExpr
a1)   (App CoreExpr
f2 CoreExpr
a2)       = RnEnv2 -> CoreExpr -> CoreExpr -> MaybeT (State VarPairSet) ()
go RnEnv2
env CoreExpr
f1 CoreExpr
f2 MaybeT (State VarPairSet) ()
-> MaybeT (State VarPairSet) () -> MaybeT (State VarPairSet) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RnEnv2 -> CoreExpr -> CoreExpr -> MaybeT (State VarPairSet) ()
go RnEnv2
env CoreExpr
a1 CoreExpr
a2
    go RnEnv2
env (Tick HpcTick{} CoreExpr
e1) CoreExpr
e2 | Bool
it     = RnEnv2 -> CoreExpr -> CoreExpr -> MaybeT (State VarPairSet) ()
go RnEnv2
env CoreExpr
e1 CoreExpr
e2
    go RnEnv2
env CoreExpr
e1 (Tick HpcTick{} CoreExpr
e2) | Bool
it     = RnEnv2 -> CoreExpr -> CoreExpr -> MaybeT (State VarPairSet) ()
go RnEnv2
env CoreExpr
e1 CoreExpr
e2
    go RnEnv2
env (Tick Tickish Var
n1 CoreExpr
e1)  (Tick Tickish Var
n2 CoreExpr
e2)      = Bool -> MaybeT (State VarPairSet) ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (RnEnv2 -> Tickish Var -> Tickish Var -> Bool
go_tick RnEnv2
env Tickish Var
n1 Tickish Var
n2) MaybeT (State VarPairSet) ()
-> MaybeT (State VarPairSet) () -> MaybeT (State VarPairSet) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RnEnv2 -> CoreExpr -> CoreExpr -> MaybeT (State VarPairSet) ()
go RnEnv2
env CoreExpr
e1 CoreExpr
e2

    go RnEnv2
env (Lam Var
b CoreExpr
e1) CoreExpr
e2 | Bool
it, Var -> Bool
isTyCoVar Var
b = RnEnv2 -> CoreExpr -> CoreExpr -> MaybeT (State VarPairSet) ()
go RnEnv2
env CoreExpr
e1 CoreExpr
e2
    go RnEnv2
env CoreExpr
e1 (Lam Var
b CoreExpr
e2) | Bool
it, Var -> Bool
isTyCoVar Var
b = RnEnv2 -> CoreExpr -> CoreExpr -> MaybeT (State VarPairSet) ()
go RnEnv2
env CoreExpr
e1 CoreExpr
e2
    go RnEnv2
env (Lam Var
b1 CoreExpr
e1)  (Lam Var
b2 CoreExpr
e2)
      = do Bool -> MaybeT (State VarPairSet) ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool
it Bool -> Bool -> Bool
|| RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env (Var -> Type
varType Var
b1) (Var -> Type
varType Var
b2))
                -- False for Id/TyVar combination
           RnEnv2 -> CoreExpr -> CoreExpr -> MaybeT (State VarPairSet) ()
go (RnEnv2 -> Var -> Var -> RnEnv2
rnBndr2 RnEnv2
env Var
b1 Var
b2) CoreExpr
e1 CoreExpr
e2

    go RnEnv2
env (Let (NonRec Var
v1 CoreExpr
r1) CoreExpr
e1) (Let (NonRec Var
v2 CoreExpr
r2) CoreExpr
e2)
      = do RnEnv2 -> CoreExpr -> CoreExpr -> MaybeT (State VarPairSet) ()
go RnEnv2
env CoreExpr
r1 CoreExpr
r2  -- No need to check binder types, since RHSs match
           RnEnv2 -> CoreExpr -> CoreExpr -> MaybeT (State VarPairSet) ()
go (RnEnv2 -> Var -> Var -> RnEnv2
rnBndr2 RnEnv2
env Var
v1 Var
v2) CoreExpr
e1 CoreExpr
e2

    go RnEnv2
env (Let (Rec [(Var, CoreExpr)]
ps1) CoreExpr
e1) (Let (Rec [(Var, CoreExpr)]
ps2) CoreExpr
e2)
      = do Bool -> MaybeT (State VarPairSet) ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> MaybeT (State VarPairSet) ())
-> Bool -> MaybeT (State VarPairSet) ()
forall a b. (a -> b) -> a -> b
$ [(Var, CoreExpr)] -> [(Var, CoreExpr)] -> Bool
forall a b. [a] -> [b] -> Bool
equalLength [(Var, CoreExpr)]
ps1 [(Var, CoreExpr)]
ps2
           [MaybeT (State VarPairSet) ()] -> MaybeT (State VarPairSet) ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([MaybeT (State VarPairSet) ()] -> MaybeT (State VarPairSet) ())
-> [MaybeT (State VarPairSet) ()] -> MaybeT (State VarPairSet) ()
forall a b. (a -> b) -> a -> b
$ (CoreExpr -> CoreExpr -> MaybeT (State VarPairSet) ())
-> [CoreExpr] -> [CoreExpr] -> [MaybeT (State VarPairSet) ()]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (RnEnv2 -> CoreExpr -> CoreExpr -> MaybeT (State VarPairSet) ()
go RnEnv2
env') [CoreExpr]
rs1 [CoreExpr]
rs2
           RnEnv2 -> CoreExpr -> CoreExpr -> MaybeT (State VarPairSet) ()
go RnEnv2
env' CoreExpr
e1 CoreExpr
e2
      where
        ([Var]
bs1,[CoreExpr]
rs1) = [(Var, CoreExpr)] -> ([Var], [CoreExpr])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Var, CoreExpr)]
ps1
        ([Var]
bs2,[CoreExpr]
rs2) = [(Var, CoreExpr)] -> ([Var], [CoreExpr])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Var, CoreExpr)]
ps2
        env' :: RnEnv2
env' = RnEnv2 -> [Var] -> [Var] -> RnEnv2
rnBndrs2 RnEnv2
env [Var]
bs1 [Var]
bs2

    go RnEnv2
env (Case CoreExpr
e1 Var
b1 Type
t1 [Alt Var]
a1) (Case CoreExpr
e2 Var
b2 Type
t2 [Alt Var]
a2)
      | [Alt Var] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Alt Var]
a1   -- See Note [Empty case alternatives] in TrieMap
      = do Bool -> MaybeT (State VarPairSet) ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ([Alt Var] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Alt Var]
a2)
           RnEnv2 -> CoreExpr -> CoreExpr -> MaybeT (State VarPairSet) ()
go RnEnv2
env CoreExpr
e1 CoreExpr
e2
           Bool -> MaybeT (State VarPairSet) ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool
it Bool -> Bool -> Bool
|| RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env Type
t1 Type
t2)
      | Bool
otherwise
      = do Bool -> MaybeT (State VarPairSet) ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> MaybeT (State VarPairSet) ())
-> Bool -> MaybeT (State VarPairSet) ()
forall a b. (a -> b) -> a -> b
$ [Alt Var] -> [Alt Var] -> Bool
forall a b. [a] -> [b] -> Bool
equalLength [Alt Var]
a1 [Alt Var]
a2
           RnEnv2 -> CoreExpr -> CoreExpr -> MaybeT (State VarPairSet) ()
go RnEnv2
env CoreExpr
e1 CoreExpr
e2
           [MaybeT (State VarPairSet) ()] -> MaybeT (State VarPairSet) ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([MaybeT (State VarPairSet) ()] -> MaybeT (State VarPairSet) ())
-> [MaybeT (State VarPairSet) ()] -> MaybeT (State VarPairSet) ()
forall a b. (a -> b) -> a -> b
$ (Alt Var -> Alt Var -> MaybeT (State VarPairSet) ())
-> [Alt Var] -> [Alt Var] -> [MaybeT (State VarPairSet) ()]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (RnEnv2 -> Alt Var -> Alt Var -> MaybeT (State VarPairSet) ()
forall a.
Eq a =>
RnEnv2
-> (a, [Var], CoreExpr)
-> (a, [Var], CoreExpr)
-> MaybeT (State VarPairSet) ()
go_alt (RnEnv2 -> Var -> Var -> RnEnv2
rnBndr2 RnEnv2
env Var
b1 Var
b2)) [Alt Var]
a1 [Alt Var]
a2

    go RnEnv2
_ CoreExpr
_ CoreExpr
_ = Bool -> MaybeT (State VarPairSet) ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
False

    -----------
    go_alt :: RnEnv2
-> (a, [Var], CoreExpr)
-> (a, [Var], CoreExpr)
-> MaybeT (State VarPairSet) ()
go_alt RnEnv2
env (a
c1, [Var]
bs1, CoreExpr
e1) (a
c2, [Var]
bs2, CoreExpr
e2)
      = Bool -> MaybeT (State VarPairSet) ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (a
c1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
c2) MaybeT (State VarPairSet) ()
-> MaybeT (State VarPairSet) () -> MaybeT (State VarPairSet) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RnEnv2 -> CoreExpr -> CoreExpr -> MaybeT (State VarPairSet) ()
go (RnEnv2 -> [Var] -> [Var] -> RnEnv2
rnBndrs2 RnEnv2
env [Var]
bs1 [Var]
bs2) CoreExpr
e1 CoreExpr
e2

    go_tick :: RnEnv2 -> Tickish Id -> Tickish Id -> Bool
    go_tick :: RnEnv2 -> Tickish Var -> Tickish Var -> Bool
go_tick RnEnv2
env (Breakpoint Int
lid [Var]
lids) (Breakpoint Int
rid [Var]
rids)
          = Int
lid Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
rid  Bool -> Bool -> Bool
&&  (Var -> Var) -> [Var] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (RnEnv2 -> Var -> Var
rnOccL RnEnv2
env) [Var]
lids [Var] -> [Var] -> Bool
forall a. Eq a => a -> a -> Bool
== (Var -> Var) -> [Var] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (RnEnv2 -> Var -> Var
rnOccR RnEnv2
env) [Var]
rids
    go_tick RnEnv2
_ Tickish Var
l Tickish Var
r = Tickish Var
l Tickish Var -> Tickish Var -> Bool
forall a. Eq a => a -> a -> Bool
== Tickish Var
r



-- | Returns @True@ if the given core expression mentions no type constructor
-- anywhere that has the given name.
freeOfType :: Slice -> [Name] -> Maybe (Var, CoreExpr)
freeOfType :: [(Var, CoreExpr)] -> [Name] -> Maybe (Var, CoreExpr)
freeOfType [(Var, CoreExpr)]
slice [Name]
tcNs =
      ((Var, CoreExpr, [TyCon]) -> (Var, CoreExpr))
-> Maybe (Var, CoreExpr, [TyCon]) -> Maybe (Var, CoreExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Var
a,CoreExpr
b,[TyCon]
_) -> (Var
a,CoreExpr
b))
    (Maybe (Var, CoreExpr, [TyCon]) -> Maybe (Var, CoreExpr))
-> Maybe (Var, CoreExpr, [TyCon]) -> Maybe (Var, CoreExpr)
forall a b. (a -> b) -> a -> b
$ (TyCon -> Bool)
-> [(Var, CoreExpr)] -> Maybe (Var, CoreExpr, [TyCon])
allTyCons (\TyCon
tc -> TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
tc Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Name]
tcNs) [(Var, CoreExpr)]
slice

-- | Check if all type constructors in a slice satisfy the given predicate.
-- Returns the binder, expression and failing constructors triple on failure.
allTyCons :: (TyCon -> Bool) -> Slice -> Maybe (Var, CoreExpr, [TyCon])
allTyCons :: (TyCon -> Bool)
-> [(Var, CoreExpr)] -> Maybe (Var, CoreExpr, [TyCon])
allTyCons TyCon -> Bool
ignore [(Var, CoreExpr)]
slice =
    [(Var, CoreExpr, [TyCon])] -> Maybe (Var, CoreExpr, [TyCon])
forall a. [a] -> Maybe a
listToMaybe
        [(Var
v, CoreExpr
e, [TyCon] -> [TyCon]
forall a. Eq a => [a] -> [a]
nub [TyCon]
tcs) | (Var
v, CoreExpr
e) <- [(Var, CoreExpr)]
slice, let tcs :: [TyCon]
tcs = CoreExpr -> [TyCon]
go CoreExpr
e, Bool -> Bool
not ([TyCon] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyCon]
tcs)]
  where
    goV :: Var -> [TyCon]
goV Var
v = Type -> [TyCon]
goT (Var -> Type
varType Var
v)

    go :: CoreExpr -> [TyCon]
go (Var Var
v)           = Var -> [TyCon]
goV Var
v
    go (Lit Literal
_)           = []
    go (App CoreExpr
e CoreExpr
a)         = CoreExpr -> [TyCon]
go CoreExpr
e [TyCon] -> [TyCon] -> [TyCon]
forall a. [a] -> [a] -> [a]
++ CoreExpr -> [TyCon]
go CoreExpr
a
    go (Lam Var
b CoreExpr
e)         = Var -> [TyCon]
goV Var
b [TyCon] -> [TyCon] -> [TyCon]
forall a. [a] -> [a] -> [a]
++ CoreExpr -> [TyCon]
go CoreExpr
e
    go (Let Bind Var
bind CoreExpr
body)   = ((Var, CoreExpr) -> [TyCon]) -> [(Var, CoreExpr)] -> [TyCon]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Var, CoreExpr) -> [TyCon]
goB ([Bind Var] -> [(Var, CoreExpr)]
forall b. [Bind b] -> [(b, Expr b)]
flattenBinds [Bind Var
bind]) [TyCon] -> [TyCon] -> [TyCon]
forall a. [a] -> [a] -> [a]
++ CoreExpr -> [TyCon]
go CoreExpr
body
    go (Case CoreExpr
s Var
b Type
_ [Alt Var]
alts) = CoreExpr -> [TyCon]
go CoreExpr
s [TyCon] -> [TyCon] -> [TyCon]
forall a. [a] -> [a] -> [a]
++ Var -> [TyCon]
goV Var
b [TyCon] -> [TyCon] -> [TyCon]
forall a. [a] -> [a] -> [a]
++ (Alt Var -> [TyCon]) -> [Alt Var] -> [TyCon]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Alt Var -> [TyCon]
goA [Alt Var]
alts
    go (Cast CoreExpr
e Coercion
_)        = CoreExpr -> [TyCon]
go CoreExpr
e
    go (Tick Tickish Var
_ CoreExpr
e)        = CoreExpr -> [TyCon]
go CoreExpr
e
    go (Type Type
t)          = (Type -> [TyCon]
goT Type
t)
    go (Coercion Coercion
_)      = []

    goB :: (Var, CoreExpr) -> [TyCon]
goB (Var
b, CoreExpr
e) = Var -> [TyCon]
goV Var
b [TyCon] -> [TyCon] -> [TyCon]
forall a. [a] -> [a] -> [a]
++ CoreExpr -> [TyCon]
go CoreExpr
e

    goA :: Alt Var -> [TyCon]
goA (AltCon
_,[Var]
pats, CoreExpr
e) = (Var -> [TyCon]) -> [Var] -> [TyCon]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Var -> [TyCon]
goV [Var]
pats [TyCon] -> [TyCon] -> [TyCon]
forall a. [a] -> [a] -> [a]
++ CoreExpr -> [TyCon]
go CoreExpr
e

    goT :: Type -> [TyCon]
goT (TyVarTy Var
_)      = []
    goT (AppTy Type
t1 Type
t2)    = Type -> [TyCon]
goT Type
t1 [TyCon] -> [TyCon] -> [TyCon]
forall a. [a] -> [a] -> [a]
++ Type -> [TyCon]
goT Type
t2
    goT (TyConApp TyCon
tc [Type]
ts) = [TyCon
tc | Bool -> Bool
not (TyCon -> Bool
ignore TyCon
tc)] [TyCon] -> [TyCon] -> [TyCon]
forall a. [a] -> [a] -> [a]
++ (Type -> [TyCon]) -> [Type] -> [TyCon]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Type -> [TyCon]
goT [Type]
ts
                           -- ↑ This is the crucial bit
    goT (ForAllTy TyCoVarBinder
_ Type
t)   = Type -> [TyCon]
goT Type
t
#if MIN_VERSION_GLASGOW_HASKELL(8,2,0,0)
    goT (FunTy
#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
               _
#endif
# if MIN_VERSION_GLASGOW_HASKELL(8,9,0,0)
               AnonArgFlag
_
# endif
                 Type
t1 Type
t2)  = Type -> [TyCon]
goT Type
t1 [TyCon] -> [TyCon] -> [TyCon]
forall a. [a] -> [a] -> [a]
++ Type -> [TyCon]
goT Type
t2
#endif
    goT (LitTy TyLit
_)        = []
    goT (CastTy Type
t Coercion
_)     = Type -> [TyCon]
goT Type
t
    goT (CoercionTy Coercion
_)   = []
--
-- | Returns @True@ if the given core expression mentions no term variable
-- anywhere that has the given name.
freeOfTerm :: Slice -> [Name] -> Maybe (Var, CoreExpr)
freeOfTerm :: [(Var, CoreExpr)] -> [Name] -> Maybe (Var, CoreExpr)
freeOfTerm [(Var, CoreExpr)]
slice [Name]
needles = [(Var, CoreExpr)] -> Maybe (Var, CoreExpr)
forall a. [a] -> Maybe a
listToMaybe [ (Var
v,CoreExpr
e) | (Var
v,CoreExpr
e) <- [(Var, CoreExpr)]
slice, Bool -> Bool
not (CoreExpr -> Bool
forall b. Expr b -> Bool
go CoreExpr
e) ]
  where
    isNeedle :: Name -> Bool
isNeedle Name
n = Name
n Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
needles

    goV :: Var -> Bool
goV Var
v | Name -> Bool
isNeedle (Var -> Name
Var.varName Var
v)  = Bool
False
          | Just DataCon
dc <- Var -> Maybe DataCon
isDataConId_maybe Var
v
          , Name -> Bool
isNeedle (DataCon -> Name
dataConName DataCon
dc) = Bool
False
          | Bool
otherwise                 = Bool
True

    go :: Expr b -> Bool
go (Var Var
v)           = Var -> Bool
goV Var
v
    go (Lit Literal
_ )          = Bool
True
    go (App Expr b
e Expr b
a)         = Expr b -> Bool
go Expr b
e Bool -> Bool -> Bool
&& Expr b -> Bool
go Expr b
a
    go (Lam b
_ Expr b
e)         = Expr b -> Bool
go Expr b
e
    go (Let Bind b
bind Expr b
body)   = ((b, Expr b) -> Bool) -> [(b, Expr b)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (b, Expr b) -> Bool
goB ([Bind b] -> [(b, Expr b)]
forall b. [Bind b] -> [(b, Expr b)]
flattenBinds [Bind b
bind]) Bool -> Bool -> Bool
&& Expr b -> Bool
go Expr b
body
    go (Case Expr b
s b
_ Type
_ [Alt b]
alts) = Expr b -> Bool
go Expr b
s Bool -> Bool -> Bool
&& (Alt b -> Bool) -> [Alt b] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Alt b -> Bool
goA [Alt b]
alts
    go (Cast Expr b
e Coercion
_)        = Expr b -> Bool
go Expr b
e
    go (Tick Tickish Var
_ Expr b
e)        = Expr b -> Bool
go Expr b
e
    go (Type Type
_)          = Bool
True
    go (Coercion Coercion
_)      = Bool
True

    goB :: (b, Expr b) -> Bool
goB (b
_, Expr b
e) = Expr b -> Bool
go Expr b
e

    goA :: Alt b -> Bool
goA (AltCon
ac, [b]
_, Expr b
e) = AltCon -> Bool
goAltCon AltCon
ac Bool -> Bool -> Bool
&& Expr b -> Bool
go Expr b
e

    goAltCon :: AltCon -> Bool
goAltCon (DataAlt DataCon
dc) | Name -> Bool
isNeedle (DataCon -> Name
dataConName DataCon
dc) = Bool
False
    goAltCon AltCon
_ = Bool
True


-- | True if the given variable binding does not allocate, if called fully
-- satisfied.
--
-- It currently does not look through function calls, which of course could
-- allocate. It should probably at least look through local function calls.
--
-- The variable is important to know the arity of the function.
doesNotAllocate :: Slice -> Maybe (Var, CoreExpr)
doesNotAllocate :: [(Var, CoreExpr)] -> Maybe (Var, CoreExpr)
doesNotAllocate [(Var, CoreExpr)]
slice = [(Var, CoreExpr)] -> Maybe (Var, CoreExpr)
forall a. [a] -> Maybe a
listToMaybe [ (Var
v,CoreExpr
e) | (Var
v,CoreExpr
e) <- [(Var, CoreExpr)]
slice, Bool -> Bool
not (Int -> CoreExpr -> Bool
go (Var -> Int
idArity Var
v) CoreExpr
e) ]
  where
    go :: Int -> CoreExpr -> Bool
go Int
_ (Var Var
v)
      | Var -> Bool
isDataConWorkId Var
v, Var -> Int
idArity Var
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = Bool
False
    go Int
a (Var Var
v)                         = Int
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Var -> Int
idArity Var
v
    go Int
_ (Lit Literal
_ )                        = Bool
True
    go Int
a (App CoreExpr
e CoreExpr
arg) | CoreExpr -> Bool
forall b. Expr b -> Bool
isTypeArg CoreExpr
arg     = Int -> CoreExpr -> Bool
go Int
a CoreExpr
e
    go Int
a (App CoreExpr
e CoreExpr
arg)                     = Int -> CoreExpr -> Bool
go (Int
aInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) CoreExpr
e Bool -> Bool -> Bool
&& CoreExpr -> Bool
goArg CoreExpr
arg
    go Int
a (Lam Var
b CoreExpr
e) | Var -> Bool
isTyVar Var
b           = Int -> CoreExpr -> Bool
go Int
a CoreExpr
e
    go Int
0 (Lam Var
_ CoreExpr
_)                       = Bool
False
    go Int
a (Lam Var
_ CoreExpr
e)                       = Int -> CoreExpr -> Bool
go (Int
aInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) CoreExpr
e
    go Int
a (Let Bind Var
bind CoreExpr
body)                 = ((Var, CoreExpr) -> Bool) -> [(Var, CoreExpr)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Var, CoreExpr) -> Bool
goB ([Bind Var] -> [(Var, CoreExpr)]
forall b. [Bind b] -> [(b, Expr b)]
flattenBinds [Bind Var
bind]) Bool -> Bool -> Bool
&& Int -> CoreExpr -> Bool
go Int
a CoreExpr
body
    go Int
a (Case CoreExpr
s Var
_ Type
_ [Alt Var]
alts)               = Int -> CoreExpr -> Bool
go Int
0 CoreExpr
s Bool -> Bool -> Bool
&& (Alt Var -> Bool) -> [Alt Var] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int -> Alt Var -> Bool
goA Int
a) [Alt Var]
alts
    go Int
a (Cast CoreExpr
e Coercion
_)                      = Int -> CoreExpr -> Bool
go Int
a CoreExpr
e
    go Int
a (Tick Tickish Var
_ CoreExpr
e)                      = Int -> CoreExpr -> Bool
go Int
a CoreExpr
e
    go Int
_ (Type Type
_)                        = Bool
True
    go Int
_ (Coercion Coercion
_)                    = Bool
True

    goArg :: CoreExpr -> Bool
goArg CoreExpr
e | CoreExpr -> Bool
exprIsTrivial CoreExpr
e             = Int -> CoreExpr -> Bool
go Int
0 CoreExpr
e
            | HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType (CoreExpr -> Type
exprType CoreExpr
e) = Int -> CoreExpr -> Bool
go Int
0 CoreExpr
e
            | Bool
otherwise                   = Bool
False

    goB :: (Var, CoreExpr) -> Bool
goB (Var
b, CoreExpr
e)
#if MIN_VERSION_GLASGOW_HASKELL(8,2,0,0)
        | Var -> Bool
isJoinId Var
b                = Int -> CoreExpr -> Bool
go (Var -> Int
idArity Var
b) CoreExpr
e
#endif
        -- Not sure when a local function definition allocates…
        | Type -> Bool
isFunTy (Var -> Type
idType Var
b)        = Int -> CoreExpr -> Bool
go (Var -> Int
idArity Var
b) CoreExpr
e
        | HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType (Var -> Type
idType Var
b) = Int -> CoreExpr -> Bool
go (Var -> Int
idArity Var
b) CoreExpr
e
        | Bool
otherwise                 = Bool
False
        -- A let binding allocates if any variable is not a join point and not
        -- unlifted

    goA :: Int -> Alt Var -> Bool
goA Int
a (AltCon
_,[Var]
_, CoreExpr
e) = Int -> CoreExpr -> Bool
go Int
a CoreExpr
e

doesNotContainTypeClasses :: Slice -> [Name] -> Maybe (Var, CoreExpr, [TyCon])
doesNotContainTypeClasses :: [(Var, CoreExpr)] -> [Name] -> Maybe (Var, CoreExpr, [TyCon])
doesNotContainTypeClasses [(Var, CoreExpr)]
slice [Name]
tcNs
    = (TyCon -> Bool)
-> [(Var, CoreExpr)] -> Maybe (Var, CoreExpr, [TyCon])
allTyCons (\TyCon
tc -> Bool -> Bool
not (TyCon -> Bool
isClassTyCon TyCon
tc) Bool -> Bool -> Bool
|| (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
==) [Name]
tcNs) [(Var, CoreExpr)]
slice