{-# LANGUAGE CPP, FlexibleContexts, PatternSynonyms, MultiWayIf #-}
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.Literal
import GHC.Types.Var.Env
import GHC.Types.Unique
import GHC.Utils.Outputable as Outputable
import GHC.Core.Ppr
import GHC.Core.Subst
import GHC.Core.Coercion
import GHC.Utils.Misc
import GHC.Core.DataCon
import GHC.Core.TyCon (TyCon, isClassTyCon)
#else
import CoreSyn
import CoreUtils
import CoreSubst
import TyCoRep
import Type
import Var
import Id
import Literal
import Name
import VarEnv
import Outputable
import PprCore
import Coercion
import Util
import DataCon
import Unique
import TyCon (TyCon, isClassTyCon)
#endif
#if MIN_VERSION_ghc(9,2,0)
import GHC.Types.Tickish
#endif
import qualified Data.Set as S
import Control.Monad.State.Strict
import Data.List (nub, intercalate)
import Data.Maybe
import Test.Inspection (Equivalence (..))
tracePut :: Monad m => Int -> String -> String -> m ()
tracePut :: Int -> String -> String -> m ()
tracePut Int
_ String
_ String
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#if !MIN_VERSION_ghc(9,2,0)
pattern Alt :: a -> b -> c -> (a, b, c)
pattern $bAlt :: a -> b -> c -> (a, b, c)
$mAlt :: forall r a b c.
(a, b, c) -> (a -> b -> c -> r) -> (Void# -> r) -> r
Alt a b c = (a, b, c)
{-# COMPLETE Alt #-}
#endif
type Slice = [(Var, CoreExpr)]
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
= String -> [(Var, CoreExpr)]
forall a. HasCallStack => String -> a
error String
"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 e :: CoreExpr
e = Maybe CoreExpr -> CoreExpr
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe CoreExpr -> CoreExpr) -> Maybe CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ 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 (Alt AltCon
_ [Var]
_ CoreExpr
e) = CoreExpr -> m ()
go CoreExpr
e
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 ]
pprSliceDifference :: Slice -> Slice -> SDoc
pprSliceDifference :: [(Var, CoreExpr)] -> [(Var, CoreExpr)] -> SDoc
pprSliceDifference [(Var, CoreExpr)]
slice1 [(Var, CoreExpr)]
slice2
| [(Var
v1,CoreExpr
e1)] <- [(Var, CoreExpr)]
slice1'
, [(Var
v2,CoreExpr
e2)] <- [(Var, CoreExpr)]
slice2'
= Var -> Var -> CoreExpr -> CoreExpr -> SDoc
pprSingletonSliceDifference Var
v1 Var
v2 CoreExpr
e1 CoreExpr
e2
| Bool
otherwise =
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"LHS" SDoc -> SDoc -> SDoc
Outputable.<> SDoc
colon) Int
4 ([(Var, CoreExpr)] -> SDoc
pprSlice [(Var, CoreExpr)]
slice1') SDoc -> SDoc -> SDoc
$$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"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
pprSingletonSliceDifference :: Var -> Var -> CoreExpr -> CoreExpr -> SDoc
pprSingletonSliceDifference :: Var -> Var -> CoreExpr -> CoreExpr -> SDoc
pprSingletonSliceDifference Var
v1 Var
v2 CoreExpr
e1 CoreExpr
e2 =
SDoc -> SDoc
ctxDoc (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"LHS" SDoc -> SDoc -> SDoc
Outputable.<> SDoc
colon) Int
4 (SDoc -> Int -> SDoc -> SDoc
hang (Var -> SDoc
forall a. OutputableBndr a => a -> SDoc
pprPrefixOcc Var
v1) Int
2 (SDoc
eqSign SDoc -> SDoc -> SDoc
<+> CoreExpr -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr CoreExpr
e1')) SDoc -> SDoc -> SDoc
$$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"RHS" SDoc -> SDoc -> SDoc
Outputable.<> SDoc
colon) Int
4 (SDoc -> Int -> SDoc -> SDoc
hang (Var -> SDoc
forall a. OutputableBndr a => a -> SDoc
pprPrefixOcc Var
v2) Int
2 (SDoc
eqSign SDoc -> SDoc -> SDoc
<+> CoreExpr -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr CoreExpr
e2'))
where
hasContext :: Bool
hasContext = Bool -> Bool
not ([(Var, Var)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Var, Var)]
ctxt)
ctxDoc :: SDoc -> SDoc
ctxDoc | Bool
hasContext = SDoc -> SDoc
forall a. a -> a
id
| Bool
otherwise = (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"In") Int
4 (CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CoreExpr -> SDoc) -> CoreExpr -> SDoc
forall a b. (a -> b) -> a -> b
$ [Var] -> CoreExpr
mkContextExpr ([Var] -> [Var]
forall a. [a] -> [a]
reverse (((Var, Var) -> Var) -> [(Var, Var)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, Var) -> Var
forall a b. (a, b) -> b
snd [(Var, Var)]
ctxt))) SDoc -> SDoc -> SDoc
$$)
eqSign :: SDoc
eqSign | Bool
hasContext = String -> SDoc
text String
"= ..."
| Bool
otherwise = SDoc
equals
(CoreExpr
e1', CoreExpr
e2', [(Var, Var)]
ctxt) = CoreExpr
-> CoreExpr
-> [(Var, Var)]
-> RnEnv2
-> (CoreExpr, CoreExpr, [(Var, Var)])
go CoreExpr
e1 CoreExpr
e2 [] (InScopeSet -> RnEnv2
mkRnEnv2 InScopeSet
emptyInScopeSet)
go :: CoreExpr -> CoreExpr -> [(Var, Var)] -> RnEnv2 -> (CoreExpr, CoreExpr, [(Var, Var)])
go :: CoreExpr
-> CoreExpr
-> [(Var, Var)]
-> RnEnv2
-> (CoreExpr, CoreExpr, [(Var, Var)])
go (Lam Var
b1 CoreExpr
t1) (Lam Var
b2 CoreExpr
t2) [(Var, Var)]
ctxt RnEnv2
env
| RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env (Var -> Type
varType Var
b1) (Var -> Type
varType Var
b2)
= CoreExpr
-> CoreExpr
-> [(Var, Var)]
-> RnEnv2
-> (CoreExpr, CoreExpr, [(Var, Var)])
go CoreExpr
t1 CoreExpr
t2 ((Var
b1,Var
b2)(Var, Var) -> [(Var, Var)] -> [(Var, Var)]
forall a. a -> [a] -> [a]
:[(Var, Var)]
ctxt) (RnEnv2 -> Var -> Var -> RnEnv2
rnBndr2 RnEnv2
env Var
b1 Var
b2)
where
go CoreExpr
x CoreExpr
y [(Var, Var)]
ctxt RnEnv2
_env = ([(Var, Var)] -> CoreExpr -> CoreExpr
rename [(Var, Var)]
ctxt CoreExpr
x, CoreExpr
y, [(Var, Var)]
ctxt)
mkContextExpr :: [Var] -> CoreExpr
mkContextExpr :: [Var] -> CoreExpr
mkContextExpr [] = CoreExpr
ellipsis
mkContextExpr (Var
x:[Var]
rest) = Var -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Var
x ([Var] -> CoreExpr
mkContextExpr [Var]
rest)
ellipsis :: CoreExpr
#if MIN_VERSION_ghc(8,8,0)
ellipsis :: CoreExpr
ellipsis = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Literal -> CoreExpr) -> Literal -> CoreExpr
forall a b. (a -> b) -> a -> b
$ String -> Literal
mkLitString String
"..."
#else
ellipsis = Lit $ mkMachString "..."
#endif
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
eqSlice :: Equivalence -> Slice -> Slice -> Bool
eqSlice :: Equivalence -> [(Var, CoreExpr)] -> [(Var, CoreExpr)] -> Bool
eqSlice Equivalence
_ [(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
eqSlice Equivalence
eqv [(Var, CoreExpr)]
slice1 [(Var, CoreExpr)]
slice2
= (((), Set (Var, Var)) -> Bool) -> [((), Set (Var, Var))] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Set (Var, Var) -> Bool
forall a. Set a -> Bool
S.null (Set (Var, Var) -> Bool)
-> (((), Set (Var, Var)) -> Set (Var, Var))
-> ((), Set (Var, Var))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((), Set (Var, Var)) -> Set (Var, Var)
forall a b. (a, b) -> b
snd) [((), Set (Var, Var))]
results
where
it :: Bool
it :: Bool
it = case Equivalence
eqv of
Equivalence
StrictEquiv -> Bool
False
Equivalence
IgnoreTypesAndTicksEquiv -> Bool
True
Equivalence
UnorderedLetsEquiv -> Bool
True
ul :: Bool
ul :: Bool
ul = case Equivalence
eqv of
Equivalence
StrictEquiv -> Bool
False
Equivalence
IgnoreTypesAndTicksEquiv -> Bool
False
Equivalence
UnorderedLetsEquiv -> Bool
True
results :: [((), VarPairSet)]
results :: [((), Set (Var, Var))]
results = StateT (Set (Var, Var)) [] ()
-> Set (Var, Var) -> [((), Set (Var, Var))]
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (RnEnv2
-> Set (Var, Var) -> Var -> Var -> StateT (Set (Var, Var)) [] ()
loop' (InScopeSet -> RnEnv2
mkRnEnv2 InScopeSet
emptyInScopeSet) Set (Var, Var)
forall a. Set a
S.empty ((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))) Set (Var, Var)
forall a. Set a
S.empty
loop :: RnEnv2 -> VarPairSet -> StateT VarPairSet [] ()
loop :: RnEnv2 -> Set (Var, Var) -> StateT (Set (Var, Var)) [] ()
loop RnEnv2
env Set (Var, Var)
done = do
Set (Var, Var)
vars <- StateT (Set (Var, Var)) [] (Set (Var, Var))
forall s (m :: * -> *). MonadState s m => m s
get
case Set (Var, Var) -> Maybe ((Var, Var), Set (Var, Var))
forall a. Set a -> Maybe (a, Set a)
S.minView Set (Var, Var)
vars of
Maybe ((Var, Var), Set (Var, Var))
Nothing -> () -> StateT (Set (Var, Var)) [] ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just ((Var
x, Var
y), Set (Var, Var)
vars') -> do
Set (Var, Var) -> StateT (Set (Var, Var)) [] ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Set (Var, Var)
vars'
if (Var
x, Var
y) (Var, Var) -> Set (Var, Var) -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set (Var, Var)
done
then RnEnv2 -> Set (Var, Var) -> StateT (Set (Var, Var)) [] ()
loop RnEnv2
env Set (Var, Var)
done
else RnEnv2
-> Set (Var, Var) -> Var -> Var -> StateT (Set (Var, Var)) [] ()
loop' RnEnv2
env Set (Var, Var)
done Var
x Var
y
loop' :: RnEnv2 -> VarPairSet -> Var -> Var -> StateT VarPairSet [] ()
loop' :: RnEnv2
-> Set (Var, Var) -> Var -> Var -> StateT (Set (Var, Var)) [] ()
loop' RnEnv2
env Set (Var, Var)
done Var
x Var
y = do
Int -> String -> String -> StateT (Set (Var, Var)) [] ()
forall (m :: * -> *). Monad m => Int -> String -> String -> m ()
tracePut Int
0 String
"TOP" (Var -> String
varToString Var
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" =?= " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Var -> String
varToString Var
y)
Int -> String -> String -> StateT (Set (Var, Var)) [] ()
forall (m :: * -> *). Monad m => Int -> String -> String -> m ()
tracePut Int
0 String
"DONESET" (Set (Var, Var) -> String
showVarPairSet Set (Var, Var)
done)
if | 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
-> do (Set (Var, Var) -> Set (Var, Var)) -> StateT (Set (Var, Var)) [] ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' ((Var, Var) -> Set (Var, Var) -> Set (Var, Var)
forall a. Ord a => a -> Set a -> Set a
S.insert (Var
x', Var
y))
RnEnv2 -> Set (Var, Var) -> StateT (Set (Var, Var)) [] ()
loop RnEnv2
env Set (Var, Var)
done
| 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
-> do (Set (Var, Var) -> Set (Var, Var)) -> StateT (Set (Var, Var)) [] ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' ((Var, Var) -> Set (Var, Var) -> Set (Var, Var)
forall a. Ord a => a -> Set a -> Set a
S.insert (Var
x, Var
y'))
RnEnv2 -> Set (Var, Var) -> StateT (Set (Var, Var)) [] ()
loop RnEnv2
env Set (Var, Var)
done
| 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
-> do
let env' :: RnEnv2
env' = RnEnv2 -> Var -> Var -> RnEnv2
rnBndr2 RnEnv2
env Var
x Var
y
done' :: Set (Var, Var)
done' = (Var, Var) -> Set (Var, Var) -> Set (Var, Var)
forall a. Ord a => a -> Set a -> Set a
S.insert (Var
x, Var
y) Set (Var, Var)
done
Int
-> RnEnv2 -> CoreExpr -> CoreExpr -> StateT (Set (Var, Var)) [] ()
go Int
0 RnEnv2
env' CoreExpr
e1 CoreExpr
e2
RnEnv2 -> Set (Var, Var) -> StateT (Set (Var, Var)) [] ()
loop RnEnv2
env' Set (Var, Var)
done'
| Bool
otherwise
-> do
Int -> String -> String -> StateT (Set (Var, Var)) [] ()
forall (m :: * -> *). Monad m => Int -> String -> String -> m ()
tracePut Int
0 String
"TOP" (Var -> String
varToString Var
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" =?= " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Var -> String
varToString Var
y String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" NOT IN SLICES")
StateT (Set (Var, Var)) [] ()
forall (m :: * -> *) a. MonadPlus m => m a
mzero
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
#if MIN_VERSION_ghc(9,0,0)
essentiallyVar (Case s _ _ [Alt _ _ e]) | it, isUnsafeEqualityProof s = essentiallyVar e
#endif
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 :: Int -> RnEnv2 -> CoreExpr -> CoreExpr -> StateT VarPairSet [] ()
go :: Int
-> RnEnv2 -> CoreExpr -> CoreExpr -> StateT (Set (Var, Var)) [] ()
go Int
lv RnEnv2
env (Var Var
v1) (Var Var
v2) = do
if | Var
v1 Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
v2 -> do
Int -> String -> String -> StateT (Set (Var, Var)) [] ()
forall (m :: * -> *). Monad m => Int -> String -> String -> m ()
tracePut Int
lv String
"VAR" (Var -> String
varToString Var
v1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" =?= " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Var -> String
varToString Var
v2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" SAME")
() -> StateT (Set (Var, Var)) [] ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| 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 -> do
Int -> String -> String -> StateT (Set (Var, Var)) [] ()
forall (m :: * -> *). Monad m => Int -> String -> String -> m ()
tracePut Int
lv String
"VAR" (Var -> String
varToString Var
v1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" =?= " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Var -> String
varToString Var
v2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" IN ENV")
() -> StateT (Set (Var, Var)) [] ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise -> do
Int -> String -> String -> StateT (Set (Var, Var)) [] ()
forall (m :: * -> *). Monad m => Int -> String -> String -> m ()
tracePut Int
lv String
"VAR" (Var -> String
varToString Var
v1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" =?= " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Var -> String
varToString Var
v2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" OBLIGATION")
(Set (Var, Var) -> Set (Var, Var)) -> StateT (Set (Var, Var)) [] ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Var, Var) -> Set (Var, Var) -> Set (Var, Var)
forall a. Ord a => a -> Set a -> Set a
S.insert (Var
v1, Var
v2))
go Int
lv RnEnv2
_ (Lit Literal
lit1) (Lit Literal
lit2) = do
Int -> String -> String -> StateT (Set (Var, Var)) [] ()
forall (m :: * -> *). Monad m => Int -> String -> String -> m ()
tracePut Int
lv String
"LIT" String
"???"
Bool -> StateT (Set (Var, Var)) [] ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> StateT (Set (Var, Var)) [] ())
-> Bool -> StateT (Set (Var, Var)) [] ()
forall a b. (a -> b) -> a -> b
$ Literal
lit1 Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== Literal
lit2
go Int
_ RnEnv2
env (Type Type
t1) (Type Type
t2) = Bool -> StateT (Set (Var, Var)) [] ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> StateT (Set (Var, Var)) [] ())
-> Bool -> StateT (Set (Var, Var)) [] ()
forall a b. (a -> b) -> a -> b
$ RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env Type
t1 Type
t2
go Int
_ RnEnv2
env (Coercion Coercion
co1) (Coercion Coercion
co2) = Bool -> StateT (Set (Var, Var)) [] ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> StateT (Set (Var, Var)) [] ())
-> Bool -> StateT (Set (Var, Var)) [] ()
forall a b. (a -> b) -> a -> b
$ RnEnv2 -> Coercion -> Coercion -> Bool
eqCoercionX RnEnv2
env Coercion
co1 Coercion
co2
go Int
lv RnEnv2
env (Cast CoreExpr
e1 Coercion
_) CoreExpr
e2 | Bool
it = Int
-> RnEnv2 -> CoreExpr -> CoreExpr -> StateT (Set (Var, Var)) [] ()
go Int
lv RnEnv2
env CoreExpr
e1 CoreExpr
e2
go Int
lv RnEnv2
env CoreExpr
e1 (Cast CoreExpr
e2 Coercion
_) | Bool
it = Int
-> RnEnv2 -> CoreExpr -> CoreExpr -> StateT (Set (Var, Var)) [] ()
go Int
lv RnEnv2
env CoreExpr
e1 CoreExpr
e2
#if MIN_VERSION_ghc(9,0,0)
go lv env (Case s _ _ [Alt _ _ e1]) e2 | it, isUnsafeEqualityProof s = go lv env e1 e2
go lv env e1 (Case s _ _ [Alt _ _ e2]) | it, isUnsafeEqualityProof s = go lv env e1 e2
#endif
go Int
lv RnEnv2
env (Cast CoreExpr
e1 Coercion
co1) (Cast CoreExpr
e2 Coercion
co2) = Int
-> String
-> String
-> (Int -> StateT (Set (Var, Var)) [] ())
-> StateT (Set (Var, Var)) [] ()
forall (m :: * -> *).
Monad m =>
Int -> String -> String -> (Int -> m ()) -> m ()
traceBlock Int
lv String
"CAST" String
"" ((Int -> StateT (Set (Var, Var)) [] ())
-> StateT (Set (Var, Var)) [] ())
-> (Int -> StateT (Set (Var, Var)) [] ())
-> StateT (Set (Var, Var)) [] ()
forall a b. (a -> b) -> a -> b
$ \Int
lv -> do
Bool -> StateT (Set (Var, Var)) [] ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (RnEnv2 -> Coercion -> Coercion -> Bool
eqCoercionX RnEnv2
env Coercion
co1 Coercion
co2)
Int
-> RnEnv2 -> CoreExpr -> CoreExpr -> StateT (Set (Var, Var)) [] ()
go Int
lv RnEnv2
env CoreExpr
e1 CoreExpr
e2
go Int
lv RnEnv2
env (App CoreExpr
e1 CoreExpr
a) CoreExpr
e2 | Bool
it, CoreExpr -> Bool
forall b. Expr b -> Bool
isTyCoArg CoreExpr
a = Int
-> RnEnv2 -> CoreExpr -> CoreExpr -> StateT (Set (Var, Var)) [] ()
go Int
lv RnEnv2
env CoreExpr
e1 CoreExpr
e2
go Int
lv RnEnv2
env CoreExpr
e1 (App CoreExpr
e2 CoreExpr
a) | Bool
it, CoreExpr -> Bool
forall b. Expr b -> Bool
isTyCoArg CoreExpr
a = Int
-> RnEnv2 -> CoreExpr -> CoreExpr -> StateT (Set (Var, Var)) [] ()
go Int
lv RnEnv2
env CoreExpr
e1 CoreExpr
e2
go Int
lv RnEnv2
env (App CoreExpr
f1 CoreExpr
a1) (App CoreExpr
f2 CoreExpr
a2) = Int
-> String
-> String
-> (Int -> StateT (Set (Var, Var)) [] ())
-> StateT (Set (Var, Var)) [] ()
forall (m :: * -> *).
Monad m =>
Int -> String -> String -> (Int -> m ()) -> m ()
traceBlock Int
lv String
"APP" String
"" ((Int -> StateT (Set (Var, Var)) [] ())
-> StateT (Set (Var, Var)) [] ())
-> (Int -> StateT (Set (Var, Var)) [] ())
-> StateT (Set (Var, Var)) [] ()
forall a b. (a -> b) -> a -> b
$ \Int
lv -> do
Int
-> RnEnv2 -> CoreExpr -> CoreExpr -> StateT (Set (Var, Var)) [] ()
go Int
lv RnEnv2
env CoreExpr
f1 CoreExpr
f2
Int
-> RnEnv2 -> CoreExpr -> CoreExpr -> StateT (Set (Var, Var)) [] ()
go Int
lv RnEnv2
env CoreExpr
a1 CoreExpr
a2
go Int
lv RnEnv2
env (Tick HpcTick{} CoreExpr
e1) CoreExpr
e2 | Bool
it = Int
-> RnEnv2 -> CoreExpr -> CoreExpr -> StateT (Set (Var, Var)) [] ()
go Int
lv RnEnv2
env CoreExpr
e1 CoreExpr
e2
go Int
lv RnEnv2
env CoreExpr
e1 (Tick HpcTick{} CoreExpr
e2) | Bool
it = Int
-> RnEnv2 -> CoreExpr -> CoreExpr -> StateT (Set (Var, Var)) [] ()
go Int
lv RnEnv2
env CoreExpr
e1 CoreExpr
e2
go Int
lv RnEnv2
env (Tick Tickish Var
n1 CoreExpr
e1) (Tick Tickish Var
n2 CoreExpr
e2) = Int
-> String
-> String
-> (Int -> StateT (Set (Var, Var)) [] ())
-> StateT (Set (Var, Var)) [] ()
forall (m :: * -> *).
Monad m =>
Int -> String -> String -> (Int -> m ()) -> m ()
traceBlock Int
lv String
"TICK" String
"" ((Int -> StateT (Set (Var, Var)) [] ())
-> StateT (Set (Var, Var)) [] ())
-> (Int -> StateT (Set (Var, Var)) [] ())
-> StateT (Set (Var, Var)) [] ()
forall a b. (a -> b) -> a -> b
$ \Int
lv -> do
Bool -> StateT (Set (Var, Var)) [] ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (RnEnv2 -> Tickish Var -> Tickish Var -> Bool
go_tick RnEnv2
env Tickish Var
n1 Tickish Var
n2)
Int
-> RnEnv2 -> CoreExpr -> CoreExpr -> StateT (Set (Var, Var)) [] ()
go Int
lv RnEnv2
env CoreExpr
e1 CoreExpr
e2
go Int
lv RnEnv2
env (Lam Var
b CoreExpr
e1) CoreExpr
e2 | Bool
it, Var -> Bool
isTyCoVar Var
b = Int
-> RnEnv2 -> CoreExpr -> CoreExpr -> StateT (Set (Var, Var)) [] ()
go Int
lv RnEnv2
env CoreExpr
e1 CoreExpr
e2
go Int
lv RnEnv2
env CoreExpr
e1 (Lam Var
b CoreExpr
e2) | Bool
it, Var -> Bool
isTyCoVar Var
b = Int
-> RnEnv2 -> CoreExpr -> CoreExpr -> StateT (Set (Var, Var)) [] ()
go Int
lv RnEnv2
env CoreExpr
e1 CoreExpr
e2
go Int
lv RnEnv2
env (Lam Var
b1 CoreExpr
e1) (Lam Var
b2 CoreExpr
e2) = Int
-> String
-> String
-> (Int -> StateT (Set (Var, Var)) [] ())
-> StateT (Set (Var, Var)) [] ()
forall (m :: * -> *).
Monad m =>
Int -> String -> String -> (Int -> m ()) -> m ()
traceBlock Int
lv String
"LAM" (Var -> String
varToString Var
b1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ~ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Var -> String
varToString Var
b2) ((Int -> StateT (Set (Var, Var)) [] ())
-> StateT (Set (Var, Var)) [] ())
-> (Int -> StateT (Set (Var, Var)) [] ())
-> StateT (Set (Var, Var)) [] ()
forall a b. (a -> b) -> a -> b
$ \Int
lv -> do
Bool -> StateT (Set (Var, Var)) [] ()
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))
Int
-> RnEnv2 -> CoreExpr -> CoreExpr -> StateT (Set (Var, Var)) [] ()
go Int
lv (RnEnv2 -> Var -> Var -> RnEnv2
rnBndr2 RnEnv2
env Var
b1 Var
b2) CoreExpr
e1 CoreExpr
e2
go Int
lv RnEnv2
env e1 :: CoreExpr
e1@(Let Bind Var
_ CoreExpr
_) e2 :: CoreExpr
e2@(Let Bind Var
_ CoreExpr
_)
| Bool
ul
, ([(Var, CoreExpr)]
ps1, CoreExpr
e1') <- CoreExpr -> ([(Var, CoreExpr)], CoreExpr)
forall a. Expr a -> ([(a, Expr a)], Expr a)
peelLets CoreExpr
e1
, ([(Var, CoreExpr)]
ps2, CoreExpr
e2') <- CoreExpr -> ([(Var, CoreExpr)], CoreExpr)
forall a. Expr a -> ([(a, Expr a)], Expr a)
peelLets CoreExpr
e2
= Int
-> String
-> String
-> (Int -> StateT (Set (Var, Var)) [] ())
-> StateT (Set (Var, Var)) [] ()
forall (m :: * -> *).
Monad m =>
Int -> String -> String -> (Int -> m ()) -> m ()
traceBlock Int
lv String
"LET" ([(Var, CoreExpr)] -> String
forall a. [(Var, a)] -> String
showVars [(Var, CoreExpr)]
ps1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ~ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(Var, CoreExpr)] -> String
forall a. [(Var, a)] -> String
showVars [(Var, CoreExpr)]
ps2) ((Int -> StateT (Set (Var, Var)) [] ())
-> StateT (Set (Var, Var)) [] ())
-> (Int -> StateT (Set (Var, Var)) [] ())
-> StateT (Set (Var, Var)) [] ()
forall a b. (a -> b) -> a -> b
$ \Int
lv -> do
Bool -> StateT (Set (Var, Var)) [] ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> StateT (Set (Var, Var)) [] ())
-> Bool -> StateT (Set (Var, Var)) [] ()
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
RnEnv2
env' <- Int
-> RnEnv2
-> [(Var, CoreExpr)]
-> [(Var, CoreExpr)]
-> StateT (Set (Var, Var)) [] RnEnv2
goBinds Int
lv RnEnv2
env [(Var, CoreExpr)]
ps1 [(Var, CoreExpr)]
ps2
Int
-> RnEnv2 -> CoreExpr -> CoreExpr -> StateT (Set (Var, Var)) [] ()
go Int
lv RnEnv2
env' CoreExpr
e1' CoreExpr
e2'
go Int
lv RnEnv2
env (Let (NonRec Var
v1 CoreExpr
r1) CoreExpr
e1) (Let (NonRec Var
v2 CoreExpr
r2) CoreExpr
e2)
= do Int
-> RnEnv2 -> CoreExpr -> CoreExpr -> StateT (Set (Var, Var)) [] ()
go Int
lv RnEnv2
env CoreExpr
r1 CoreExpr
r2
Int
-> RnEnv2 -> CoreExpr -> CoreExpr -> StateT (Set (Var, Var)) [] ()
go Int
lv (RnEnv2 -> Var -> Var -> RnEnv2
rnBndr2 RnEnv2
env Var
v1 Var
v2) CoreExpr
e1 CoreExpr
e2
go Int
lv RnEnv2
env (Let (Rec [(Var, CoreExpr)]
ps1) CoreExpr
e1) (Let (Rec [(Var, CoreExpr)]
ps2) CoreExpr
e2)
= do Bool -> StateT (Set (Var, Var)) [] ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> StateT (Set (Var, Var)) [] ())
-> Bool -> StateT (Set (Var, Var)) [] ()
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
[StateT (Set (Var, Var)) [] ()] -> StateT (Set (Var, Var)) [] ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([StateT (Set (Var, Var)) [] ()] -> StateT (Set (Var, Var)) [] ())
-> [StateT (Set (Var, Var)) [] ()] -> StateT (Set (Var, Var)) [] ()
forall a b. (a -> b) -> a -> b
$ (CoreExpr -> CoreExpr -> StateT (Set (Var, Var)) [] ())
-> [CoreExpr] -> [CoreExpr] -> [StateT (Set (Var, Var)) [] ()]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Int
-> RnEnv2 -> CoreExpr -> CoreExpr -> StateT (Set (Var, Var)) [] ()
go Int
lv RnEnv2
env') [CoreExpr]
rs1 [CoreExpr]
rs2
Int
-> RnEnv2 -> CoreExpr -> CoreExpr -> StateT (Set (Var, Var)) [] ()
go Int
lv 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 Int
lv 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
= do Bool -> StateT (Set (Var, Var)) [] ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ([Alt Var] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Alt Var]
a2)
Int
-> RnEnv2 -> CoreExpr -> CoreExpr -> StateT (Set (Var, Var)) [] ()
go Int
lv RnEnv2
env CoreExpr
e1 CoreExpr
e2
Bool -> StateT (Set (Var, Var)) [] ()
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 -> StateT (Set (Var, Var)) [] ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> StateT (Set (Var, Var)) [] ())
-> Bool -> StateT (Set (Var, Var)) [] ()
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
Int
-> RnEnv2 -> CoreExpr -> CoreExpr -> StateT (Set (Var, Var)) [] ()
go Int
lv RnEnv2
env CoreExpr
e1 CoreExpr
e2
[StateT (Set (Var, Var)) [] ()] -> StateT (Set (Var, Var)) [] ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([StateT (Set (Var, Var)) [] ()] -> StateT (Set (Var, Var)) [] ())
-> [StateT (Set (Var, Var)) [] ()] -> StateT (Set (Var, Var)) [] ()
forall a b. (a -> b) -> a -> b
$ (Alt Var -> Alt Var -> StateT (Set (Var, Var)) [] ())
-> [Alt Var] -> [Alt Var] -> [StateT (Set (Var, Var)) [] ()]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Int
-> RnEnv2 -> Alt Var -> Alt Var -> StateT (Set (Var, Var)) [] ()
forall a.
Eq a =>
Int
-> RnEnv2
-> (a, [Var], CoreExpr)
-> (a, [Var], CoreExpr)
-> StateT (Set (Var, Var)) [] ()
go_alt Int
lv (RnEnv2 -> Var -> Var -> RnEnv2
rnBndr2 RnEnv2
env Var
b1 Var
b2)) [Alt Var]
a1 [Alt Var]
a2
go Int
lv RnEnv2
_ CoreExpr
e1 CoreExpr
e2 = do
Int -> String -> String -> StateT (Set (Var, Var)) [] ()
forall (m :: * -> *). Monad m => Int -> String -> String -> m ()
tracePut Int
lv String
"FAIL" (CoreExpr -> String
conToString CoreExpr
e1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" =/= " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CoreExpr -> String
conToString CoreExpr
e2)
StateT (Set (Var, Var)) [] ()
forall (m :: * -> *) a. MonadPlus m => m a
mzero
go_alt :: Int
-> RnEnv2
-> (a, [Var], CoreExpr)
-> (a, [Var], CoreExpr)
-> StateT (Set (Var, Var)) [] ()
go_alt Int
lv RnEnv2
env (Alt a
c1 [Var]
bs1 CoreExpr
e1) (Alt a
c2 [Var]
bs2 CoreExpr
e2)
= Bool -> StateT (Set (Var, Var)) [] ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (a
c1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
c2) StateT (Set (Var, Var)) [] ()
-> StateT (Set (Var, Var)) [] () -> StateT (Set (Var, Var)) [] ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int
-> RnEnv2 -> CoreExpr -> CoreExpr -> StateT (Set (Var, Var)) [] ()
go Int
lv (RnEnv2 -> [Var] -> [Var] -> RnEnv2
rnBndrs2 RnEnv2
env [Var]
bs1 [Var]
bs2) CoreExpr
e1 CoreExpr
e2
#if MIN_VERSION_ghc(9,2,0)
go_tick :: RnEnv2 -> CoreTickish -> CoreTickish -> Bool
go_tick env (Breakpoint _ lid lids) (Breakpoint _ rid rids)
#else
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)
#endif
= 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
peelLets :: Expr a -> ([(a, Expr a)], Expr a)
peelLets (Let (NonRec a
v Expr a
r) Expr a
e) = let ([(a, Expr a)]
xs, Expr a
e') = Expr a -> ([(a, Expr a)], Expr a)
peelLets Expr a
e in ((a
v,Expr a
r)(a, Expr a) -> [(a, Expr a)] -> [(a, Expr a)]
forall a. a -> [a] -> [a]
:[(a, Expr a)]
xs, Expr a
e')
peelLets (Let (Rec [(a, Expr a)]
bs) Expr a
e) = let ([(a, Expr a)]
xs, Expr a
e') = Expr a -> ([(a, Expr a)], Expr a)
peelLets Expr a
e in ([(a, Expr a)]
bs [(a, Expr a)] -> [(a, Expr a)] -> [(a, Expr a)]
forall a. [a] -> [a] -> [a]
++ [(a, Expr a)]
xs, Expr a
e')
peelLets Expr a
e = ([], Expr a
e)
goBinds :: Int -> RnEnv2 -> [(Var, CoreExpr)] -> [(Var, CoreExpr)] -> StateT VarPairSet [] RnEnv2
goBinds :: Int
-> RnEnv2
-> [(Var, CoreExpr)]
-> [(Var, CoreExpr)]
-> StateT (Set (Var, Var)) [] RnEnv2
goBinds Int
_ RnEnv2
env [] [] = RnEnv2 -> StateT (Set (Var, Var)) [] RnEnv2
forall (m :: * -> *) a. Monad m => a -> m a
return RnEnv2
env
goBinds Int
_ RnEnv2
_ [] ((Var, CoreExpr)
_:[(Var, CoreExpr)]
_) = StateT (Set (Var, Var)) [] RnEnv2
forall (m :: * -> *) a. MonadPlus m => m a
mzero
goBinds Int
lv RnEnv2
env ((Var
v1,CoreExpr
b1):[(Var, CoreExpr)]
xs) [(Var, CoreExpr)]
ys' = do
((Var
v2,CoreExpr
b2), [(Var, CoreExpr)]
ys) <- [((Var, CoreExpr), [(Var, CoreExpr)])]
-> StateT (Set (Var, Var)) [] ((Var, CoreExpr), [(Var, CoreExpr)])
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ([(Var, CoreExpr)] -> [((Var, CoreExpr), [(Var, CoreExpr)])]
forall a. [a] -> [(a, [a])]
choices [(Var, CoreExpr)]
ys')
Int
-> String
-> String
-> (Int -> StateT (Set (Var, Var)) [] ())
-> StateT (Set (Var, Var)) [] ()
forall (m :: * -> *).
Monad m =>
Int -> String -> String -> (Int -> m ()) -> m ()
traceBlock Int
lv String
"LET*" (Var -> String
varToString Var
v1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" =?= " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Var -> String
varToString Var
v2) ((Int -> StateT (Set (Var, Var)) [] ())
-> StateT (Set (Var, Var)) [] ())
-> (Int -> StateT (Set (Var, Var)) [] ())
-> StateT (Set (Var, Var)) [] ()
forall a b. (a -> b) -> a -> b
$ \Int
lv ->
Int
-> RnEnv2 -> CoreExpr -> CoreExpr -> StateT (Set (Var, Var)) [] ()
go Int
lv RnEnv2
env CoreExpr
b1 CoreExpr
b2
(Set (Var, Var) -> Set (Var, Var)) -> StateT (Set (Var, Var)) [] ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Var, Var) -> Set (Var, Var) -> Set (Var, Var)
forall a. Ord a => a -> Set a -> Set a
S.delete (Var
v1, Var
v2))
Int
-> RnEnv2
-> [(Var, CoreExpr)]
-> [(Var, CoreExpr)]
-> StateT (Set (Var, Var)) [] RnEnv2
goBinds Int
lv (RnEnv2 -> Var -> Var -> RnEnv2
rnBndr2 RnEnv2
env Var
v1 Var
v2) [(Var, CoreExpr)]
xs [(Var, CoreExpr)]
ys
traceBlock :: Monad m => Int -> String -> String -> (Int -> m ()) -> m ()
traceBlock :: Int -> String -> String -> (Int -> m ()) -> m ()
traceBlock Int
lv String
name String
msg Int -> m ()
action = do
Int -> String -> String -> m ()
forall (m :: * -> *). Monad m => Int -> String -> String -> m ()
tracePut Int
lv String
name String
msg
Int -> m ()
action (Int
lv Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
Int -> String -> String -> m ()
forall (m :: * -> *). Monad m => Int -> String -> String -> m ()
tracePut Int
lv String
name (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" OK"
showVars :: [(Var, a)] -> String
showVars :: [(Var, a)] -> String
showVars [(Var, a)]
xs = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [ Var -> String
varToString Var
x | (Var
x, a
_) <- [(Var, a)]
xs ]
showVarPairSet :: VarPairSet -> String
showVarPairSet :: Set (Var, Var) -> String
showVarPairSet Set (Var, Var)
xs = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [ Var -> String
varToString Var
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ~ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Var -> String
varToString Var
y | (Var
x, Var
y) <- Set (Var, Var) -> [(Var, Var)]
forall a. Set a -> [a]
S.toList Set (Var, Var)
xs ]
varToString :: Var -> String
varToString :: Var -> String
varToString Var
v = OccName -> String
occNameString (Name -> OccName
forall name. HasOccName name => name -> OccName
occName (Var -> Name
tyVarName Var
v)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Unique -> String
forall a. Show a => a -> String
show (Var -> Unique
forall a. Uniquable a => a -> Unique
getUnique Var
v)
conToString :: CoreExpr -> [Char]
conToString :: CoreExpr -> String
conToString Var {} = String
"Var"
conToString Lit {} = String
"Lit"
conToString App {} = String
"App"
conToString Lam {} = String
"Lam"
conToString Let {} = String
"Let"
conToString Case {} = String
"Case"
conToString Cast {} = String
"Cast"
conToString Tick {} = String
"Tick"
conToString Type {} = String
"Type"
conToString Coercion {} = String
"Coercion"
choices :: [a] -> [(a, [a])]
choices :: [a] -> [(a, [a])]
choices = ([a] -> [a]) -> [a] -> [(a, [a])]
forall a. ([a] -> [a]) -> [a] -> [(a, [a])]
go [a] -> [a]
forall a. a -> a
id where
go :: ([a] -> [a]) -> [a] -> [(a, [a])]
go :: ([a] -> [a]) -> [a] -> [(a, [a])]
go [a] -> [a]
_ [] = []
go [a] -> [a]
f (a
x:[a]
xs) = (a
x, [a] -> [a]
f [a]
xs) (a, [a]) -> [(a, [a])] -> [(a, [a])]
forall a. a -> [a] -> [a]
: ([a] -> [a]) -> [a] -> [(a, [a])]
forall a. ([a] -> [a]) -> [a] -> [(a, [a])]
go ([a] -> [a]
f ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
:)) [a]
xs
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
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 (Alt 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
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
_) = []
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 (Alt 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
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
| 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
goA :: Int -> Alt Var -> Bool
goA Int
a (Alt 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
rename :: [(Var, Var)] -> CoreExpr -> CoreExpr
rename :: [(Var, Var)] -> CoreExpr -> CoreExpr
rename [(Var, Var)]
rn = Subst -> CoreExpr -> CoreExpr
substExpr' Subst
sub where
sub :: Subst
sub = InScopeSet -> [(Var, CoreExpr)] -> Subst
mkOpenSubst InScopeSet
emptyInScopeSet [ (Var
v1, if Var -> Bool
isTyVar Var
v2 then Type -> CoreExpr
forall b. Type -> Expr b
Type (Var -> Type
mkTyVarTy Var
v2) else if Var -> Bool
isCoVar Var
v2 then Coercion -> CoreExpr
forall b. Coercion -> Expr b
Coercion (Var -> Coercion
mkCoVarCo Var
v2) else Var -> CoreExpr
forall b. Var -> Expr b
Var Var
v2 ) | (Var
v1, Var
v2) <- [(Var, Var)]
rn]
#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
substExpr' = substExpr
#else
substExpr' :: Subst -> CoreExpr -> CoreExpr
substExpr' = SDoc -> Subst -> CoreExpr -> CoreExpr
substExpr SDoc
empty
#endif