-- | This module implements some analyses of Core expressions necessary for
-- "Test.Inspection". Normally, users of this package can ignore this module.
{-# 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.Builtin.Types (isCTupleTyConName)
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 TysWiredIn (isCTupleTyConName)
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

#if MIN_VERSION_ghc(9,6,0)
import GHC.Core.TyCo.Compare (eqTypeX)
#endif

import qualified Data.Set as S
import Control.Monad (guard, unless, mzero)
import Control.Monad.Trans.Class (lift)
import Control.Monad.State.Strict (StateT, runStateT, execState, modify, modify', put, get, gets)
import Data.List (nub, intercalate)
import Data.Maybe

import Test.Inspection (Equivalence (..))

-- Uncomment to enable debug traces
-- import Debug.Trace

tracePut :: Monad m => Int -> String -> String -> m ()
-- tracePut lv name msg = traceM $ replicate lv ' ' ++ name ++ ": " ++ msg
tracePut :: forall (m :: * -> *). Monad m => Int -> String -> String -> m ()
tracePut Int
_  String
_    String
_ = 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 Alt a b c = (a, b, c)
{-# COMPLETE Alt #-}
#endif


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 <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Var
v [(Var, CoreExpr)]
binds
    = (Var
v,CoreExpr
e) forall a. a -> [a] -> [a]
: [(Var
v',CoreExpr
e) | (Var
v',CoreExpr
e) <- [(Var, CoreExpr)]
binds, Var
v' forall a. Eq a => a -> a -> Bool
/= Var
v, Var
v' forall a. Ord a => a -> Set a -> Bool
`S.member` Set Var
used ]
    | Bool
otherwise
    = forall a. HasCallStack => String -> a
error String
"slice: cannot find given variable in bindings"
  where
    used :: Set Var
used = forall s a. State s a -> s -> s
execState (forall {m :: * -> *}. MonadState (Set Var) m => Var -> m ()
goV Var
v) forall a. Set a
S.empty

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

    go :: CoreExpr -> m ()
go (Var Var
v)                     = Var -> m ()
goV Var
v
    go (Lit Literal
_ )                    = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    go (App CoreExpr
e CoreExpr
arg) | forall b. Expr b -> Bool
isTyCoArg CoreExpr
arg = CoreExpr -> m ()
go CoreExpr
e
    go (App CoreExpr
e CoreExpr
arg)                 = CoreExpr -> m ()
go CoreExpr
e 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)             = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CoreExpr -> m ()
go (forall b. Bind b -> [Expr b]
rhssOfBind Bind Var
bind) 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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 CoercionR
_)                  = CoreExpr -> m ()
go CoreExpr
e
    go (Tick CoreTickish
_ CoreExpr
e)                  = CoreExpr -> m ()
go CoreExpr
e
    go (Type Type
_)                    = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    go (Coercion CoercionR
_)                = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    goA :: Alt Var -> m ()
goA (Alt 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 forall a b. (a -> b) -> a -> b
$ forall b. OutputableBndr b => [Bind b] -> SDoc
pprCoreBindings [ 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
    | [(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 = forall a. Ord a => Set a -> Set a -> Set a
S.intersection (forall a. Ord a => [a] -> Set a
S.fromList (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Var, CoreExpr)]
slice1)) (forall a. Ord a => [a] -> Set a
S.fromList (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Var, CoreExpr)]
slice2))
    slice1' :: [(Var, CoreExpr)]
slice1' = forall a. (a -> Bool) -> [a] -> [a]
filter (\(Var
v,CoreExpr
_) -> Var
v forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set Var
both) [(Var, CoreExpr)]
slice1
    slice2' :: [(Var, CoreExpr)]
slice2' = forall a. (a -> Bool) -> [a] -> [a]
filter (\(Var
v,CoreExpr
_) -> Var
v 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 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 (forall a. OutputableBndr a => a -> SDoc
pprPrefixOcc Var
v1) Int
2 (SDoc
eqSign SDoc -> SDoc -> 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 (forall a. OutputableBndr a => a -> SDoc
pprPrefixOcc Var
v2) Int
2 (SDoc
eqSign SDoc -> SDoc -> SDoc
<+> forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr CoreExpr
e2'))
  where
    hasContext :: Bool
hasContext = Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Var, Var)]
ctxt)

    ctxDoc :: SDoc -> SDoc
ctxDoc | Bool
hasContext = forall a. a -> a
id
           | Bool
otherwise = (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"In") Int
4 (forall a. Outputable a => a -> SDoc
ppr forall a b. (a -> b) -> a -> b
$ [Var] -> CoreExpr
mkContextExpr (forall a. [a] -> [a]
reverse (forall a b. (a -> b) -> [a] -> [b]
map 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)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) = 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 = forall b. Literal -> Expr b
Lit 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 = sdocWithDynFlags $ \dflags ->
     withPprStyle (defaultUserStyle dflags) sdoc
#else
withLessDetail :: SDoc -> SDoc
withLessDetail SDoc
sdoc = PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultUserStyle SDoc
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 :: Equivalence -> Slice -> Slice -> Bool
eqSlice :: Equivalence -> [(Var, CoreExpr)] -> [(Var, CoreExpr)] -> Bool
eqSlice Equivalence
_ [] [] = Bool
True
eqSlice Equivalence
_ [(Var, CoreExpr)]
_ [] = Bool
False
eqSlice Equivalence
_ [] [(Var, CoreExpr)]
_ = Bool
False
  -- Mostly defensive programming (slices should not be empty)
eqSlice Equivalence
eqv slice1 :: [(Var, CoreExpr)]
slice1@((Var
head1, CoreExpr
_) : [(Var, CoreExpr)]
_) slice2 :: [(Var, CoreExpr)]
slice2@((Var
head2, CoreExpr
_) : [(Var, CoreExpr)]
_)
    -- slices are equal if there exist any result with no "unification" obligations left.
    = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Set a -> Bool
S.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [((), VarPairSet)]
results
  where
    -- ignore types and hpc ticks
    it :: Bool
    it :: Bool
it = case Equivalence
eqv of
        Equivalence
StrictEquiv              -> Bool
False
        Equivalence
IgnoreTypesAndTicksEquiv -> Bool
True
        Equivalence
UnorderedLetsEquiv       -> Bool
True

    -- unordered lets
    ul :: Bool
    ul :: Bool
ul = case Equivalence
eqv of
        Equivalence
StrictEquiv              -> Bool
False
        Equivalence
IgnoreTypesAndTicksEquiv -> Bool
False
        Equivalence
UnorderedLetsEquiv       -> Bool
True

    -- results. If there are no pairs to be equated, all is fine.
    results :: [((), VarPairSet)]
    results :: [((), VarPairSet)]
results = forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (RnEnv2 -> VarPairSet -> Var -> Var -> StateT VarPairSet [] ()
loop' (InScopeSet -> RnEnv2
mkRnEnv2 InScopeSet
emptyInScopeSet) forall a. Set a
S.empty Var
head1 Var
head2) forall a. Set a
S.empty

    -- while there are obligations left, try to equate them.
    loop :: RnEnv2 -> VarPairSet -> StateT VarPairSet [] ()
    loop :: RnEnv2 -> VarPairSet -> StateT VarPairSet [] ()
loop RnEnv2
env VarPairSet
done = do
        VarPairSet
vars <- forall s (m :: * -> *). MonadState s m => m s
get
        case forall a. Set a -> Maybe (a, Set a)
S.minView VarPairSet
vars of
            Maybe ((Var, Var), VarPairSet)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return () -- nothing to do, done.
            Just ((Var
x, Var
y), VarPairSet
vars') -> do
                forall s (m :: * -> *). MonadState s m => s -> m ()
put VarPairSet
vars'
                if (Var
x, Var
y) forall a. Ord a => a -> Set a -> Bool
`S.member` VarPairSet
done
                then RnEnv2 -> VarPairSet -> StateT VarPairSet [] ()
loop RnEnv2
env VarPairSet
done
                else RnEnv2 -> VarPairSet -> Var -> Var -> StateT VarPairSet [] ()
loop' RnEnv2
env VarPairSet
done Var
x Var
y

    loop' :: RnEnv2 -> VarPairSet -> Var -> Var -> StateT VarPairSet [] ()
    loop' :: RnEnv2 -> VarPairSet -> Var -> Var -> StateT VarPairSet [] ()
loop' RnEnv2
env VarPairSet
done Var
x Var
y = do
        forall (m :: * -> *). Monad m => Int -> String -> String -> m ()
tracePut Int
0 String
"TOP" (Var -> String
varToString Var
x forall a. [a] -> [a] -> [a]
++ String
" =?= " forall a. [a] -> [a] -> [a]
++ Var -> String
varToString Var
y)
        forall (m :: * -> *). Monad m => Int -> String -> String -> m ()
tracePut Int
0 String
"DONESET" (VarPairSet -> String
showVarPairSet VarPairSet
done)

        -- if x or y expressions are essentially a variable x' or y' respectively
        -- add an obligation to check x' = y (or x = y').
        if | Just CoreExpr
e1 <- 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' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Var, CoreExpr)]
slice1
           -> do forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (forall a. Ord a => a -> Set a -> Set a
S.insert (Var
x', Var
y))
                 RnEnv2 -> VarPairSet -> StateT VarPairSet [] ()
loop RnEnv2
env VarPairSet
done

           | Just CoreExpr
e2 <- 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' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Var, CoreExpr)]
slice2
           -> do forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (forall a. Ord a => a -> Set a -> Set a
S.insert (Var
x, Var
y'))
                 RnEnv2 -> VarPairSet -> StateT VarPairSet [] ()
loop RnEnv2
env VarPairSet
done

            -- otherwise if neither x and y expressions are variables
            -- 1. compare the expressions (already assuming that x and y are equal)
            -- 2. comparison may create new obligations, loop.
           | Just CoreExpr
e1 <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Var
x [(Var, CoreExpr)]
slice1
           , Just CoreExpr
e2 <- 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' :: VarPairSet
done' = forall a. Ord a => a -> Set a -> Set a
S.insert (Var
x, Var
y) VarPairSet
done

               Int -> RnEnv2 -> CoreExpr -> CoreExpr -> StateT VarPairSet [] ()
go Int
0 RnEnv2
env' CoreExpr
e1 CoreExpr
e2
               RnEnv2 -> VarPairSet -> StateT VarPairSet [] ()
loop RnEnv2
env' VarPairSet
done'

            -- and finally, if x or y are not in the slice, we abort.
           | Bool
otherwise
           -> do
              forall (m :: * -> *). Monad m => Int -> String -> String -> m ()
tracePut Int
0 String
"TOP" (Var -> String
varToString Var
x forall a. [a] -> [a] -> [a]
++ String
" =?= " forall a. [a] -> [a] -> [a]
++ Var -> String
varToString Var
y forall a. [a] -> [a] -> [a]
++ String
" NOT IN SLICES")
              forall (m :: * -> *) a. MonadPlus m => m a
mzero

    essentiallyVar :: CoreExpr -> Maybe Var
    essentiallyVar :: CoreExpr -> Maybe Var
essentiallyVar (App CoreExpr
e CoreExpr
a)  | Bool
it, 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 CoercionR
_) | Bool
it              = CoreExpr -> Maybe Var
essentiallyVar CoreExpr
e
#if MIN_VERSION_ghc(9,0,0)
    essentiallyVar (Case CoreExpr
s Var
b Type
_ [Alt Var]
alts) | Bool
it, Just CoreExpr
e <- CoreExpr -> Var -> [Alt Var] -> Maybe CoreExpr
isUnsafeEqualityCase CoreExpr
s Var
b [Alt Var]
alts = CoreExpr -> Maybe Var
essentiallyVar CoreExpr
e
#endif
    essentiallyVar (Var Var
v)                      = forall a. a -> Maybe a
Just Var
v
    essentiallyVar (Tick HpcTick{} CoreExpr
e) | Bool
it      = CoreExpr -> Maybe Var
essentiallyVar CoreExpr
e
    essentiallyVar CoreExpr
_                            = forall a. Maybe a
Nothing

    go :: Int -> RnEnv2 -> CoreExpr -> CoreExpr -> StateT VarPairSet [] ()
    go :: Int -> RnEnv2 -> CoreExpr -> CoreExpr -> StateT VarPairSet [] ()
go Int
lv RnEnv2
env (Var Var
v1) (Var Var
v2) = do
        if | Var
v1 forall a. Eq a => a -> a -> Bool
== Var
v2 -> do
            forall (m :: * -> *). Monad m => Int -> String -> String -> m ()
tracePut Int
lv String
"VAR" (Var -> String
varToString Var
v1 forall a. [a] -> [a] -> [a]
++ String
" =?= " forall a. [a] -> [a] -> [a]
++ Var -> String
varToString Var
v2 forall a. [a] -> [a] -> [a]
++ String
" SAME")
            forall (m :: * -> *) a. Monad m => a -> m a
return ()
           | RnEnv2 -> Var -> Var
rnOccL RnEnv2
env Var
v1 forall a. Eq a => a -> a -> Bool
== RnEnv2 -> Var -> Var
rnOccR RnEnv2
env Var
v2 -> do
            forall (m :: * -> *). Monad m => Int -> String -> String -> m ()
tracePut Int
lv String
"VAR" (Var -> String
varToString Var
v1 forall a. [a] -> [a] -> [a]
++ String
" =?= " forall a. [a] -> [a] -> [a]
++ Var -> String
varToString Var
v2 forall a. [a] -> [a] -> [a]
++ String
" IN ENV")
            forall (m :: * -> *) a. Monad m => a -> m a
return ()
           | Bool
otherwise -> do
            forall (m :: * -> *). Monad m => Int -> String -> String -> m ()
tracePut Int
lv String
"VAR" (Var -> String
varToString Var
v1 forall a. [a] -> [a] -> [a]
++ String
" =?= " forall a. [a] -> [a] -> [a]
++ Var -> String
varToString Var
v2 forall a. [a] -> [a] -> [a]
++ String
" OBLIGATION")
            forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (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
        forall (m :: * -> *). Monad m => Int -> String -> String -> m ()
tracePut Int
lv String
"LIT" String
"???" -- no Show for Literal :(
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Literal
lit1 forall a. Eq a => a -> a -> Bool
== Literal
lit2

    go Int
_  RnEnv2
env (Type Type
t1)     (Type Type
t2)         = forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env Type
t1 Type
t2
    go Int
_  RnEnv2
env (Coercion CoercionR
co1) (Coercion CoercionR
co2)   = forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ RnEnv2 -> CoercionR -> CoercionR -> Bool
eqCoercionX RnEnv2
env CoercionR
co1 CoercionR
co2

    go Int
lv RnEnv2
env (Cast CoreExpr
e1 CoercionR
_) CoreExpr
e2 | Bool
it             = Int -> RnEnv2 -> CoreExpr -> CoreExpr -> StateT VarPairSet [] ()
go Int
lv RnEnv2
env CoreExpr
e1 CoreExpr
e2
    go Int
lv RnEnv2
env CoreExpr
e1 (Cast CoreExpr
e2 CoercionR
_) | Bool
it             = Int -> RnEnv2 -> CoreExpr -> CoreExpr -> StateT VarPairSet [] ()
go Int
lv RnEnv2
env CoreExpr
e1 CoreExpr
e2
#if MIN_VERSION_ghc(9,0,0)
    go Int
lv RnEnv2
env (Case CoreExpr
s Var
b Type
_ [Alt Var]
alts) CoreExpr
e2 | Bool
it, Just CoreExpr
e1 <- CoreExpr -> Var -> [Alt Var] -> Maybe CoreExpr
isUnsafeEqualityCase CoreExpr
s Var
b [Alt Var]
alts = Int -> RnEnv2 -> CoreExpr -> CoreExpr -> StateT VarPairSet [] ()
go Int
lv RnEnv2
env CoreExpr
e1 CoreExpr
e2
    go Int
lv RnEnv2
env CoreExpr
e1 (Case CoreExpr
s Var
b Type
_ [Alt Var]
alts) | Bool
it, Just CoreExpr
e2 <- CoreExpr -> Var -> [Alt Var] -> Maybe CoreExpr
isUnsafeEqualityCase CoreExpr
s Var
b [Alt Var]
alts = Int -> RnEnv2 -> CoreExpr -> CoreExpr -> StateT VarPairSet [] ()
go Int
lv RnEnv2
env CoreExpr
e1 CoreExpr
e2
#endif
    go Int
lv RnEnv2
env (Cast CoreExpr
e1 CoercionR
co1) (Cast CoreExpr
e2 CoercionR
co2)     = forall (m :: * -> *).
Monad m =>
Int -> String -> String -> (Int -> m ()) -> m ()
traceBlock Int
lv String
"CAST" String
"" forall a b. (a -> b) -> a -> b
$ \Int
lv -> do
                                                   forall (f :: * -> *). Alternative f => Bool -> f ()
guard (RnEnv2 -> CoercionR -> CoercionR -> Bool
eqCoercionX RnEnv2
env CoercionR
co1 CoercionR
co2)
                                                   Int -> RnEnv2 -> CoreExpr -> CoreExpr -> StateT VarPairSet [] ()
go Int
lv RnEnv2
env CoreExpr
e1 CoreExpr
e2

    go Int
lv RnEnv2
env (App CoreExpr
e1 CoreExpr
a) CoreExpr
e2 | Bool
it, forall b. Expr b -> Bool
isTyCoArg CoreExpr
a = Int -> RnEnv2 -> CoreExpr -> CoreExpr -> StateT VarPairSet [] ()
go Int
lv RnEnv2
env CoreExpr
e1 CoreExpr
e2
    go Int
lv RnEnv2
env CoreExpr
e1 (App CoreExpr
e2 CoreExpr
a) | Bool
it, forall b. Expr b -> Bool
isTyCoArg CoreExpr
a = Int -> RnEnv2 -> CoreExpr -> CoreExpr -> StateT VarPairSet [] ()
go Int
lv RnEnv2
env CoreExpr
e1 CoreExpr
e2
    go Int
lv RnEnv2
env (App CoreExpr
f1 CoreExpr
a1)   (App CoreExpr
f2 CoreExpr
a2)       = forall (m :: * -> *).
Monad m =>
Int -> String -> String -> (Int -> m ()) -> m ()
traceBlock Int
lv String
"APP" String
"" forall a b. (a -> b) -> a -> b
$ \Int
lv -> do
                                                   Int -> RnEnv2 -> CoreExpr -> CoreExpr -> StateT VarPairSet [] ()
go Int
lv RnEnv2
env CoreExpr
f1 CoreExpr
f2
                                                   Int -> RnEnv2 -> CoreExpr -> CoreExpr -> StateT VarPairSet [] ()
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 VarPairSet [] ()
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 VarPairSet [] ()
go Int
lv RnEnv2
env CoreExpr
e1 CoreExpr
e2
    go Int
lv RnEnv2
env (Tick CoreTickish
n1 CoreExpr
e1)  (Tick CoreTickish
n2 CoreExpr
e2)      = forall (m :: * -> *).
Monad m =>
Int -> String -> String -> (Int -> m ()) -> m ()
traceBlock Int
lv String
"TICK" String
"" forall a b. (a -> b) -> a -> b
$ \Int
lv -> do
                                                   forall (f :: * -> *). Alternative f => Bool -> f ()
guard (RnEnv2 -> CoreTickish -> CoreTickish -> Bool
go_tick RnEnv2
env CoreTickish
n1 CoreTickish
n2)
                                                   Int -> RnEnv2 -> CoreExpr -> CoreExpr -> StateT VarPairSet [] ()
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 VarPairSet [] ()
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 VarPairSet [] ()
go Int
lv RnEnv2
env CoreExpr
e1 CoreExpr
e2
    go Int
lv RnEnv2
env (Lam Var
b1 CoreExpr
e1)  (Lam Var
b2 CoreExpr
e2)        = forall (m :: * -> *).
Monad m =>
Int -> String -> String -> (Int -> m ()) -> m ()
traceBlock Int
lv String
"LAM" (Var -> String
varToString Var
b1 forall a. [a] -> [a] -> [a]
++ String
" ~ " forall a. [a] -> [a] -> [a]
++ Var -> String
varToString Var
b2) forall a b. (a -> b) -> a -> b
$ \Int
lv -> do
           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 VarPairSet [] ()
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') <- forall {a}. Expr a -> ([(a, Expr a)], Expr a)
peelLets CoreExpr
e1
      , ([(Var, CoreExpr)]
ps2, CoreExpr
e2') <- forall {a}. Expr a -> ([(a, Expr a)], Expr a)
peelLets CoreExpr
e2
      = forall (m :: * -> *).
Monad m =>
Int -> String -> String -> (Int -> m ()) -> m ()
traceBlock Int
lv String
"LET" (forall a. [(Var, a)] -> String
showVars [(Var, CoreExpr)]
ps1 forall a. [a] -> [a] -> [a]
++ String
" ~ " forall a. [a] -> [a] -> [a]
++ forall a. [(Var, a)] -> String
showVars [(Var, CoreExpr)]
ps2) forall a b. (a -> b) -> a -> b
$ \Int
lv -> do
           forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> Bool
equalLength [(Var, CoreExpr)]
ps1 [(Var, CoreExpr)]
ps2
           RnEnv2
env' <- Int
-> RnEnv2
-> [(Var, CoreExpr)]
-> [(Var, CoreExpr)]
-> StateT VarPairSet [] RnEnv2
goBinds Int
lv RnEnv2
env [(Var, CoreExpr)]
ps1 [(Var, CoreExpr)]
ps2
           Int -> RnEnv2 -> CoreExpr -> CoreExpr -> StateT VarPairSet [] ()
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 VarPairSet [] ()
go Int
lv RnEnv2
env CoreExpr
r1 CoreExpr
r2  -- No need to check binder types, since RHSs match
           Int -> RnEnv2 -> CoreExpr -> CoreExpr -> StateT VarPairSet [] ()
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 forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> Bool
equalLength [(Var, CoreExpr)]
ps1 [(Var, CoreExpr)]
ps2
           forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Int -> RnEnv2 -> CoreExpr -> CoreExpr -> StateT VarPairSet [] ()
go Int
lv RnEnv2
env') [CoreExpr]
rs1 [CoreExpr]
rs2
           Int -> RnEnv2 -> CoreExpr -> CoreExpr -> StateT VarPairSet [] ()
go Int
lv RnEnv2
env' CoreExpr
e1 CoreExpr
e2
      where
        ([Var]
bs1,[CoreExpr]
rs1) = forall a b. [(a, b)] -> ([a], [b])
unzip [(Var, CoreExpr)]
ps1
        ([Var]
bs2,[CoreExpr]
rs2) = 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)
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Alt Var]
a1   -- See Note [Empty case alternatives] in TrieMap
      = do forall (f :: * -> *). Alternative f => Bool -> f ()
guard (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Alt Var]
a2)
           Int -> RnEnv2 -> CoreExpr -> CoreExpr -> StateT VarPairSet [] ()
go Int
lv RnEnv2
env CoreExpr
e1 CoreExpr
e2
           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 forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> Bool
equalLength [Alt Var]
a1 [Alt Var]
a2
           Int -> RnEnv2 -> CoreExpr -> CoreExpr -> StateT VarPairSet [] ()
go Int
lv RnEnv2
env CoreExpr
e1 CoreExpr
e2
           forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Int -> RnEnv2 -> Alt Var -> Alt Var -> StateT VarPairSet [] ()
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
        forall (m :: * -> *). Monad m => Int -> String -> String -> m ()
tracePut Int
lv String
"FAIL" (CoreExpr -> String
conToString CoreExpr
e1 forall a. [a] -> [a] -> [a]
++ String
" =/= " forall a. [a] -> [a] -> [a]
++ CoreExpr -> String
conToString CoreExpr
e2)
        forall (m :: * -> *) a. MonadPlus m => m a
mzero

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

    go_tick :: RnEnv2 -> CoreTickish -> CoreTickish -> Bool
    go_tick :: RnEnv2 -> CoreTickish -> CoreTickish -> Bool
go_tick RnEnv2
env Breakpoint{ breakpointId :: forall (pass :: TickishPass). GenTickish pass -> Int
breakpointId = Int
lid, breakpointFVs :: forall (pass :: TickishPass). GenTickish pass -> [XTickishId pass]
breakpointFVs = [XTickishId 'TickishPassCore]
lids } Breakpoint{ breakpointId :: forall (pass :: TickishPass). GenTickish pass -> Int
breakpointId = Int
rid, breakpointFVs :: forall (pass :: TickishPass). GenTickish pass -> [XTickishId pass]
breakpointFVs = [XTickishId 'TickishPassCore]
rids }
          = Int
lid forall a. Eq a => a -> a -> Bool
== Int
rid  Bool -> Bool -> Bool
&&  forall a b. (a -> b) -> [a] -> [b]
map (RnEnv2 -> Var -> Var
rnOccL RnEnv2
env) [XTickishId 'TickishPassCore]
lids forall a. Eq a => a -> a -> Bool
== forall a b. (a -> b) -> [a] -> [b]
map (RnEnv2 -> Var -> Var
rnOccR RnEnv2
env) [XTickishId 'TickishPassCore]
rids
    go_tick RnEnv2
_ CoreTickish
l CoreTickish
r = CoreTickish
l forall a. Eq a => a -> a -> Bool
== CoreTickish
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)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 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 VarPairSet [] RnEnv2
goBinds Int
_  RnEnv2
env []           []    = forall (m :: * -> *) a. Monad m => a -> m a
return RnEnv2
env
    goBinds Int
_  RnEnv2
_   []           ((Var, CoreExpr)
_:[(Var, CoreExpr)]
_) = forall (m :: * -> *) a. MonadPlus m => m a
mzero
    goBinds Int
lv RnEnv2
env ((Var
v1,CoreExpr
b1):[(Var, CoreExpr)]
xs) [(Var, CoreExpr)]
ys'   = do
        -- select a binding
        ((Var
v2,CoreExpr
b2), [(Var, CoreExpr)]
ys) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. [a] -> [(a, [a])]
choices [(Var, CoreExpr)]
ys')

        forall (m :: * -> *).
Monad m =>
Int -> String -> String -> (Int -> m ()) -> m ()
traceBlock Int
lv String
"LET*" (Var -> String
varToString Var
v1 forall a. [a] -> [a] -> [a]
++ String
" =?= " forall a. [a] -> [a] -> [a]
++ Var -> String
varToString Var
v2) forall a b. (a -> b) -> a -> b
$ \Int
lv ->
            Int -> RnEnv2 -> CoreExpr -> CoreExpr -> StateT VarPairSet [] ()
go Int
lv RnEnv2
env CoreExpr
b1 CoreExpr
b2

        -- if match succeeds, delete it from the obligations
        forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall a. Ord a => a -> Set a -> Set a
S.delete (Var
v1, Var
v2))
        -- continue with the rest of bindings, adding a pair as matching one.
        Int
-> RnEnv2
-> [(Var, CoreExpr)]
-> [(Var, CoreExpr)]
-> StateT VarPairSet [] RnEnv2
goBinds Int
lv (RnEnv2 -> Var -> Var -> RnEnv2
rnBndr2 RnEnv2
env Var
v1 Var
v2) [(Var, CoreExpr)]
xs [(Var, CoreExpr)]
ys

#if !MIN_VERSION_ghc(9,9,0) && MIN_VERSION_ghc(9,0,0)
isUnsafeEqualityCase :: CoreExpr -> Id -> [CoreAlt] -> Maybe CoreExpr
isUnsafeEqualityCase :: CoreExpr -> Var -> [Alt Var] -> Maybe CoreExpr
isUnsafeEqualityCase CoreExpr
scrut Var
_bndr [Alt AltCon
_ [Var]
_ CoreExpr
rhs]
  | CoreExpr -> Bool
isUnsafeEqualityProof CoreExpr
scrut = forall a. a -> Maybe a
Just CoreExpr
rhs
isUnsafeEqualityCase CoreExpr
_ Var
_ [Alt Var]
_ = forall a. Maybe a
Nothing
#endif

#if !MIN_VERSION_ghc(9,2,0)
type CoreTickish = Tickish Id
#endif

traceBlock :: Monad m => Int -> String -> String -> (Int -> m ()) -> m ()
traceBlock :: forall (m :: * -> *).
Monad m =>
Int -> String -> String -> (Int -> m ()) -> m ()
traceBlock Int
lv String
name String
msg Int -> m ()
action = do
    forall (m :: * -> *). Monad m => Int -> String -> String -> m ()
tracePut Int
lv String
name String
msg
    Int -> m ()
action (Int
lv forall a. Num a => a -> a -> a
+ Int
1)
    forall (m :: * -> *). Monad m => Int -> String -> String -> m ()
tracePut Int
lv String
name forall a b. (a -> b) -> a -> b
$ String
msg forall a. [a] -> [a] -> [a]
++ String
" OK"

showVars :: [(Var, a)] -> String
showVars :: forall a. [(Var, a)] -> String
showVars [(Var, a)]
xs = forall a. [a] -> [[a]] -> [a]
intercalate String
", " [ Var -> String
varToString Var
x | (Var
x, a
_) <- [(Var, a)]
xs ]

showVarPairSet :: VarPairSet -> String
showVarPairSet :: VarPairSet -> String
showVarPairSet VarPairSet
xs = forall a. [a] -> [[a]] -> [a]
intercalate String
", " [ Var -> String
varToString Var
x forall a. [a] -> [a] -> [a]
++ String
" ~ " forall a. [a] -> [a] -> [a]
++ Var -> String
varToString Var
y | (Var
x, Var
y) <- forall a. Set a -> [a]
S.toList VarPairSet
xs ]

varToString :: Var -> String
varToString :: Var -> String
varToString Var
v = OccName -> String
occNameString (forall name. HasOccName name => name -> OccName
occName (Var -> Name
tyVarName Var
v)) forall a. [a] -> [a] -> [a]
++ String
"_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Uniquable a => a -> Unique
getUnique Var
v)
-- using tyVarName as varName is ambiguous.

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 ""
-- []
--
-- >>> choices "abcde"
-- [('a',"bcde"),('b',"acde"),('c',"abde"),('d',"abce"),('e',"abcd")]
--
choices :: [a] -> [(a, [a])]
choices :: forall a. [a] -> [(a, [a])]
choices = forall a. ([a] -> [a]) -> [a] -> [(a, [a])]
go forall a. a -> a
id where
    go :: ([a] -> [a]) -> [a] -> [(a, [a])]
    go :: forall a. ([a] -> [a]) -> [a] -> [(a, [a])]
go [a] -> [a]
_ [] = []
    go [a] -> [a]
f (a
x:[a]
xs) = (a
x, [a] -> [a]
f [a]
xs) forall a. a -> [a] -> [a]
: forall a. ([a] -> [a]) -> [a] -> [(a, [a])]
go ([a] -> [a]
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
x forall a. a -> [a] -> [a]
:)) [a]
xs

-- | 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 =
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Var
a,CoreExpr
b,[TyCon]
_) -> (Var
a,CoreExpr
b))
    forall a b. (a -> b) -> a -> b
$ (TyCon -> Bool)
-> [(Var, CoreExpr)] -> Maybe (Var, CoreExpr, [TyCon])
allTyCons (\TyCon
tc -> forall a. NamedThing a => a -> Name
getName TyCon
tc 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 =
    forall a. [a] -> Maybe a
listToMaybe
        [(Var
v, CoreExpr
e, 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 (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 forall a. [a] -> [a] -> [a]
++ CoreExpr -> [TyCon]
go CoreExpr
a
    go (Lam Var
b CoreExpr
e)         = Var -> [TyCon]
goV Var
b forall a. [a] -> [a] -> [a]
++ CoreExpr -> [TyCon]
go CoreExpr
e
    go (Let Bind Var
bind CoreExpr
body)   = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Var, CoreExpr) -> [TyCon]
goB (forall b. [Bind b] -> [(b, Expr b)]
flattenBinds [Bind Var
bind]) 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 forall a. [a] -> [a] -> [a]
++ Var -> [TyCon]
goV Var
b forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Alt Var -> [TyCon]
goA [Alt Var]
alts
    go (Cast CoreExpr
e CoercionR
_)        = CoreExpr -> [TyCon]
go CoreExpr
e
    go (Tick CoreTickish
_ CoreExpr
e)        = CoreExpr -> [TyCon]
go CoreExpr
e
    go (Type Type
t)          = (Type -> [TyCon]
goT Type
t)
    go (Coercion CoercionR
_)      = []

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

    goA :: Alt Var -> [TyCon]
goA (Alt AltCon
_ [Var]
pats CoreExpr
e) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Var -> [TyCon]
goV [Var]
pats 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 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)] forall a. [a] -> [a] -> [a]
++ 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)
               AnonArgFlag
_
#endif
# if MIN_VERSION_GLASGOW_HASKELL(8,9,0,0)
               Type
_
# endif
                 Type
t1 Type
t2)  = Type -> [TyCon]
goT Type
t1 forall a. [a] -> [a] -> [a]
++ Type -> [TyCon]
goT Type
t2
#endif
    goT (LitTy TyLit
_)        = []
    goT (CastTy Type
t CoercionR
_)     = Type -> [TyCon]
goT Type
t
    goT (CoercionTy CoercionR
_)   = []
--
-- | 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 = forall a. [a] -> Maybe a
listToMaybe [ (Var
v,CoreExpr
e) | (Var
v,CoreExpr
e) <- [(Var, CoreExpr)]
slice, Bool -> Bool
not (forall b. Expr b -> Bool
go CoreExpr
e) ]
  where
    isNeedle :: Name -> Bool
isNeedle Name
n = Name
n 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)   = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (b, Expr b) -> Bool
goB (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
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Alt b -> Bool
goA [Alt b]
alts
    go (Cast Expr b
e CoercionR
_)        = Expr b -> Bool
go Expr b
e
    go (Tick CoreTickish
_ Expr b
e)        = Expr b -> Bool
go Expr b
e
    go (Type Type
_)          = Bool
True
    go (Coercion CoercionR
_)      = 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


-- | 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 = 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 forall a. Ord a => a -> a -> Bool
> Int
0 = Bool
False
    go Int
a (Var Var
v)                         = Int
a 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) | 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
aforall 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
aforall a. Num a => a -> a -> a
-Int
1) CoreExpr
e
    go Int
a (Let Bind Var
bind CoreExpr
body)                 = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Var, CoreExpr) -> Bool
goB (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
&& 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 CoercionR
_)                      = Int -> CoreExpr -> Bool
go Int
a CoreExpr
e
    go Int
a (Tick CoreTickish
_ CoreExpr
e)                      = Int -> CoreExpr -> Bool
go Int
a CoreExpr
e
    go Int
_ (Type Type
_)                        = Bool
True
    go Int
_ (Coercion CoercionR
_)                    = Bool
True

    goArg :: CoreExpr -> Bool
goArg CoreExpr
e | CoreExpr -> Bool
exprIsTrivial CoreExpr
e             = Int -> CoreExpr -> Bool
go Int
0 CoreExpr
e
            | HasDebugCallStack => 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
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 (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
isCTupleTyConName (forall a. NamedThing a => a -> Name
getName TyCon
tc) Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. NamedThing a => a -> Name
getName TyCon
tc 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
    -- convert RnEnv2 to Subst
    -- here we forget about tyvars and covars, but mostly this is good enough.
    sub :: Subst
sub = InScopeSet -> [(Var, CoreExpr)] -> Subst
mkOpenSubst InScopeSet
emptyInScopeSet [ (Var
v1, if Var -> Bool
isTyVar Var
v2 then forall b. Type -> Expr b
Type (Var -> Type
mkTyVarTy Var
v2) else if Var -> Bool
isCoVar Var
v2 then forall b. CoercionR -> Expr b
Coercion (Var -> CoercionR
mkCoVarCo Var
v2) else 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' :: Subst -> CoreExpr -> CoreExpr
substExpr' = HasDebugCallStack => Subst -> CoreExpr -> CoreExpr
substExpr
#else
    substExpr' = substExpr empty
#endif