{-# LANGUAGE CPP #-}
module GHC.Core.Utils (
mkCast, mkCastMCo, mkPiMCo,
mkTick, mkTicks, mkTickNoHNF, tickHNFArgs,
bindNonRec, needsCaseBinding,
mkAltExpr, mkDefaultCase, mkSingleAltCase,
findDefault, addDefault, findAlt, isDefaultAlt,
mergeAlts, trimConArgs,
filterAlts, combineIdenticalAlts, refineDefaultAlt,
scaleAltsBy,
exprType, coreAltType, coreAltsType, mkLamType, mkLamTypes,
mkFunctionType,
isExprLevPoly,
exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsDeadEnd,
getIdFromTrivialExpr_maybe,
exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun,
exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprIsWorkFree,
exprIsConLike,
isCheapApp, isExpandableApp,
exprIsTickedString, exprIsTickedString_maybe,
exprIsTopLevelBindable,
altsAreExhaustive,
cheapEqExpr, cheapEqExpr', eqExpr,
diffExpr, diffBinds,
tryEtaReduce, zapLamBndrs,
exprToType, exprToCoercion_maybe,
applyTypeToArgs, applyTypeToArg,
dataConRepInstPat, dataConRepFSInstPat,
isEmptyTy,
stripTicksTop, stripTicksTopE, stripTicksTopT,
stripTicksE, stripTicksT,
collectMakeStaticArgs,
isJoinBind,
isUnsafeEqualityProof,
dumpIdInfoOfProgram
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Platform
import GHC.Driver.Ppr
import GHC.Core
import GHC.Builtin.Names (absentErrorIdKey, makeStaticName, unsafeEqualityProofName)
import GHC.Core.Ppr
import GHC.Core.FVs( exprFreeVars )
import GHC.Types.Var
import GHC.Types.SrcLoc
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Types.Name
import GHC.Types.Literal
import GHC.Types.Tickish
import GHC.Types.Demand ( isDeadEndAppSig )
import GHC.Core.DataCon
import GHC.Builtin.PrimOps
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Core.Type as Type
import GHC.Core.Predicate
import GHC.Core.TyCo.Rep( TyCoBinder(..), TyBinder )
import GHC.Core.Coercion
import GHC.Core.TyCon
import GHC.Core.Multiplicity
import GHC.Types.Unique
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Data.FastString
import GHC.Data.Maybe
import GHC.Data.List.SetOps( minusList )
import GHC.Types.Basic ( Arity, FullArgCount )
import GHC.Utils.Misc
import GHC.Data.Pair
import Data.ByteString ( ByteString )
import Data.Function ( on )
import Data.List ( sort, sortBy, partition, zipWith4, mapAccumL )
import Data.Ord ( comparing )
import GHC.Data.OrdList
import qualified Data.Set as Set
import GHC.Types.Unique.Set
exprType :: CoreExpr -> Type
exprType :: CoreExpr -> Type
exprType (Var Var
var) = Var -> Type
idType Var
var
exprType (Lit Literal
lit) = Literal -> Type
literalType Literal
lit
exprType (Coercion CoercionR
co) = CoercionR -> Type
coercionType CoercionR
co
exprType (Let Bind Var
bind CoreExpr
body)
| NonRec Var
tv CoreExpr
rhs <- Bind Var
bind
, Type Type
ty <- CoreExpr
rhs = [Var] -> [Type] -> Type -> Type
substTyWithUnchecked [Var
tv] [Type
ty] (CoreExpr -> Type
exprType CoreExpr
body)
| Bool
otherwise = CoreExpr -> Type
exprType CoreExpr
body
exprType (Case CoreExpr
_ Var
_ Type
ty [Alt Var]
_) = Type
ty
exprType (Cast CoreExpr
_ CoercionR
co) = forall a. Pair a -> a
pSnd (CoercionR -> Pair Type
coercionKind CoercionR
co)
exprType (Tick CoreTickish
_ CoreExpr
e) = CoreExpr -> Type
exprType CoreExpr
e
exprType (Lam Var
binder CoreExpr
expr) = Var -> Type -> Type
mkLamType Var
binder (CoreExpr -> Type
exprType CoreExpr
expr)
exprType e :: CoreExpr
e@(App CoreExpr
_ CoreExpr
_)
= case forall b. Expr b -> (Expr b, [Expr b])
collectArgs CoreExpr
e of
(CoreExpr
fun, [CoreExpr]
args) -> SDoc -> Type -> [CoreExpr] -> Type
applyTypeToArgs (forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr CoreExpr
e) (CoreExpr -> Type
exprType CoreExpr
fun) [CoreExpr]
args
exprType CoreExpr
other = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"exprType" (forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr CoreExpr
other)
coreAltType :: CoreAlt -> Type
coreAltType :: Alt Var -> Type
coreAltType alt :: Alt Var
alt@(Alt AltCon
_ [Var]
bs CoreExpr
rhs)
= case [Var] -> Type -> Maybe Type
occCheckExpand [Var]
bs Type
rhs_ty of
Just Type
ty -> Type
ty
Maybe Type
Nothing -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"coreAltType" (forall a. OutputableBndr a => Alt a -> SDoc
pprCoreAlt Alt Var
alt SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr Type
rhs_ty)
where
rhs_ty :: Type
rhs_ty = CoreExpr -> Type
exprType CoreExpr
rhs
coreAltsType :: [CoreAlt] -> Type
coreAltsType :: [Alt Var] -> Type
coreAltsType (Alt Var
alt:[Alt Var]
_) = Alt Var -> Type
coreAltType Alt Var
alt
coreAltsType [] = forall a. String -> a
panic String
"corAltsType"
mkLamType :: Var -> Type -> Type
mkLamTypes :: [Var] -> Type -> Type
mkLamType :: Var -> Type -> Type
mkLamType Var
v Type
body_ty
| Var -> Bool
isTyVar Var
v
= Var -> ArgFlag -> Type -> Type
mkForAllTy Var
v ArgFlag
Inferred Type
body_ty
| Var -> Bool
isCoVar Var
v
, Var
v Var -> VarSet -> Bool
`elemVarSet` Type -> VarSet
tyCoVarsOfType Type
body_ty
= Var -> ArgFlag -> Type -> Type
mkForAllTy Var
v ArgFlag
Required Type
body_ty
| Bool
otherwise
= Type -> Type -> Type -> Type
mkFunctionType (Var -> Type
varMult Var
v) (Var -> Type
varType Var
v) Type
body_ty
mkFunctionType :: Mult -> Type -> Type -> Type
mkFunctionType :: Type -> Type -> Type -> Type
mkFunctionType Type
mult Type
arg_ty Type
res_ty
| HasDebugCallStack => Type -> Bool
isPredTy Type
arg_ty
= ASSERT(eqType mult Many)
Type -> Type -> Type -> Type
mkInvisFunTy Type
mult Type
arg_ty Type
res_ty
| Bool
otherwise
= Type -> Type -> Type -> Type
mkVisFunTy Type
mult Type
arg_ty Type
res_ty
mkLamTypes :: [Var] -> Type -> Type
mkLamTypes [Var]
vs Type
ty = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Var -> Type -> Type
mkLamType Type
ty [Var]
vs
isExprLevPoly :: CoreExpr -> Bool
isExprLevPoly :: CoreExpr -> Bool
isExprLevPoly = CoreExpr -> Bool
go
where
go :: CoreExpr -> Bool
go (Var Var
_) = Bool
False
go (Lit Literal
_) = Bool
False
go e :: CoreExpr
e@(App CoreExpr
f CoreExpr
_) | Bool -> Bool
not (forall {b}. OutputableBndr b => Expr b -> Bool
go_app CoreExpr
f) = Bool
False
| Bool
otherwise = CoreExpr -> Bool
check_type CoreExpr
e
go (Lam Var
_ CoreExpr
_) = Bool
False
go (Let Bind Var
_ CoreExpr
e) = CoreExpr -> Bool
go CoreExpr
e
go e :: CoreExpr
e@(Case {}) = CoreExpr -> Bool
check_type CoreExpr
e
go e :: CoreExpr
e@(Cast {}) = CoreExpr -> Bool
check_type CoreExpr
e
go (Tick CoreTickish
_ CoreExpr
e) = CoreExpr -> Bool
go CoreExpr
e
go e :: CoreExpr
e@(Type {}) = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"isExprLevPoly ty" (forall a. Outputable a => a -> SDoc
ppr CoreExpr
e)
go (Coercion {}) = Bool
False
check_type :: CoreExpr -> Bool
check_type = Type -> Bool
isTypeLevPoly forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> Type
exprType
go_app :: Expr b -> Bool
go_app (Var Var
id) = Bool -> Bool
not (Var -> Bool
isNeverLevPolyId Var
id)
go_app (Lit Literal
_) = Bool
False
go_app (App Expr b
f Expr b
_) = Expr b -> Bool
go_app Expr b
f
go_app (Lam b
_ Expr b
e) = Expr b -> Bool
go_app Expr b
e
go_app (Let Bind b
_ Expr b
e) = Expr b -> Bool
go_app Expr b
e
go_app (Case Expr b
_ b
_ Type
ty [Alt b]
_) = Type -> Bool
resultIsLevPoly Type
ty
go_app (Cast Expr b
_ CoercionR
co) = Type -> Bool
resultIsLevPoly (CoercionR -> Type
coercionRKind CoercionR
co)
go_app (Tick CoreTickish
_ Expr b
e) = Expr b -> Bool
go_app Expr b
e
go_app e :: Expr b
e@(Type {}) = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"isExprLevPoly app ty" (forall a. Outputable a => a -> SDoc
ppr Expr b
e)
go_app e :: Expr b
e@(Coercion {}) = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"isExprLevPoly app co" (forall a. Outputable a => a -> SDoc
ppr Expr b
e)
applyTypeToArgs :: SDoc -> Type -> [CoreExpr] -> Type
applyTypeToArgs :: SDoc -> Type -> [CoreExpr] -> Type
applyTypeToArgs SDoc
pp_e Type
op_ty [CoreExpr]
args
= Type -> [CoreExpr] -> Type
go Type
op_ty [CoreExpr]
args
where
go :: Type -> [CoreExpr] -> Type
go Type
op_ty [] = Type
op_ty
go Type
op_ty (Type Type
ty : [CoreExpr]
args) = Type -> [Type] -> [CoreExpr] -> Type
go_ty_args Type
op_ty [Type
ty] [CoreExpr]
args
go Type
op_ty (Coercion CoercionR
co : [CoreExpr]
args) = Type -> [Type] -> [CoreExpr] -> Type
go_ty_args Type
op_ty [CoercionR -> Type
mkCoercionTy CoercionR
co] [CoreExpr]
args
go Type
op_ty (CoreExpr
_ : [CoreExpr]
args) | Just (Type
_, Type
_, Type
res_ty) <- Type -> Maybe (Type, Type, Type)
splitFunTy_maybe Type
op_ty
= Type -> [CoreExpr] -> Type
go Type
res_ty [CoreExpr]
args
go Type
_ [CoreExpr]
args = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"applyTypeToArgs" ([CoreExpr] -> SDoc
panic_msg [CoreExpr]
args)
go_ty_args :: Type -> [Type] -> [CoreExpr] -> Type
go_ty_args Type
op_ty [Type]
rev_tys (Type Type
ty : [CoreExpr]
args)
= Type -> [Type] -> [CoreExpr] -> Type
go_ty_args Type
op_ty (Type
tyforall a. a -> [a] -> [a]
:[Type]
rev_tys) [CoreExpr]
args
go_ty_args Type
op_ty [Type]
rev_tys (Coercion CoercionR
co : [CoreExpr]
args)
= Type -> [Type] -> [CoreExpr] -> Type
go_ty_args Type
op_ty (CoercionR -> Type
mkCoercionTy CoercionR
co forall a. a -> [a] -> [a]
: [Type]
rev_tys) [CoreExpr]
args
go_ty_args Type
op_ty [Type]
rev_tys [CoreExpr]
args
= Type -> [CoreExpr] -> Type
go (HasDebugCallStack => Type -> [Type] -> Type
piResultTys Type
op_ty (forall a. [a] -> [a]
reverse [Type]
rev_tys)) [CoreExpr]
args
panic_msg :: [CoreExpr] -> SDoc
panic_msg [CoreExpr]
as = [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Expression:" SDoc -> SDoc -> SDoc
<+> SDoc
pp_e
, String -> SDoc
text String
"Type:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Type
op_ty
, String -> SDoc
text String
"Args:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [CoreExpr]
args
, String -> SDoc
text String
"Args':" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [CoreExpr]
as ]
mkCastMCo :: CoreExpr -> MCoercionR -> CoreExpr
mkCastMCo :: CoreExpr -> MCoercionR -> CoreExpr
mkCastMCo CoreExpr
e MCoercionR
MRefl = CoreExpr
e
mkCastMCo CoreExpr
e (MCo CoercionR
co) = forall b. Expr b -> CoercionR -> Expr b
Cast CoreExpr
e CoercionR
co
mkPiMCo :: Var -> MCoercionR -> MCoercionR
mkPiMCo :: Var -> MCoercionR -> MCoercionR
mkPiMCo Var
_ MCoercionR
MRefl = MCoercionR
MRefl
mkPiMCo Var
v (MCo CoercionR
co) = CoercionR -> MCoercionR
MCo (Role -> Var -> CoercionR -> CoercionR
mkPiCo Role
Representational Var
v CoercionR
co)
mkCast :: CoreExpr -> CoercionR -> CoreExpr
mkCast :: CoreExpr -> CoercionR -> CoreExpr
mkCast CoreExpr
e CoercionR
co
| ASSERT2( coercionRole co == Representational
, text "coercion" <+> ppr co <+> ptext (sLit "passed to mkCast")
<+> ppr e <+> text "has wrong role" <+> ppr (coercionRole co) )
CoercionR -> Bool
isReflCo CoercionR
co
= CoreExpr
e
mkCast (Coercion CoercionR
e_co) CoercionR
co
| Type -> Bool
isCoVarType (CoercionR -> Type
coercionRKind CoercionR
co)
= forall b. CoercionR -> Expr b
Coercion (CoercionR -> CoercionR -> CoercionR
mkCoCast CoercionR
e_co CoercionR
co)
mkCast (Cast CoreExpr
expr CoercionR
co2) CoercionR
co
= WARN(let { from_ty = coercionLKind co;
to_ty2 = coercionRKind co2 } in
not (from_ty `eqType` to_ty2),
vcat ([ text "expr:" <+> ppr expr
, text "co2:" <+> ppr co2
, text "co:" <+> ppr co ]) )
CoreExpr -> CoercionR -> CoreExpr
mkCast CoreExpr
expr (CoercionR -> CoercionR -> CoercionR
mkTransCo CoercionR
co2 CoercionR
co)
mkCast (Tick CoreTickish
t CoreExpr
expr) CoercionR
co
= forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t (CoreExpr -> CoercionR -> CoreExpr
mkCast CoreExpr
expr CoercionR
co)
mkCast CoreExpr
expr CoercionR
co
= let from_ty :: Type
from_ty = CoercionR -> Type
coercionLKind CoercionR
co in
WARN( not (from_ty `eqType` exprType expr),
text "Trying to coerce" <+> text "(" <> ppr expr
$$ text "::" <+> ppr (exprType expr) <> text ")"
$$ ppr co $$ ppr (coercionType co)
$$ callStackDoc )
(forall b. Expr b -> CoercionR -> Expr b
Cast CoreExpr
expr CoercionR
co)
mkTick :: CoreTickish -> CoreExpr -> CoreExpr
mkTick :: CoreTickish -> CoreExpr -> CoreExpr
mkTick CoreTickish
t CoreExpr
orig_expr = (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
mkTick' forall a. a -> a
id forall a. a -> a
id CoreExpr
orig_expr
where
canSplit :: Bool
canSplit = forall (pass :: TickishPass). GenTickish pass -> Bool
tickishCanSplit CoreTickish
t Bool -> Bool -> Bool
&& forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
tickishPlace (forall (pass :: TickishPass). GenTickish pass -> GenTickish pass
mkNoCount CoreTickish
t) forall a. Eq a => a -> a -> Bool
/= forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
tickishPlace CoreTickish
t
mkTick' :: (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr)
-> CoreExpr
-> CoreExpr
mkTick' :: (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
mkTick' CoreExpr -> CoreExpr
top CoreExpr -> CoreExpr
rest CoreExpr
expr = case CoreExpr
expr of
Tick CoreTickish
t2 CoreExpr
e
| ProfNote{} <- CoreTickish
t2, ProfNote{} <- CoreTickish
t -> CoreExpr -> CoreExpr
top forall a b. (a -> b) -> a -> b
$ forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr
rest CoreExpr
expr
| forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
tickishPlace CoreTickish
t2 forall a. Eq a => a -> a -> Bool
/= forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
tickishPlace CoreTickish
t -> (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
mkTick' (CoreExpr -> CoreExpr
top forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t2) CoreExpr -> CoreExpr
rest CoreExpr
e
| forall (pass :: TickishPass).
Eq (GenTickish pass) =>
GenTickish pass -> GenTickish pass -> Bool
tickishContains CoreTickish
t CoreTickish
t2 -> (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
mkTick' CoreExpr -> CoreExpr
top CoreExpr -> CoreExpr
rest CoreExpr
e
| forall (pass :: TickishPass).
Eq (GenTickish pass) =>
GenTickish pass -> GenTickish pass -> Bool
tickishContains CoreTickish
t2 CoreTickish
t -> CoreExpr
orig_expr
| Bool
otherwise -> (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
mkTick' CoreExpr -> CoreExpr
top (CoreExpr -> CoreExpr
rest forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t2) CoreExpr
e
Cast CoreExpr
e CoercionR
co -> (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
mkTick' (CoreExpr -> CoreExpr
top forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall b. Expr b -> CoercionR -> Expr b
Cast CoercionR
co) CoreExpr -> CoreExpr
rest CoreExpr
e
Coercion CoercionR
co -> forall b. CoercionR -> Expr b
Coercion CoercionR
co
Lam Var
x CoreExpr
e
| Bool -> Bool
not (Var -> Bool
isRuntimeVar Var
x) Bool -> Bool -> Bool
|| forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
tickishPlace CoreTickish
t forall a. Eq a => a -> a -> Bool
/= TickishPlacement
PlaceRuntime
-> (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
mkTick' (CoreExpr -> CoreExpr
top forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. b -> Expr b -> Expr b
Lam Var
x) CoreExpr -> CoreExpr
rest CoreExpr
e
| Bool
canSplit
-> CoreExpr -> CoreExpr
top forall a b. (a -> b) -> a -> b
$ forall b. CoreTickish -> Expr b -> Expr b
Tick (forall (pass :: TickishPass). GenTickish pass -> GenTickish pass
mkNoScope CoreTickish
t) forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr
rest forall a b. (a -> b) -> a -> b
$ forall b. b -> Expr b -> Expr b
Lam Var
x forall a b. (a -> b) -> a -> b
$ CoreTickish -> CoreExpr -> CoreExpr
mkTick (forall (pass :: TickishPass). GenTickish pass -> GenTickish pass
mkNoCount CoreTickish
t) CoreExpr
e
App CoreExpr
f CoreExpr
arg
| Bool -> Bool
not (CoreExpr -> Bool
isRuntimeArg CoreExpr
arg)
-> (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
mkTick' (CoreExpr -> CoreExpr
top forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall b. Expr b -> Expr b -> Expr b
App CoreExpr
arg) CoreExpr -> CoreExpr
rest CoreExpr
f
| CoreExpr -> Bool
isSaturatedConApp CoreExpr
expr Bool -> Bool -> Bool
&& (forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
tickishPlace CoreTickish
tforall a. Eq a => a -> a -> Bool
==TickishPlacement
PlaceCostCentre Bool -> Bool -> Bool
|| Bool
canSplit)
-> if forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
tickishPlace CoreTickish
t forall a. Eq a => a -> a -> Bool
== TickishPlacement
PlaceCostCentre
then CoreExpr -> CoreExpr
top forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr
rest forall a b. (a -> b) -> a -> b
$ CoreTickish -> CoreExpr -> CoreExpr
tickHNFArgs CoreTickish
t CoreExpr
expr
else CoreExpr -> CoreExpr
top forall a b. (a -> b) -> a -> b
$ forall b. CoreTickish -> Expr b -> Expr b
Tick (forall (pass :: TickishPass). GenTickish pass -> GenTickish pass
mkNoScope CoreTickish
t) forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr
rest forall a b. (a -> b) -> a -> b
$ CoreTickish -> CoreExpr -> CoreExpr
tickHNFArgs (forall (pass :: TickishPass). GenTickish pass -> GenTickish pass
mkNoCount CoreTickish
t) CoreExpr
expr
Var Var
x
| Bool
notFunction Bool -> Bool -> Bool
&& forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
tickishPlace CoreTickish
t forall a. Eq a => a -> a -> Bool
== TickishPlacement
PlaceCostCentre
-> CoreExpr
orig_expr
| Bool
notFunction Bool -> Bool -> Bool
&& Bool
canSplit
-> CoreExpr -> CoreExpr
top forall a b. (a -> b) -> a -> b
$ forall b. CoreTickish -> Expr b -> Expr b
Tick (forall (pass :: TickishPass). GenTickish pass -> GenTickish pass
mkNoScope CoreTickish
t) forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr
rest CoreExpr
expr
where
notFunction :: Bool
notFunction = Bool -> Bool
not (Type -> Bool
isFunTy (Var -> Type
idType Var
x))
Lit{}
| forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
tickishPlace CoreTickish
t forall a. Eq a => a -> a -> Bool
== TickishPlacement
PlaceCostCentre
-> CoreExpr
orig_expr
CoreExpr
_any -> CoreExpr -> CoreExpr
top forall a b. (a -> b) -> a -> b
$ forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr
rest CoreExpr
expr
mkTicks :: [CoreTickish] -> CoreExpr -> CoreExpr
mkTicks :: [CoreTickish] -> CoreExpr -> CoreExpr
mkTicks [CoreTickish]
ticks CoreExpr
expr = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CoreTickish -> CoreExpr -> CoreExpr
mkTick CoreExpr
expr [CoreTickish]
ticks
isSaturatedConApp :: CoreExpr -> Bool
isSaturatedConApp :: CoreExpr -> Bool
isSaturatedConApp CoreExpr
e = forall {b}. Expr b -> [Expr b] -> Bool
go CoreExpr
e []
where go :: Expr b -> [Expr b] -> Bool
go (App Expr b
f Expr b
a) [Expr b]
as = Expr b -> [Expr b] -> Bool
go Expr b
f (Expr b
aforall a. a -> [a] -> [a]
:[Expr b]
as)
go (Var Var
fun) [Expr b]
args
= Var -> Bool
isConLikeId Var
fun Bool -> Bool -> Bool
&& Var -> FullArgCount
idArity Var
fun forall a. Eq a => a -> a -> Bool
== forall b. [Arg b] -> FullArgCount
valArgCount [Expr b]
args
go (Cast Expr b
f CoercionR
_) [Expr b]
as = Expr b -> [Expr b] -> Bool
go Expr b
f [Expr b]
as
go Expr b
_ [Expr b]
_ = Bool
False
mkTickNoHNF :: CoreTickish -> CoreExpr -> CoreExpr
mkTickNoHNF :: CoreTickish -> CoreExpr -> CoreExpr
mkTickNoHNF CoreTickish
t CoreExpr
e
| CoreExpr -> Bool
exprIsHNF CoreExpr
e = CoreTickish -> CoreExpr -> CoreExpr
tickHNFArgs CoreTickish
t CoreExpr
e
| Bool
otherwise = CoreTickish -> CoreExpr -> CoreExpr
mkTick CoreTickish
t CoreExpr
e
tickHNFArgs :: CoreTickish -> CoreExpr -> CoreExpr
tickHNFArgs :: CoreTickish -> CoreExpr -> CoreExpr
tickHNFArgs CoreTickish
t CoreExpr
e = CoreTickish -> CoreExpr -> CoreExpr
push CoreTickish
t CoreExpr
e
where
push :: CoreTickish -> CoreExpr -> CoreExpr
push CoreTickish
t (App CoreExpr
f (Type Type
u)) = forall b. Expr b -> Expr b -> Expr b
App (CoreTickish -> CoreExpr -> CoreExpr
push CoreTickish
t CoreExpr
f) (forall b. Type -> Expr b
Type Type
u)
push CoreTickish
t (App CoreExpr
f CoreExpr
arg) = forall b. Expr b -> Expr b -> Expr b
App (CoreTickish -> CoreExpr -> CoreExpr
push CoreTickish
t CoreExpr
f) (CoreTickish -> CoreExpr -> CoreExpr
mkTick CoreTickish
t CoreExpr
arg)
push CoreTickish
_t CoreExpr
e = CoreExpr
e
stripTicksTop :: (CoreTickish -> Bool) -> Expr b -> ([CoreTickish], Expr b)
stripTicksTop :: forall b.
(CoreTickish -> Bool) -> Expr b -> ([CoreTickish], Expr b)
stripTicksTop CoreTickish -> Bool
p = [CoreTickish] -> Expr b -> ([CoreTickish], Expr b)
go []
where go :: [CoreTickish] -> Expr b -> ([CoreTickish], Expr b)
go [CoreTickish]
ts (Tick CoreTickish
t Expr b
e) | CoreTickish -> Bool
p CoreTickish
t = [CoreTickish] -> Expr b -> ([CoreTickish], Expr b)
go (CoreTickish
tforall a. a -> [a] -> [a]
:[CoreTickish]
ts) Expr b
e
go [CoreTickish]
ts Expr b
other = (forall a. [a] -> [a]
reverse [CoreTickish]
ts, Expr b
other)
stripTicksTopE :: (CoreTickish -> Bool) -> Expr b -> Expr b
stripTicksTopE :: forall b. (CoreTickish -> Bool) -> Expr b -> Expr b
stripTicksTopE CoreTickish -> Bool
p = Expr b -> Expr b
go
where go :: Expr b -> Expr b
go (Tick CoreTickish
t Expr b
e) | CoreTickish -> Bool
p CoreTickish
t = Expr b -> Expr b
go Expr b
e
go Expr b
other = Expr b
other
stripTicksTopT :: (CoreTickish -> Bool) -> Expr b -> [CoreTickish]
stripTicksTopT :: forall b. (CoreTickish -> Bool) -> Expr b -> [CoreTickish]
stripTicksTopT CoreTickish -> Bool
p = [CoreTickish] -> Expr b -> [CoreTickish]
go []
where go :: [CoreTickish] -> Expr b -> [CoreTickish]
go [CoreTickish]
ts (Tick CoreTickish
t Expr b
e) | CoreTickish -> Bool
p CoreTickish
t = [CoreTickish] -> Expr b -> [CoreTickish]
go (CoreTickish
tforall a. a -> [a] -> [a]
:[CoreTickish]
ts) Expr b
e
go [CoreTickish]
ts Expr b
_ = [CoreTickish]
ts
stripTicksE :: (CoreTickish -> Bool) -> Expr b -> Expr b
stripTicksE :: forall b. (CoreTickish -> Bool) -> Expr b -> Expr b
stripTicksE CoreTickish -> Bool
p Expr b
expr = Expr b -> Expr b
go Expr b
expr
where go :: Expr b -> Expr b
go (App Expr b
e Expr b
a) = forall b. Expr b -> Expr b -> Expr b
App (Expr b -> Expr b
go Expr b
e) (Expr b -> Expr b
go Expr b
a)
go (Lam b
b Expr b
e) = forall b. b -> Expr b -> Expr b
Lam b
b (Expr b -> Expr b
go Expr b
e)
go (Let Bind b
b Expr b
e) = forall b. Bind b -> Expr b -> Expr b
Let (Bind b -> Bind b
go_bs Bind b
b) (Expr b -> Expr b
go Expr b
e)
go (Case Expr b
e b
b Type
t [Alt b]
as) = forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (Expr b -> Expr b
go Expr b
e) b
b Type
t (forall a b. (a -> b) -> [a] -> [b]
map Alt b -> Alt b
go_a [Alt b]
as)
go (Cast Expr b
e CoercionR
c) = forall b. Expr b -> CoercionR -> Expr b
Cast (Expr b -> Expr b
go Expr b
e) CoercionR
c
go (Tick CoreTickish
t Expr b
e)
| CoreTickish -> Bool
p CoreTickish
t = Expr b -> Expr b
go Expr b
e
| Bool
otherwise = forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t (Expr b -> Expr b
go Expr b
e)
go Expr b
other = Expr b
other
go_bs :: Bind b -> Bind b
go_bs (NonRec b
b Expr b
e) = forall b. b -> Expr b -> Bind b
NonRec b
b (Expr b -> Expr b
go Expr b
e)
go_bs (Rec [(b, Expr b)]
bs) = forall b. [(b, Expr b)] -> Bind b
Rec (forall a b. (a -> b) -> [a] -> [b]
map (b, Expr b) -> (b, Expr b)
go_b [(b, Expr b)]
bs)
go_b :: (b, Expr b) -> (b, Expr b)
go_b (b
b, Expr b
e) = (b
b, Expr b -> Expr b
go Expr b
e)
go_a :: Alt b -> Alt b
go_a (Alt AltCon
c [b]
bs Expr b
e) = forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
c [b]
bs (Expr b -> Expr b
go Expr b
e)
stripTicksT :: (CoreTickish -> Bool) -> Expr b -> [CoreTickish]
stripTicksT :: forall b. (CoreTickish -> Bool) -> Expr b -> [CoreTickish]
stripTicksT CoreTickish -> Bool
p Expr b
expr = forall a. OrdList a -> [a]
fromOL forall a b. (a -> b) -> a -> b
$ Expr b -> OrdList CoreTickish
go Expr b
expr
where go :: Expr b -> OrdList CoreTickish
go (App Expr b
e Expr b
a) = Expr b -> OrdList CoreTickish
go Expr b
e forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Expr b -> OrdList CoreTickish
go Expr b
a
go (Lam b
_ Expr b
e) = Expr b -> OrdList CoreTickish
go Expr b
e
go (Let Bind b
b Expr b
e) = Bind b -> OrdList CoreTickish
go_bs Bind b
b forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Expr b -> OrdList CoreTickish
go Expr b
e
go (Case Expr b
e b
_ Type
_ [Alt b]
as) = Expr b -> OrdList CoreTickish
go Expr b
e forall a. OrdList a -> OrdList a -> OrdList a
`appOL` forall a. [OrdList a] -> OrdList a
concatOL (forall a b. (a -> b) -> [a] -> [b]
map Alt b -> OrdList CoreTickish
go_a [Alt b]
as)
go (Cast Expr b
e CoercionR
_) = Expr b -> OrdList CoreTickish
go Expr b
e
go (Tick CoreTickish
t Expr b
e)
| CoreTickish -> Bool
p CoreTickish
t = CoreTickish
t forall a. a -> OrdList a -> OrdList a
`consOL` Expr b -> OrdList CoreTickish
go Expr b
e
| Bool
otherwise = Expr b -> OrdList CoreTickish
go Expr b
e
go Expr b
_ = forall a. OrdList a
nilOL
go_bs :: Bind b -> OrdList CoreTickish
go_bs (NonRec b
_ Expr b
e) = Expr b -> OrdList CoreTickish
go Expr b
e
go_bs (Rec [(b, Expr b)]
bs) = forall a. [OrdList a] -> OrdList a
concatOL (forall a b. (a -> b) -> [a] -> [b]
map (b, Expr b) -> OrdList CoreTickish
go_b [(b, Expr b)]
bs)
go_b :: (b, Expr b) -> OrdList CoreTickish
go_b (b
_, Expr b
e) = Expr b -> OrdList CoreTickish
go Expr b
e
go_a :: Alt b -> OrdList CoreTickish
go_a (Alt AltCon
_ [b]
_ Expr b
e) = Expr b -> OrdList CoreTickish
go Expr b
e
bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec :: Var -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec Var
bndr CoreExpr
rhs CoreExpr
body
| Var -> Bool
isTyVar Var
bndr = CoreExpr
let_bind
| Var -> Bool
isCoVar Var
bndr = if forall b. Expr b -> Bool
isCoArg CoreExpr
rhs then CoreExpr
let_bind
else CoreExpr
case_bind
| Var -> Bool
isJoinId Var
bndr = CoreExpr
let_bind
| Type -> CoreExpr -> Bool
needsCaseBinding (Var -> Type
idType Var
bndr) CoreExpr
rhs = CoreExpr
case_bind
| Bool
otherwise = CoreExpr
let_bind
where
case_bind :: CoreExpr
case_bind = CoreExpr -> Var -> CoreExpr -> CoreExpr
mkDefaultCase CoreExpr
rhs Var
bndr CoreExpr
body
let_bind :: CoreExpr
let_bind = forall b. Bind b -> Expr b -> Expr b
Let (forall b. b -> Expr b -> Bind b
NonRec Var
bndr CoreExpr
rhs) CoreExpr
body
needsCaseBinding :: Type -> CoreExpr -> Bool
needsCaseBinding :: Type -> CoreExpr -> Bool
needsCaseBinding Type
ty CoreExpr
rhs = HasDebugCallStack => Type -> Bool
isUnliftedType Type
ty Bool -> Bool -> Bool
&& Bool -> Bool
not (CoreExpr -> Bool
exprOkForSpeculation CoreExpr
rhs)
mkAltExpr :: AltCon
-> [CoreBndr]
-> [Type]
-> CoreExpr
mkAltExpr :: AltCon -> [Var] -> [Type] -> CoreExpr
mkAltExpr (DataAlt DataCon
con) [Var]
args [Type]
inst_tys
= forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
con (forall a b. (a -> b) -> [a] -> [b]
map forall b. Type -> Expr b
Type [Type]
inst_tys forall a. [a] -> [a] -> [a]
++ forall b. [Var] -> [Expr b]
varsToCoreExprs [Var]
args)
mkAltExpr (LitAlt Literal
lit) [] []
= forall b. Literal -> Expr b
Lit Literal
lit
mkAltExpr (LitAlt Literal
_) [Var]
_ [Type]
_ = forall a. String -> a
panic String
"mkAltExpr LitAlt"
mkAltExpr AltCon
DEFAULT [Var]
_ [Type]
_ = forall a. String -> a
panic String
"mkAltExpr DEFAULT"
mkDefaultCase :: CoreExpr -> Id -> CoreExpr -> CoreExpr
mkDefaultCase :: CoreExpr -> Var -> CoreExpr -> CoreExpr
mkDefaultCase CoreExpr
scrut Var
case_bndr CoreExpr
body
= forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
scrut Var
case_bndr (CoreExpr -> Type
exprType CoreExpr
body) [forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] CoreExpr
body]
mkSingleAltCase :: CoreExpr -> Id -> AltCon -> [Var] -> CoreExpr -> CoreExpr
mkSingleAltCase :: CoreExpr -> Var -> AltCon -> [Var] -> CoreExpr -> CoreExpr
mkSingleAltCase CoreExpr
scrut Var
case_bndr AltCon
con [Var]
bndrs CoreExpr
body
= forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
scrut Var
case_bndr Type
case_ty [forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [Var]
bndrs CoreExpr
body]
where
body_ty :: Type
body_ty = CoreExpr -> Type
exprType CoreExpr
body
case_ty :: Type
case_ty
| Just Type
body_ty' <- [Var] -> Type -> Maybe Type
occCheckExpand [Var]
bndrs Type
body_ty
= Type
body_ty'
| Bool
otherwise
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkSingleAltCase" (forall a. Outputable a => a -> SDoc
ppr CoreExpr
scrut SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr [Var]
bndrs SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr Type
body_ty)
findDefault :: [Alt b] -> ([Alt b], Maybe (Expr b))
findDefault :: forall b. [Alt b] -> ([Alt b], Maybe (Expr b))
findDefault (Alt AltCon
DEFAULT [b]
args Expr b
rhs : [Alt b]
alts) = ASSERT( null args ) (alts, Just rhs)
findDefault [Alt b]
alts = ([Alt b]
alts, forall a. Maybe a
Nothing)
addDefault :: [Alt b] -> Maybe (Expr b) -> [Alt b]
addDefault :: forall b. [Alt b] -> Maybe (Expr b) -> [Alt b]
addDefault [Alt b]
alts Maybe (Expr b)
Nothing = [Alt b]
alts
addDefault [Alt b]
alts (Just Expr b
rhs) = forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] Expr b
rhs forall a. a -> [a] -> [a]
: [Alt b]
alts
isDefaultAlt :: Alt b -> Bool
isDefaultAlt :: forall b. Alt b -> Bool
isDefaultAlt (Alt AltCon
DEFAULT [b]
_ Expr b
_) = Bool
True
isDefaultAlt Alt b
_ = Bool
False
findAlt :: AltCon -> [Alt b] -> Maybe (Alt b)
findAlt :: forall b. AltCon -> [Alt b] -> Maybe (Alt b)
findAlt AltCon
con [Alt b]
alts
= case [Alt b]
alts of
(deflt :: Alt b
deflt@(Alt AltCon
DEFAULT [b]
_ Expr b
_):[Alt b]
alts) -> [Alt b] -> Maybe (Alt b) -> Maybe (Alt b)
go [Alt b]
alts (forall a. a -> Maybe a
Just Alt b
deflt)
[Alt b]
_ -> [Alt b] -> Maybe (Alt b) -> Maybe (Alt b)
go [Alt b]
alts forall a. Maybe a
Nothing
where
go :: [Alt b] -> Maybe (Alt b) -> Maybe (Alt b)
go [] Maybe (Alt b)
deflt = Maybe (Alt b)
deflt
go (alt :: Alt b
alt@(Alt AltCon
con1 [b]
_ Expr b
_) : [Alt b]
alts) Maybe (Alt b)
deflt
= case AltCon
con AltCon -> AltCon -> Ordering
`cmpAltCon` AltCon
con1 of
Ordering
LT -> Maybe (Alt b)
deflt
Ordering
EQ -> forall a. a -> Maybe a
Just Alt b
alt
Ordering
GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt
mergeAlts :: [Alt a] -> [Alt a] -> [Alt a]
mergeAlts :: forall a. [Alt a] -> [Alt a] -> [Alt a]
mergeAlts [] [Alt a]
as2 = [Alt a]
as2
mergeAlts [Alt a]
as1 [] = [Alt a]
as1
mergeAlts (Alt a
a1:[Alt a]
as1) (Alt a
a2:[Alt a]
as2)
= case Alt a
a1 forall a. Alt a -> Alt a -> Ordering
`cmpAlt` Alt a
a2 of
Ordering
LT -> Alt a
a1 forall a. a -> [a] -> [a]
: forall a. [Alt a] -> [Alt a] -> [Alt a]
mergeAlts [Alt a]
as1 (Alt a
a2forall a. a -> [a] -> [a]
:[Alt a]
as2)
Ordering
EQ -> Alt a
a1 forall a. a -> [a] -> [a]
: forall a. [Alt a] -> [Alt a] -> [Alt a]
mergeAlts [Alt a]
as1 [Alt a]
as2
Ordering
GT -> Alt a
a2 forall a. a -> [a] -> [a]
: forall a. [Alt a] -> [Alt a] -> [Alt a]
mergeAlts (Alt a
a1forall a. a -> [a] -> [a]
:[Alt a]
as1) [Alt a]
as2
trimConArgs :: AltCon -> [CoreArg] -> [CoreArg]
trimConArgs :: AltCon -> [CoreExpr] -> [CoreExpr]
trimConArgs AltCon
DEFAULT [CoreExpr]
args = ASSERT( null args ) []
trimConArgs (LitAlt Literal
_) [CoreExpr]
args = ASSERT( null args ) []
trimConArgs (DataAlt DataCon
dc) [CoreExpr]
args = forall b a. [b] -> [a] -> [a]
dropList (DataCon -> [Var]
dataConUnivTyVars DataCon
dc) [CoreExpr]
args
filterAlts :: TyCon
-> [Type]
-> [AltCon]
-> [Alt b]
-> ([AltCon], [Alt b])
filterAlts :: forall b.
TyCon -> [Type] -> [AltCon] -> [Alt b] -> ([AltCon], [Alt b])
filterAlts TyCon
_tycon [Type]
inst_tys [AltCon]
imposs_cons [Alt b]
alts
= ([AltCon]
imposs_deflt_cons, forall b. [Alt b] -> Maybe (Expr b) -> [Alt b]
addDefault [Alt b]
trimmed_alts Maybe (Expr b)
maybe_deflt)
where
([Alt b]
alts_wo_default, Maybe (Expr b)
maybe_deflt) = forall b. [Alt b] -> ([Alt b], Maybe (Expr b))
findDefault [Alt b]
alts
alt_cons :: [AltCon]
alt_cons = [AltCon
con | Alt AltCon
con [b]
_ Expr b
_ <- [Alt b]
alts_wo_default]
trimmed_alts :: [Alt b]
trimmed_alts = forall a. (a -> Bool) -> [a] -> [a]
filterOut (forall b. [Type] -> Alt b -> Bool
impossible_alt [Type]
inst_tys) [Alt b]
alts_wo_default
imposs_cons_set :: Set AltCon
imposs_cons_set = forall a. Ord a => [a] -> Set a
Set.fromList [AltCon]
imposs_cons
imposs_deflt_cons :: [AltCon]
imposs_deflt_cons =
[AltCon]
imposs_cons forall a. [a] -> [a] -> [a]
++ forall a. (a -> Bool) -> [a] -> [a]
filterOut (forall a. Ord a => a -> Set a -> Bool
`Set.member` Set AltCon
imposs_cons_set) [AltCon]
alt_cons
impossible_alt :: [Type] -> Alt b -> Bool
impossible_alt :: forall b. [Type] -> Alt b -> Bool
impossible_alt [Type]
_ (Alt AltCon
con [b]
_ Expr b
_) | AltCon
con forall a. Ord a => a -> Set a -> Bool
`Set.member` Set AltCon
imposs_cons_set = Bool
True
impossible_alt [Type]
inst_tys (Alt (DataAlt DataCon
con) [b]
_ Expr b
_) = [Type] -> DataCon -> Bool
dataConCannotMatch [Type]
inst_tys DataCon
con
impossible_alt [Type]
_ Alt b
_ = Bool
False
refineDefaultAlt :: [Unique]
-> Mult
-> TyCon
-> [Type]
-> [AltCon]
-> [CoreAlt]
-> (Bool, [CoreAlt])
refineDefaultAlt :: [Unique]
-> Type
-> TyCon
-> [Type]
-> [AltCon]
-> [Alt Var]
-> (Bool, [Alt Var])
refineDefaultAlt [Unique]
us Type
mult TyCon
tycon [Type]
tys [AltCon]
imposs_deflt_cons [Alt Var]
all_alts
| Alt AltCon
DEFAULT [Var]
_ CoreExpr
rhs : [Alt Var]
rest_alts <- [Alt Var]
all_alts
, TyCon -> Bool
isAlgTyCon TyCon
tycon
, Bool -> Bool
not (TyCon -> Bool
isNewTyCon TyCon
tycon)
, Just [DataCon]
all_cons <- TyCon -> Maybe [DataCon]
tyConDataCons_maybe TyCon
tycon
, let imposs_data_cons :: UniqSet DataCon
imposs_data_cons = forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet [DataCon
con | DataAlt DataCon
con <- [AltCon]
imposs_deflt_cons]
impossible :: DataCon -> Bool
impossible DataCon
con = DataCon
con forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet DataCon
imposs_data_cons
Bool -> Bool -> Bool
|| [Type] -> DataCon -> Bool
dataConCannotMatch [Type]
tys DataCon
con
= case forall a. (a -> Bool) -> [a] -> [a]
filterOut DataCon -> Bool
impossible [DataCon]
all_cons of
[] -> (Bool
False, [Alt Var]
rest_alts)
[DataCon
con] -> (Bool
True, forall a. [Alt a] -> [Alt a] -> [Alt a]
mergeAlts [Alt Var]
rest_alts [forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
con) ([Var]
ex_tvs forall a. [a] -> [a] -> [a]
++ [Var]
arg_ids) CoreExpr
rhs])
where
([Var]
ex_tvs, [Var]
arg_ids) = [Unique] -> Type -> DataCon -> [Type] -> ([Var], [Var])
dataConRepInstPat [Unique]
us Type
mult DataCon
con [Type]
tys
[DataCon]
_ -> (Bool
False, [Alt Var]
all_alts)
| Bool
debugIsOn, TyCon -> Bool
isAlgTyCon TyCon
tycon, forall (t :: * -> *) a. Foldable t => t a -> Bool
null (TyCon -> [DataCon]
tyConDataCons TyCon
tycon)
, Bool -> Bool
not (TyCon -> Bool
isFamilyTyCon TyCon
tycon Bool -> Bool -> Bool
|| TyCon -> Bool
isAbstractTyCon TyCon
tycon)
= (Bool
False, [Alt Var]
all_alts)
| Bool
otherwise
= (Bool
False, [Alt Var]
all_alts)
combineIdenticalAlts :: [AltCon]
-> [CoreAlt]
-> (Bool,
[AltCon],
[CoreAlt])
combineIdenticalAlts :: [AltCon] -> [Alt Var] -> (Bool, [AltCon], [Alt Var])
combineIdenticalAlts [AltCon]
imposs_deflt_cons (Alt AltCon
con1 [Var]
bndrs1 CoreExpr
rhs1 : [Alt Var]
rest_alts)
| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Var -> Bool
isDeadBinder [Var]
bndrs1
, Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Alt Var]
elim_rest)
= (Bool
True, [AltCon]
imposs_deflt_cons', Alt Var
deflt_alt forall a. a -> [a] -> [a]
: [Alt Var]
filtered_rest)
where
([Alt Var]
elim_rest, [Alt Var]
filtered_rest) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Alt Var -> Bool
identical_to_alt1 [Alt Var]
rest_alts
deflt_alt :: Alt Var
deflt_alt = forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] ([CoreTickish] -> CoreExpr -> CoreExpr
mkTicks (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[CoreTickish]]
tickss) CoreExpr
rhs1)
imposs_deflt_cons' :: [AltCon]
imposs_deflt_cons' = [AltCon]
imposs_deflt_cons forall a. Ord a => [a] -> [a] -> [a]
`minusList` [AltCon]
elim_cons
elim_cons :: [AltCon]
elim_cons = [AltCon]
elim_con1 forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (\(Alt AltCon
con [Var]
_ CoreExpr
_) -> AltCon
con) [Alt Var]
elim_rest
elim_con1 :: [AltCon]
elim_con1 = case AltCon
con1 of
AltCon
DEFAULT -> []
AltCon
_ -> [AltCon
con1]
cheapEqTicked :: Expr b -> Expr b -> Bool
cheapEqTicked Expr b
e1 Expr b
e2 = forall b. (CoreTickish -> Bool) -> Expr b -> Expr b -> Bool
cheapEqExpr' forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable Expr b
e1 Expr b
e2
identical_to_alt1 :: Alt Var -> Bool
identical_to_alt1 (Alt AltCon
_con [Var]
bndrs CoreExpr
rhs)
= forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Var -> Bool
isDeadBinder [Var]
bndrs Bool -> Bool -> Bool
&& CoreExpr
rhs forall {b}. Expr b -> Expr b -> Bool
`cheapEqTicked` CoreExpr
rhs1
tickss :: [[CoreTickish]]
tickss = forall a b. (a -> b) -> [a] -> [b]
map (\(Alt AltCon
_ [Var]
_ CoreExpr
rhs) -> forall b. (CoreTickish -> Bool) -> Expr b -> [CoreTickish]
stripTicksT forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable CoreExpr
rhs) [Alt Var]
elim_rest
combineIdenticalAlts [AltCon]
imposs_cons [Alt Var]
alts
= (Bool
False, [AltCon]
imposs_cons, [Alt Var]
alts)
scaleAltsBy :: Mult -> [CoreAlt] -> [CoreAlt]
scaleAltsBy :: Type -> [Alt Var] -> [Alt Var]
scaleAltsBy Type
w [Alt Var]
alts = forall a b. (a -> b) -> [a] -> [b]
map Alt Var -> Alt Var
scaleAlt [Alt Var]
alts
where
scaleAlt :: CoreAlt -> CoreAlt
scaleAlt :: Alt Var -> Alt Var
scaleAlt (Alt AltCon
con [Var]
bndrs CoreExpr
rhs) = forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con (forall a b. (a -> b) -> [a] -> [b]
map Var -> Var
scaleBndr [Var]
bndrs) CoreExpr
rhs
scaleBndr :: CoreBndr -> CoreBndr
scaleBndr :: Var -> Var
scaleBndr Var
b = Type -> Var -> Var
scaleVarBy Type
w Var
b
exprIsTrivial :: CoreExpr -> Bool
exprIsTrivial :: CoreExpr -> Bool
exprIsTrivial (Var Var
_) = Bool
True
exprIsTrivial (Type Type
_) = Bool
True
exprIsTrivial (Coercion CoercionR
_) = Bool
True
exprIsTrivial (Lit Literal
lit) = Literal -> Bool
litIsTrivial Literal
lit
exprIsTrivial (App CoreExpr
e CoreExpr
arg) = Bool -> Bool
not (CoreExpr -> Bool
isRuntimeArg CoreExpr
arg) Bool -> Bool -> Bool
&& CoreExpr -> Bool
exprIsTrivial CoreExpr
e
exprIsTrivial (Lam Var
b CoreExpr
e) = Bool -> Bool
not (Var -> Bool
isRuntimeVar Var
b) Bool -> Bool -> Bool
&& CoreExpr -> Bool
exprIsTrivial CoreExpr
e
exprIsTrivial (Tick CoreTickish
t CoreExpr
e) = Bool -> Bool
not (forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode CoreTickish
t) Bool -> Bool -> Bool
&& CoreExpr -> Bool
exprIsTrivial CoreExpr
e
exprIsTrivial (Cast CoreExpr
e CoercionR
_) = CoreExpr -> Bool
exprIsTrivial CoreExpr
e
exprIsTrivial (Case CoreExpr
e Var
_ Type
_ []) = CoreExpr -> Bool
exprIsTrivial CoreExpr
e
exprIsTrivial CoreExpr
_ = Bool
False
getIdFromTrivialExpr :: HasDebugCallStack => CoreExpr -> Id
getIdFromTrivialExpr :: HasDebugCallStack => CoreExpr -> Var
getIdFromTrivialExpr CoreExpr
e
= forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getIdFromTrivialExpr" (forall a. Outputable a => a -> SDoc
ppr CoreExpr
e))
(CoreExpr -> Maybe Var
getIdFromTrivialExpr_maybe CoreExpr
e)
getIdFromTrivialExpr_maybe :: CoreExpr -> Maybe Id
getIdFromTrivialExpr_maybe :: CoreExpr -> Maybe Var
getIdFromTrivialExpr_maybe CoreExpr
e
= CoreExpr -> Maybe Var
go CoreExpr
e
where
go :: CoreExpr -> Maybe Var
go (App CoreExpr
f CoreExpr
t) | Bool -> Bool
not (CoreExpr -> Bool
isRuntimeArg CoreExpr
t) = CoreExpr -> Maybe Var
go CoreExpr
f
go (Tick CoreTickish
t CoreExpr
e) | Bool -> Bool
not (forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode CoreTickish
t) = CoreExpr -> Maybe Var
go CoreExpr
e
go (Cast CoreExpr
e CoercionR
_) = CoreExpr -> Maybe Var
go CoreExpr
e
go (Lam Var
b CoreExpr
e) | Bool -> Bool
not (Var -> Bool
isRuntimeVar Var
b) = CoreExpr -> Maybe Var
go CoreExpr
e
go (Case CoreExpr
e Var
_ Type
_ []) = CoreExpr -> Maybe Var
go CoreExpr
e
go (Var Var
v) = forall a. a -> Maybe a
Just Var
v
go CoreExpr
_ = forall a. Maybe a
Nothing
exprIsDeadEnd :: CoreExpr -> Bool
exprIsDeadEnd :: CoreExpr -> Bool
exprIsDeadEnd CoreExpr
e
| Type -> Bool
isEmptyTy (CoreExpr -> Type
exprType CoreExpr
e)
= Bool
True
| Bool
otherwise
= FullArgCount -> CoreExpr -> Bool
go FullArgCount
0 CoreExpr
e
where
go :: FullArgCount -> CoreExpr -> Bool
go FullArgCount
n (Var Var
v) = StrictSig -> FullArgCount -> Bool
isDeadEndAppSig (Var -> StrictSig
idStrictness Var
v) FullArgCount
n
go FullArgCount
n (App CoreExpr
e CoreExpr
a) | forall b. Expr b -> Bool
isTypeArg CoreExpr
a = FullArgCount -> CoreExpr -> Bool
go FullArgCount
n CoreExpr
e
| Bool
otherwise = FullArgCount -> CoreExpr -> Bool
go (FullArgCount
nforall a. Num a => a -> a -> a
+FullArgCount
1) CoreExpr
e
go FullArgCount
n (Tick CoreTickish
_ CoreExpr
e) = FullArgCount -> CoreExpr -> Bool
go FullArgCount
n CoreExpr
e
go FullArgCount
n (Cast CoreExpr
e CoercionR
_) = FullArgCount -> CoreExpr -> Bool
go FullArgCount
n CoreExpr
e
go FullArgCount
n (Let Bind Var
_ CoreExpr
e) = FullArgCount -> CoreExpr -> Bool
go FullArgCount
n CoreExpr
e
go FullArgCount
n (Lam Var
v CoreExpr
e) | Var -> Bool
isTyVar Var
v = FullArgCount -> CoreExpr -> Bool
go FullArgCount
n CoreExpr
e
go FullArgCount
_ (Case CoreExpr
_ Var
_ Type
_ [Alt Var]
alts) = forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Alt Var]
alts
go FullArgCount
_ CoreExpr
_ = Bool
False
exprIsDupable :: Platform -> CoreExpr -> Bool
exprIsDupable :: Platform -> CoreExpr -> Bool
exprIsDupable Platform
platform CoreExpr
e
= forall a. Maybe a -> Bool
isJust (FullArgCount -> CoreExpr -> Maybe FullArgCount
go FullArgCount
dupAppSize CoreExpr
e)
where
go :: Int -> CoreExpr -> Maybe Int
go :: FullArgCount -> CoreExpr -> Maybe FullArgCount
go FullArgCount
n (Type {}) = forall a. a -> Maybe a
Just FullArgCount
n
go FullArgCount
n (Coercion {}) = forall a. a -> Maybe a
Just FullArgCount
n
go FullArgCount
n (Var {}) = FullArgCount -> Maybe FullArgCount
decrement FullArgCount
n
go FullArgCount
n (Tick CoreTickish
_ CoreExpr
e) = FullArgCount -> CoreExpr -> Maybe FullArgCount
go FullArgCount
n CoreExpr
e
go FullArgCount
n (Cast CoreExpr
e CoercionR
_) = FullArgCount -> CoreExpr -> Maybe FullArgCount
go FullArgCount
n CoreExpr
e
go FullArgCount
n (App CoreExpr
f CoreExpr
a) | Just FullArgCount
n' <- FullArgCount -> CoreExpr -> Maybe FullArgCount
go FullArgCount
n CoreExpr
a = FullArgCount -> CoreExpr -> Maybe FullArgCount
go FullArgCount
n' CoreExpr
f
go FullArgCount
n (Lit Literal
lit) | Platform -> Literal -> Bool
litIsDupable Platform
platform Literal
lit = FullArgCount -> Maybe FullArgCount
decrement FullArgCount
n
go FullArgCount
_ CoreExpr
_ = forall a. Maybe a
Nothing
decrement :: Int -> Maybe Int
decrement :: FullArgCount -> Maybe FullArgCount
decrement FullArgCount
0 = forall a. Maybe a
Nothing
decrement FullArgCount
n = forall a. a -> Maybe a
Just (FullArgCount
nforall a. Num a => a -> a -> a
-FullArgCount
1)
dupAppSize :: Int
dupAppSize :: FullArgCount
dupAppSize = FullArgCount
8
exprIsWorkFree :: CoreExpr -> Bool
exprIsWorkFree :: CoreExpr -> Bool
exprIsWorkFree = CheapAppFun -> CoreExpr -> Bool
exprIsCheapX CheapAppFun
isWorkFreeApp
exprIsCheap :: CoreExpr -> Bool
exprIsCheap :: CoreExpr -> Bool
exprIsCheap = CheapAppFun -> CoreExpr -> Bool
exprIsCheapX CheapAppFun
isCheapApp
exprIsCheapX :: CheapAppFun -> CoreExpr -> Bool
exprIsCheapX :: CheapAppFun -> CoreExpr -> Bool
exprIsCheapX CheapAppFun
ok_app CoreExpr
e
= CoreExpr -> Bool
ok CoreExpr
e
where
ok :: CoreExpr -> Bool
ok CoreExpr
e = FullArgCount -> CoreExpr -> Bool
go FullArgCount
0 CoreExpr
e
go :: FullArgCount -> CoreExpr -> Bool
go FullArgCount
n (Var Var
v) = CheapAppFun
ok_app Var
v FullArgCount
n
go FullArgCount
_ (Lit {}) = Bool
True
go FullArgCount
_ (Type {}) = Bool
True
go FullArgCount
_ (Coercion {}) = Bool
True
go FullArgCount
n (Cast CoreExpr
e CoercionR
_) = FullArgCount -> CoreExpr -> Bool
go FullArgCount
n CoreExpr
e
go FullArgCount
n (Case CoreExpr
scrut Var
_ Type
_ [Alt Var]
alts) = CoreExpr -> Bool
ok CoreExpr
scrut Bool -> Bool -> Bool
&&
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ FullArgCount -> CoreExpr -> Bool
go FullArgCount
n CoreExpr
rhs | Alt AltCon
_ [Var]
_ CoreExpr
rhs <- [Alt Var]
alts ]
go FullArgCount
n (Tick CoreTickish
t CoreExpr
e) | forall (pass :: TickishPass). GenTickish pass -> Bool
tickishCounts CoreTickish
t = Bool
False
| Bool
otherwise = FullArgCount -> CoreExpr -> Bool
go FullArgCount
n CoreExpr
e
go FullArgCount
n (Lam Var
x CoreExpr
e) | Var -> Bool
isRuntimeVar Var
x = FullArgCount
nforall a. Eq a => a -> a -> Bool
==FullArgCount
0 Bool -> Bool -> Bool
|| FullArgCount -> CoreExpr -> Bool
go (FullArgCount
nforall a. Num a => a -> a -> a
-FullArgCount
1) CoreExpr
e
| Bool
otherwise = FullArgCount -> CoreExpr -> Bool
go FullArgCount
n CoreExpr
e
go FullArgCount
n (App CoreExpr
f CoreExpr
e) | CoreExpr -> Bool
isRuntimeArg CoreExpr
e = FullArgCount -> CoreExpr -> Bool
go (FullArgCount
nforall a. Num a => a -> a -> a
+FullArgCount
1) CoreExpr
f Bool -> Bool -> Bool
&& CoreExpr -> Bool
ok CoreExpr
e
| Bool
otherwise = FullArgCount -> CoreExpr -> Bool
go FullArgCount
n CoreExpr
f
go FullArgCount
n (Let (NonRec Var
_ CoreExpr
r) CoreExpr
e) = FullArgCount -> CoreExpr -> Bool
go FullArgCount
n CoreExpr
e Bool -> Bool -> Bool
&& CoreExpr -> Bool
ok CoreExpr
r
go FullArgCount
n (Let (Rec [(Var, CoreExpr)]
prs) CoreExpr
e) = FullArgCount -> CoreExpr -> Bool
go FullArgCount
n CoreExpr
e Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (CoreExpr -> Bool
ok forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Var, CoreExpr)]
prs
exprIsExpandable :: CoreExpr -> Bool
exprIsExpandable :: CoreExpr -> Bool
exprIsExpandable CoreExpr
e
= CoreExpr -> Bool
ok CoreExpr
e
where
ok :: CoreExpr -> Bool
ok CoreExpr
e = FullArgCount -> CoreExpr -> Bool
go FullArgCount
0 CoreExpr
e
go :: FullArgCount -> CoreExpr -> Bool
go FullArgCount
n (Var Var
v) = CheapAppFun
isExpandableApp Var
v FullArgCount
n
go FullArgCount
_ (Lit {}) = Bool
True
go FullArgCount
_ (Type {}) = Bool
True
go FullArgCount
_ (Coercion {}) = Bool
True
go FullArgCount
n (Cast CoreExpr
e CoercionR
_) = FullArgCount -> CoreExpr -> Bool
go FullArgCount
n CoreExpr
e
go FullArgCount
n (Tick CoreTickish
t CoreExpr
e) | forall (pass :: TickishPass). GenTickish pass -> Bool
tickishCounts CoreTickish
t = Bool
False
| Bool
otherwise = FullArgCount -> CoreExpr -> Bool
go FullArgCount
n CoreExpr
e
go FullArgCount
n (Lam Var
x CoreExpr
e) | Var -> Bool
isRuntimeVar Var
x = FullArgCount
nforall a. Eq a => a -> a -> Bool
==FullArgCount
0 Bool -> Bool -> Bool
|| FullArgCount -> CoreExpr -> Bool
go (FullArgCount
nforall a. Num a => a -> a -> a
-FullArgCount
1) CoreExpr
e
| Bool
otherwise = FullArgCount -> CoreExpr -> Bool
go FullArgCount
n CoreExpr
e
go FullArgCount
n (App CoreExpr
f CoreExpr
e) | CoreExpr -> Bool
isRuntimeArg CoreExpr
e = FullArgCount -> CoreExpr -> Bool
go (FullArgCount
nforall a. Num a => a -> a -> a
+FullArgCount
1) CoreExpr
f Bool -> Bool -> Bool
&& CoreExpr -> Bool
ok CoreExpr
e
| Bool
otherwise = FullArgCount -> CoreExpr -> Bool
go FullArgCount
n CoreExpr
f
go FullArgCount
_ (Case {}) = Bool
False
go FullArgCount
_ (Let {}) = Bool
False
type CheapAppFun = Id -> Arity -> Bool
isWorkFreeApp :: CheapAppFun
isWorkFreeApp :: CheapAppFun
isWorkFreeApp Var
fn FullArgCount
n_val_args
| FullArgCount
n_val_args forall a. Eq a => a -> a -> Bool
== FullArgCount
0
= Bool
True
| FullArgCount
n_val_args forall a. Ord a => a -> a -> Bool
< Var -> FullArgCount
idArity Var
fn
= Bool
True
| Bool
otherwise
= case Var -> IdDetails
idDetails Var
fn of
DataConWorkId {} -> Bool
True
IdDetails
_ -> Bool
False
isCheapApp :: CheapAppFun
isCheapApp :: CheapAppFun
isCheapApp Var
fn FullArgCount
n_val_args
| CheapAppFun
isWorkFreeApp Var
fn FullArgCount
n_val_args = Bool
True
| Var -> Bool
isDeadEndId Var
fn = Bool
True
| Bool
otherwise
= case Var -> IdDetails
idDetails Var
fn of
DataConWorkId {} -> Bool
True
RecSelId {} -> FullArgCount
n_val_args forall a. Eq a => a -> a -> Bool
== FullArgCount
1
ClassOpId {} -> FullArgCount
n_val_args forall a. Eq a => a -> a -> Bool
== FullArgCount
1
PrimOpId PrimOp
op -> PrimOp -> Bool
primOpIsCheap PrimOp
op
IdDetails
_ -> Bool
False
isExpandableApp :: CheapAppFun
isExpandableApp :: CheapAppFun
isExpandableApp Var
fn FullArgCount
n_val_args
| CheapAppFun
isWorkFreeApp Var
fn FullArgCount
n_val_args = Bool
True
| Bool
otherwise
= case Var -> IdDetails
idDetails Var
fn of
RecSelId {} -> FullArgCount
n_val_args forall a. Eq a => a -> a -> Bool
== FullArgCount
1
ClassOpId {} -> FullArgCount
n_val_args forall a. Eq a => a -> a -> Bool
== FullArgCount
1
PrimOpId {} -> Bool
False
IdDetails
_ | Var -> Bool
isDeadEndId Var
fn -> Bool
False
| Var -> Bool
isConLikeId Var
fn -> Bool
True
| Bool
all_args_are_preds -> Bool
True
| Bool
otherwise -> Bool
False
where
all_args_are_preds :: Bool
all_args_are_preds = forall {t}. (Eq t, Num t) => t -> Type -> Bool
all_pred_args FullArgCount
n_val_args (Var -> Type
idType Var
fn)
all_pred_args :: t -> Type -> Bool
all_pred_args t
n_val_args Type
ty
| t
n_val_args forall a. Eq a => a -> a -> Bool
== t
0
= Bool
True
| Just (TyCoBinder
bndr, Type
ty) <- Type -> Maybe (TyCoBinder, Type)
splitPiTy_maybe Type
ty
= case TyCoBinder
bndr of
Named {} -> t -> Type -> Bool
all_pred_args t
n_val_args Type
ty
Anon AnonArgFlag
InvisArg Scaled Type
_ -> t -> Type -> Bool
all_pred_args (t
n_val_argsforall a. Num a => a -> a -> a
-t
1) Type
ty
Anon AnonArgFlag
VisArg Scaled Type
_ -> Bool
False
| Bool
otherwise
= Bool
False
exprOkForSpeculation, exprOkForSideEffects :: CoreExpr -> Bool
exprOkForSpeculation :: CoreExpr -> Bool
exprOkForSpeculation = (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok PrimOp -> Bool
primOpOkForSpeculation
exprOkForSideEffects :: CoreExpr -> Bool
exprOkForSideEffects = (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok PrimOp -> Bool
primOpOkForSideEffects
expr_ok :: (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok :: (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok PrimOp -> Bool
_ (Lit Literal
_) = Bool
True
expr_ok PrimOp -> Bool
_ (Type Type
_) = Bool
True
expr_ok PrimOp -> Bool
_ (Coercion CoercionR
_) = Bool
True
expr_ok PrimOp -> Bool
primop_ok (Var Var
v) = (PrimOp -> Bool) -> Var -> [CoreExpr] -> Bool
app_ok PrimOp -> Bool
primop_ok Var
v []
expr_ok PrimOp -> Bool
primop_ok (Cast CoreExpr
e CoercionR
_) = (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok PrimOp -> Bool
primop_ok CoreExpr
e
expr_ok PrimOp -> Bool
primop_ok (Lam Var
b CoreExpr
e)
| Var -> Bool
isTyVar Var
b = (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok PrimOp -> Bool
primop_ok CoreExpr
e
| Bool
otherwise = Bool
True
expr_ok PrimOp -> Bool
primop_ok (Tick CoreTickish
tickish CoreExpr
e)
| forall (pass :: TickishPass). GenTickish pass -> Bool
tickishCounts CoreTickish
tickish = Bool
False
| Bool
otherwise = (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok PrimOp -> Bool
primop_ok CoreExpr
e
expr_ok PrimOp -> Bool
_ (Let {}) = Bool
False
expr_ok PrimOp -> Bool
primop_ok (Case CoreExpr
scrut Var
bndr Type
_ [Alt Var]
alts)
=
(PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok PrimOp -> Bool
primop_ok CoreExpr
scrut
Bool -> Bool -> Bool
&& HasDebugCallStack => Type -> Bool
isUnliftedType (Var -> Type
idType Var
bndr)
Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(Alt AltCon
_ [Var]
_ CoreExpr
rhs) -> (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok PrimOp -> Bool
primop_ok CoreExpr
rhs) [Alt Var]
alts
Bool -> Bool -> Bool
&& forall b. [Alt b] -> Bool
altsAreExhaustive [Alt Var]
alts
expr_ok PrimOp -> Bool
primop_ok CoreExpr
other_expr
| (CoreExpr
expr, [CoreExpr]
args) <- forall b. Expr b -> (Expr b, [Expr b])
collectArgs CoreExpr
other_expr
= case forall b. (CoreTickish -> Bool) -> Expr b -> Expr b
stripTicksTopE (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (pass :: TickishPass). GenTickish pass -> Bool
tickishCounts) CoreExpr
expr of
Var Var
f -> (PrimOp -> Bool) -> Var -> [CoreExpr] -> Bool
app_ok PrimOp -> Bool
primop_ok Var
f [CoreExpr]
args
Lit Literal
lit -> ASSERT( isRubbishLit lit ) True
CoreExpr
_ -> Bool
False
app_ok :: (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool
app_ok :: (PrimOp -> Bool) -> Var -> [CoreExpr] -> Bool
app_ok PrimOp -> Bool
primop_ok Var
fun [CoreExpr]
args
= case Var -> IdDetails
idDetails Var
fun of
DFunId Bool
new_type -> Bool -> Bool
not Bool
new_type
DataConWorkId {} -> Bool
True
PrimOpId PrimOp
op
| PrimOp -> Bool
primOpIsDiv PrimOp
op
, [CoreExpr
arg1, Lit Literal
lit] <- [CoreExpr]
args
-> Bool -> Bool
not (Literal -> Bool
isZeroLit Literal
lit) Bool -> Bool -> Bool
&& (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok PrimOp -> Bool
primop_ok CoreExpr
arg1
| PrimOp
SeqOp <- PrimOp
op
-> Bool
False
| PrimOp
DataToTagOp <- PrimOp
op
-> Bool
False
| PrimOp
KeepAliveOp <- PrimOp
op
-> Bool
False
| Bool
otherwise
-> PrimOp -> Bool
primop_ok PrimOp
op
Bool -> Bool -> Bool
&& forall (t :: * -> *). Foldable t => t Bool -> Bool
and (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith TyCoBinder -> CoreExpr -> Bool
primop_arg_ok [TyCoBinder]
arg_tys [CoreExpr]
args)
IdDetails
_other -> HasDebugCallStack => Type -> Bool
isUnliftedType (Var -> Type
idType Var
fun)
Bool -> Bool -> Bool
|| Var -> FullArgCount
idArity Var
fun forall a. Ord a => a -> a -> Bool
> FullArgCount
n_val_args
where
n_val_args :: FullArgCount
n_val_args = forall b. [Arg b] -> FullArgCount
valArgCount [CoreExpr]
args
where
([TyCoBinder]
arg_tys, Type
_) = Type -> ([TyCoBinder], Type)
splitPiTys (Var -> Type
idType Var
fun)
primop_arg_ok :: TyBinder -> CoreExpr -> Bool
primop_arg_ok :: TyCoBinder -> CoreExpr -> Bool
primop_arg_ok (Named TyCoVarBinder
_) CoreExpr
_ = Bool
True
primop_arg_ok (Anon AnonArgFlag
_ Scaled Type
ty) CoreExpr
arg
| HasDebugCallStack => Type -> Bool
isUnliftedType (forall a. Scaled a -> a
scaledThing Scaled Type
ty) = (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok PrimOp -> Bool
primop_ok CoreExpr
arg
| Bool
otherwise = Bool
True
altsAreExhaustive :: [Alt b] -> Bool
altsAreExhaustive :: forall b. [Alt b] -> Bool
altsAreExhaustive []
= Bool
False
altsAreExhaustive (Alt AltCon
con1 [b]
_ Expr b
_ : [Alt b]
alts)
= case AltCon
con1 of
AltCon
DEFAULT -> Bool
True
LitAlt {} -> Bool
False
DataAlt DataCon
c -> [Alt b]
alts forall a. [a] -> FullArgCount -> Bool
`lengthIs` (TyCon -> FullArgCount
tyConFamilySize (DataCon -> TyCon
dataConTyCon DataCon
c) forall a. Num a => a -> a -> a
- FullArgCount
1)
exprIsHNF :: CoreExpr -> Bool
exprIsHNF :: CoreExpr -> Bool
exprIsHNF = (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool
exprIsHNFlike Var -> Bool
isDataConWorkId Unfolding -> Bool
isEvaldUnfolding
exprIsConLike :: CoreExpr -> Bool
exprIsConLike :: CoreExpr -> Bool
exprIsConLike = (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool
exprIsHNFlike Var -> Bool
isConLikeId Unfolding -> Bool
isConLikeUnfolding
exprIsHNFlike :: (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool
exprIsHNFlike :: (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool
exprIsHNFlike Var -> Bool
is_con Unfolding -> Bool
is_con_unf = CoreExpr -> Bool
is_hnf_like
where
is_hnf_like :: CoreExpr -> Bool
is_hnf_like (Var Var
v)
= CheapAppFun
id_app_is_value Var
v FullArgCount
0
Bool -> Bool -> Bool
|| Unfolding -> Bool
is_con_unf (Var -> Unfolding
idUnfolding Var
v)
is_hnf_like (Lit Literal
_) = Bool
True
is_hnf_like (Type Type
_) = Bool
True
is_hnf_like (Coercion CoercionR
_) = Bool
True
is_hnf_like (Lam Var
b CoreExpr
e) = Var -> Bool
isRuntimeVar Var
b Bool -> Bool -> Bool
|| CoreExpr -> Bool
is_hnf_like CoreExpr
e
is_hnf_like (Tick CoreTickish
tickish CoreExpr
e) = Bool -> Bool
not (forall (pass :: TickishPass). GenTickish pass -> Bool
tickishCounts CoreTickish
tickish)
Bool -> Bool -> Bool
&& CoreExpr -> Bool
is_hnf_like CoreExpr
e
is_hnf_like (Cast CoreExpr
e CoercionR
_) = CoreExpr -> Bool
is_hnf_like CoreExpr
e
is_hnf_like (App CoreExpr
e CoreExpr
a)
| forall b. Expr b -> Bool
isValArg CoreExpr
a = CoreExpr -> FullArgCount -> Bool
app_is_value CoreExpr
e FullArgCount
1
| Bool
otherwise = CoreExpr -> Bool
is_hnf_like CoreExpr
e
is_hnf_like (Let Bind Var
_ CoreExpr
e) = CoreExpr -> Bool
is_hnf_like CoreExpr
e
is_hnf_like CoreExpr
_ = Bool
False
app_is_value :: CoreExpr -> Int -> Bool
app_is_value :: CoreExpr -> FullArgCount -> Bool
app_is_value (Var Var
f) FullArgCount
nva = CheapAppFun
id_app_is_value Var
f FullArgCount
nva
app_is_value (Tick CoreTickish
_ CoreExpr
f) FullArgCount
nva = CoreExpr -> FullArgCount -> Bool
app_is_value CoreExpr
f FullArgCount
nva
app_is_value (Cast CoreExpr
f CoercionR
_) FullArgCount
nva = CoreExpr -> FullArgCount -> Bool
app_is_value CoreExpr
f FullArgCount
nva
app_is_value (App CoreExpr
f CoreExpr
a) FullArgCount
nva
| forall b. Expr b -> Bool
isValArg CoreExpr
a = CoreExpr -> FullArgCount -> Bool
app_is_value CoreExpr
f (FullArgCount
nva forall a. Num a => a -> a -> a
+ FullArgCount
1)
| Bool
otherwise = CoreExpr -> FullArgCount -> Bool
app_is_value CoreExpr
f FullArgCount
nva
app_is_value CoreExpr
_ FullArgCount
_ = Bool
False
id_app_is_value :: CheapAppFun
id_app_is_value Var
id FullArgCount
n_val_args
= Var -> Bool
is_con Var
id
Bool -> Bool -> Bool
|| Var -> FullArgCount
idArity Var
id forall a. Ord a => a -> a -> Bool
> FullArgCount
n_val_args
Bool -> Bool -> Bool
|| Var
id forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
absentErrorIdKey
exprIsTopLevelBindable :: CoreExpr -> Type -> Bool
exprIsTopLevelBindable :: CoreExpr -> Type -> Bool
exprIsTopLevelBindable CoreExpr
expr Type
ty
= Bool -> Bool
not (Type -> Bool
mightBeUnliftedType Type
ty)
Bool -> Bool -> Bool
|| CoreExpr -> Bool
exprIsTickedString CoreExpr
expr
exprIsTickedString :: CoreExpr -> Bool
exprIsTickedString :: CoreExpr -> Bool
exprIsTickedString = forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> Maybe ByteString
exprIsTickedString_maybe
exprIsTickedString_maybe :: CoreExpr -> Maybe ByteString
exprIsTickedString_maybe :: CoreExpr -> Maybe ByteString
exprIsTickedString_maybe (Lit (LitString ByteString
bs)) = forall a. a -> Maybe a
Just ByteString
bs
exprIsTickedString_maybe (Tick CoreTickish
t CoreExpr
e)
| forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
tickishPlace CoreTickish
t forall a. Eq a => a -> a -> Bool
== TickishPlacement
PlaceCostCentre = forall a. Maybe a
Nothing
| Bool
otherwise = CoreExpr -> Maybe ByteString
exprIsTickedString_maybe CoreExpr
e
exprIsTickedString_maybe CoreExpr
_ = forall a. Maybe a
Nothing
dataConRepInstPat :: [Unique] -> Mult -> DataCon -> [Type] -> ([TyCoVar], [Id])
dataConRepFSInstPat :: [FastString] -> [Unique] -> Mult -> DataCon -> [Type] -> ([TyCoVar], [Id])
dataConRepInstPat :: [Unique] -> Type -> DataCon -> [Type] -> ([Var], [Var])
dataConRepInstPat = [FastString]
-> [Unique] -> Type -> DataCon -> [Type] -> ([Var], [Var])
dataConInstPat (forall a. a -> [a]
repeat ((String -> FastString
fsLit String
"ipv")))
dataConRepFSInstPat :: [FastString]
-> [Unique] -> Type -> DataCon -> [Type] -> ([Var], [Var])
dataConRepFSInstPat = [FastString]
-> [Unique] -> Type -> DataCon -> [Type] -> ([Var], [Var])
dataConInstPat
dataConInstPat :: [FastString]
-> [Unique]
-> Mult
-> DataCon
-> [Type]
-> ([TyCoVar], [Id])
dataConInstPat :: [FastString]
-> [Unique] -> Type -> DataCon -> [Type] -> ([Var], [Var])
dataConInstPat [FastString]
fss [Unique]
uniqs Type
mult DataCon
con [Type]
inst_tys
= ASSERT( univ_tvs `equalLength` inst_tys )
([Var]
ex_bndrs, [Var]
arg_ids)
where
univ_tvs :: [Var]
univ_tvs = DataCon -> [Var]
dataConUnivTyVars DataCon
con
ex_tvs :: [Var]
ex_tvs = DataCon -> [Var]
dataConExTyCoVars DataCon
con
arg_tys :: [Scaled Type]
arg_tys = DataCon -> [Scaled Type]
dataConRepArgTys DataCon
con
arg_strs :: [StrictnessMark]
arg_strs = DataCon -> [StrictnessMark]
dataConRepStrictness DataCon
con
n_ex :: FullArgCount
n_ex = forall (t :: * -> *) a. Foldable t => t a -> FullArgCount
length [Var]
ex_tvs
([Unique]
ex_uniqs, [Unique]
id_uniqs) = forall a. FullArgCount -> [a] -> ([a], [a])
splitAt FullArgCount
n_ex [Unique]
uniqs
([FastString]
ex_fss, [FastString]
id_fss) = forall a. FullArgCount -> [a] -> ([a], [a])
splitAt FullArgCount
n_ex [FastString]
fss
univ_subst :: TCvSubst
univ_subst = HasDebugCallStack => [Var] -> [Type] -> TCvSubst
zipTvSubst [Var]
univ_tvs [Type]
inst_tys
(TCvSubst
full_subst, [Var]
ex_bndrs) = forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL TCvSubst -> (Var, FastString, Unique) -> (TCvSubst, Var)
mk_ex_var TCvSubst
univ_subst
(forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Var]
ex_tvs [FastString]
ex_fss [Unique]
ex_uniqs)
mk_ex_var :: TCvSubst -> (TyCoVar, FastString, Unique) -> (TCvSubst, TyCoVar)
mk_ex_var :: TCvSubst -> (Var, FastString, Unique) -> (TCvSubst, Var)
mk_ex_var TCvSubst
subst (Var
tv, FastString
fs, Unique
uniq) = (TCvSubst -> Var -> Var -> TCvSubst
Type.extendTCvSubstWithClone TCvSubst
subst Var
tv
Var
new_tv
, Var
new_tv)
where
new_tv :: Var
new_tv | Var -> Bool
isTyVar Var
tv
= Name -> Type -> Var
mkTyVar (Unique -> FastString -> Name
mkSysTvName Unique
uniq FastString
fs) Type
kind
| Bool
otherwise
= Name -> Type -> Var
mkCoVar (Unique -> FastString -> Name
mkSystemVarName Unique
uniq FastString
fs) Type
kind
kind :: Type
kind = TCvSubst -> Type -> Type
Type.substTyUnchecked TCvSubst
subst (Var -> Type
varType Var
tv)
arg_ids :: [Var]
arg_ids = forall a b c d e.
(a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e]
zipWith4 Unique -> FastString -> Scaled Type -> StrictnessMark -> Var
mk_id_var [Unique]
id_uniqs [FastString]
id_fss [Scaled Type]
arg_tys [StrictnessMark]
arg_strs
mk_id_var :: Unique -> FastString -> Scaled Type -> StrictnessMark -> Var
mk_id_var Unique
uniq FastString
fs (Scaled Type
m Type
ty) StrictnessMark
str
= StrictnessMark -> Var -> Var
setCaseBndrEvald StrictnessMark
str forall a b. (a -> b) -> a -> b
$
Name -> Type -> Type -> Var
mkLocalIdOrCoVar Name
name (Type
mult Type -> Type -> Type
`mkMultMul` Type
m) (HasCallStack => TCvSubst -> Type -> Type
Type.substTy TCvSubst
full_subst Type
ty)
where
name :: Name
name = Unique -> OccName -> SrcSpan -> Name
mkInternalName Unique
uniq (FastString -> OccName
mkVarOccFS FastString
fs) SrcSpan
noSrcSpan
cheapEqExpr :: Expr b -> Expr b -> Bool
cheapEqExpr :: forall {b}. Expr b -> Expr b -> Bool
cheapEqExpr = forall b. (CoreTickish -> Bool) -> Expr b -> Expr b -> Bool
cheapEqExpr' (forall a b. a -> b -> a
const Bool
False)
cheapEqExpr' :: (CoreTickish -> Bool) -> Expr b -> Expr b -> Bool
{-# INLINE cheapEqExpr' #-}
cheapEqExpr' :: forall b. (CoreTickish -> Bool) -> Expr b -> Expr b -> Bool
cheapEqExpr' CoreTickish -> Bool
ignoreTick Expr b
e1 Expr b
e2
= Expr b -> Expr b -> Bool
go Expr b
e1 Expr b
e2
where
go :: Expr b -> Expr b -> Bool
go (Var Var
v1) (Var Var
v2) = Var
v1 forall a. Eq a => a -> a -> Bool
== Var
v2
go (Lit Literal
lit1) (Lit Literal
lit2) = Literal
lit1 forall a. Eq a => a -> a -> Bool
== Literal
lit2
go (Type Type
t1) (Type Type
t2) = Type
t1 Type -> Type -> Bool
`eqType` Type
t2
go (Coercion CoercionR
c1) (Coercion CoercionR
c2) = CoercionR
c1 CoercionR -> CoercionR -> Bool
`eqCoercion` CoercionR
c2
go (App Expr b
f1 Expr b
a1) (App Expr b
f2 Expr b
a2) = Expr b
f1 Expr b -> Expr b -> Bool
`go` Expr b
f2 Bool -> Bool -> Bool
&& Expr b
a1 Expr b -> Expr b -> Bool
`go` Expr b
a2
go (Cast Expr b
e1 CoercionR
t1) (Cast Expr b
e2 CoercionR
t2) = Expr b
e1 Expr b -> Expr b -> Bool
`go` Expr b
e2 Bool -> Bool -> Bool
&& CoercionR
t1 CoercionR -> CoercionR -> Bool
`eqCoercion` CoercionR
t2
go (Tick CoreTickish
t1 Expr b
e1) Expr b
e2 | CoreTickish -> Bool
ignoreTick CoreTickish
t1 = Expr b -> Expr b -> Bool
go Expr b
e1 Expr b
e2
go Expr b
e1 (Tick CoreTickish
t2 Expr b
e2) | CoreTickish -> Bool
ignoreTick CoreTickish
t2 = Expr b -> Expr b -> Bool
go Expr b
e1 Expr b
e2
go (Tick CoreTickish
t1 Expr b
e1) (Tick CoreTickish
t2 Expr b
e2) = CoreTickish
t1 forall a. Eq a => a -> a -> Bool
== CoreTickish
t2 Bool -> Bool -> Bool
&& Expr b
e1 Expr b -> Expr b -> Bool
`go` Expr b
e2
go Expr b
_ Expr b
_ = Bool
False
eqExpr :: InScopeSet -> CoreExpr -> CoreExpr -> Bool
eqExpr :: InScopeSet -> CoreExpr -> CoreExpr -> Bool
eqExpr InScopeSet
in_scope CoreExpr
e1 CoreExpr
e2
= RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go (InScopeSet -> RnEnv2
mkRnEnv2 InScopeSet
in_scope) CoreExpr
e1 CoreExpr
e2
where
go :: RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go RnEnv2
env (Var Var
v1) (Var Var
v2)
| RnEnv2 -> Var -> Var
rnOccL RnEnv2
env Var
v1 forall a. Eq a => a -> a -> Bool
== RnEnv2 -> Var -> Var
rnOccR RnEnv2
env Var
v2
= Bool
True
go RnEnv2
_ (Lit Literal
lit1) (Lit Literal
lit2) = Literal
lit1 forall a. Eq a => a -> a -> Bool
== Literal
lit2
go RnEnv2
env (Type Type
t1) (Type Type
t2) = RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env Type
t1 Type
t2
go RnEnv2
env (Coercion CoercionR
co1) (Coercion CoercionR
co2) = RnEnv2 -> CoercionR -> CoercionR -> Bool
eqCoercionX RnEnv2
env CoercionR
co1 CoercionR
co2
go RnEnv2
env (Cast CoreExpr
e1 CoercionR
co1) (Cast CoreExpr
e2 CoercionR
co2) = RnEnv2 -> CoercionR -> CoercionR -> Bool
eqCoercionX RnEnv2
env CoercionR
co1 CoercionR
co2 Bool -> Bool -> Bool
&& RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go RnEnv2
env CoreExpr
e1 CoreExpr
e2
go RnEnv2
env (App CoreExpr
f1 CoreExpr
a1) (App CoreExpr
f2 CoreExpr
a2) = RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go RnEnv2
env CoreExpr
f1 CoreExpr
f2 Bool -> Bool -> Bool
&& RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go RnEnv2
env CoreExpr
a1 CoreExpr
a2
go RnEnv2
env (Tick CoreTickish
n1 CoreExpr
e1) (Tick CoreTickish
n2 CoreExpr
e2) = RnEnv2 -> CoreTickish -> CoreTickish -> Bool
eqTickish RnEnv2
env CoreTickish
n1 CoreTickish
n2 Bool -> Bool -> Bool
&& RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go RnEnv2
env CoreExpr
e1 CoreExpr
e2
go RnEnv2
env (Lam Var
b1 CoreExpr
e1) (Lam Var
b2 CoreExpr
e2)
= RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env (Var -> Type
varType Var
b1) (Var -> Type
varType Var
b2)
Bool -> Bool -> Bool
&& RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go (RnEnv2 -> Var -> Var -> RnEnv2
rnBndr2 RnEnv2
env Var
b1 Var
b2) CoreExpr
e1 CoreExpr
e2
go RnEnv2
env (Let (NonRec Var
v1 CoreExpr
r1) CoreExpr
e1) (Let (NonRec Var
v2 CoreExpr
r2) CoreExpr
e2)
= RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go RnEnv2
env CoreExpr
r1 CoreExpr
r2
Bool -> Bool -> Bool
&& RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go (RnEnv2 -> Var -> Var -> RnEnv2
rnBndr2 RnEnv2
env Var
v1 Var
v2) CoreExpr
e1 CoreExpr
e2
go RnEnv2
env (Let (Rec [(Var, CoreExpr)]
ps1) CoreExpr
e1) (Let (Rec [(Var, CoreExpr)]
ps2) CoreExpr
e2)
= forall a b. [a] -> [b] -> Bool
equalLength [(Var, CoreExpr)]
ps1 [(Var, CoreExpr)]
ps2
Bool -> Bool -> Bool
&& forall a b. (a -> b -> Bool) -> [a] -> [b] -> Bool
all2 (RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go RnEnv2
env') [CoreExpr]
rs1 [CoreExpr]
rs2 Bool -> Bool -> Bool
&& RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go 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 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
= forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Alt Var]
a2 Bool -> Bool -> Bool
&& RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go RnEnv2
env CoreExpr
e1 CoreExpr
e2 Bool -> Bool -> Bool
&& RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env Type
t1 Type
t2
| Bool
otherwise
= RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go RnEnv2
env CoreExpr
e1 CoreExpr
e2 Bool -> Bool -> Bool
&& forall a b. (a -> b -> Bool) -> [a] -> [b] -> Bool
all2 (RnEnv2 -> Alt Var -> Alt Var -> Bool
go_alt (RnEnv2 -> Var -> Var -> RnEnv2
rnBndr2 RnEnv2
env Var
b1 Var
b2)) [Alt Var]
a1 [Alt Var]
a2
go RnEnv2
_ CoreExpr
_ CoreExpr
_ = Bool
False
go_alt :: RnEnv2 -> Alt Var -> Alt Var -> Bool
go_alt RnEnv2
env (Alt AltCon
c1 [Var]
bs1 CoreExpr
e1) (Alt AltCon
c2 [Var]
bs2 CoreExpr
e2)
= AltCon
c1 forall a. Eq a => a -> a -> Bool
== AltCon
c2 Bool -> Bool -> Bool
&& RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go (RnEnv2 -> [Var] -> [Var] -> RnEnv2
rnBndrs2 RnEnv2
env [Var]
bs1 [Var]
bs2) CoreExpr
e1 CoreExpr
e2
eqTickish :: RnEnv2 -> CoreTickish -> CoreTickish -> Bool
eqTickish :: RnEnv2 -> CoreTickish -> CoreTickish -> Bool
eqTickish RnEnv2
env (Breakpoint XBreakpoint 'TickishPassCore
lext FullArgCount
lid [XTickishId 'TickishPassCore]
lids) (Breakpoint XBreakpoint 'TickishPassCore
rext FullArgCount
rid [XTickishId 'TickishPassCore]
rids)
= FullArgCount
lid forall a. Eq a => a -> a -> Bool
== FullArgCount
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 Bool -> Bool -> Bool
&&
XBreakpoint 'TickishPassCore
lext forall a. Eq a => a -> a -> Bool
== XBreakpoint 'TickishPassCore
rext
eqTickish RnEnv2
_ CoreTickish
l CoreTickish
r = CoreTickish
l forall a. Eq a => a -> a -> Bool
== CoreTickish
r
diffExpr :: Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr :: Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
_ RnEnv2
env (Var Var
v1) (Var Var
v2) | RnEnv2 -> Var -> Var
rnOccL RnEnv2
env Var
v1 forall a. Eq a => a -> a -> Bool
== RnEnv2 -> Var -> Var
rnOccR RnEnv2
env Var
v2 = []
diffExpr Bool
_ RnEnv2
_ (Lit Literal
lit1) (Lit Literal
lit2) | Literal
lit1 forall a. Eq a => a -> a -> Bool
== Literal
lit2 = []
diffExpr Bool
_ RnEnv2
env (Type Type
t1) (Type Type
t2) | RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env Type
t1 Type
t2 = []
diffExpr Bool
_ RnEnv2
env (Coercion CoercionR
co1) (Coercion CoercionR
co2)
| RnEnv2 -> CoercionR -> CoercionR -> Bool
eqCoercionX RnEnv2
env CoercionR
co1 CoercionR
co2 = []
diffExpr Bool
top RnEnv2
env (Cast CoreExpr
e1 CoercionR
co1) (Cast CoreExpr
e2 CoercionR
co2)
| RnEnv2 -> CoercionR -> CoercionR -> Bool
eqCoercionX RnEnv2
env CoercionR
co1 CoercionR
co2 = Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
top RnEnv2
env CoreExpr
e1 CoreExpr
e2
diffExpr Bool
top RnEnv2
env (Tick CoreTickish
n1 CoreExpr
e1) CoreExpr
e2
| Bool -> Bool
not (forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode CoreTickish
n1) = Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
top RnEnv2
env CoreExpr
e1 CoreExpr
e2
diffExpr Bool
top RnEnv2
env CoreExpr
e1 (Tick CoreTickish
n2 CoreExpr
e2)
| Bool -> Bool
not (forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode CoreTickish
n2) = Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
top RnEnv2
env CoreExpr
e1 CoreExpr
e2
diffExpr Bool
top RnEnv2
env (Tick CoreTickish
n1 CoreExpr
e1) (Tick CoreTickish
n2 CoreExpr
e2)
| RnEnv2 -> CoreTickish -> CoreTickish -> Bool
eqTickish RnEnv2
env CoreTickish
n1 CoreTickish
n2 = Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
top RnEnv2
env CoreExpr
e1 CoreExpr
e2
diffExpr Bool
_ RnEnv2
_ (App (App (Var Var
absent) CoreExpr
_) CoreExpr
_)
(App (App (Var Var
absent2) CoreExpr
_) CoreExpr
_)
| Var -> Bool
isDeadEndId Var
absent Bool -> Bool -> Bool
&& Var -> Bool
isDeadEndId Var
absent2 = []
diffExpr Bool
top RnEnv2
env (App CoreExpr
f1 CoreExpr
a1) (App CoreExpr
f2 CoreExpr
a2)
= Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
top RnEnv2
env CoreExpr
f1 CoreExpr
f2 forall a. [a] -> [a] -> [a]
++ Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
top RnEnv2
env CoreExpr
a1 CoreExpr
a2
diffExpr Bool
top RnEnv2
env (Lam Var
b1 CoreExpr
e1) (Lam Var
b2 CoreExpr
e2)
| RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env (Var -> Type
varType Var
b1) (Var -> Type
varType Var
b2)
= Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
top (RnEnv2 -> Var -> Var -> RnEnv2
rnBndr2 RnEnv2
env Var
b1 Var
b2) CoreExpr
e1 CoreExpr
e2
diffExpr Bool
top RnEnv2
env (Let Bind Var
bs1 CoreExpr
e1) (Let Bind Var
bs2 CoreExpr
e2)
= let ([SDoc]
ds, RnEnv2
env') = Bool
-> RnEnv2
-> [(Var, CoreExpr)]
-> [(Var, CoreExpr)]
-> ([SDoc], RnEnv2)
diffBinds Bool
top RnEnv2
env (forall b. [Bind b] -> [(b, Expr b)]
flattenBinds [Bind Var
bs1]) (forall b. [Bind b] -> [(b, Expr b)]
flattenBinds [Bind Var
bs2])
in [SDoc]
ds forall a. [a] -> [a] -> [a]
++ Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
top RnEnv2
env' CoreExpr
e1 CoreExpr
e2
diffExpr Bool
top RnEnv2
env (Case CoreExpr
e1 Var
b1 Type
t1 [Alt Var]
a1) (Case CoreExpr
e2 Var
b2 Type
t2 [Alt Var]
a2)
| forall a b. [a] -> [b] -> Bool
equalLength [Alt Var]
a1 [Alt Var]
a2 Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Alt Var]
a1) Bool -> Bool -> Bool
|| RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env Type
t1 Type
t2
= Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
top RnEnv2
env CoreExpr
e1 CoreExpr
e2 forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Alt Var -> Alt Var -> [SDoc]
diffAlt [Alt Var]
a1 [Alt Var]
a2)
where env' :: RnEnv2
env' = RnEnv2 -> Var -> Var -> RnEnv2
rnBndr2 RnEnv2
env Var
b1 Var
b2
diffAlt :: Alt Var -> Alt Var -> [SDoc]
diffAlt (Alt AltCon
c1 [Var]
bs1 CoreExpr
e1) (Alt AltCon
c2 [Var]
bs2 CoreExpr
e2)
| AltCon
c1 forall a. Eq a => a -> a -> Bool
/= AltCon
c2 = [String -> SDoc
text String
"alt-cons " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr AltCon
c1 SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" /= " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr AltCon
c2]
| Bool
otherwise = Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
top (RnEnv2 -> [Var] -> [Var] -> RnEnv2
rnBndrs2 RnEnv2
env' [Var]
bs1 [Var]
bs2) CoreExpr
e1 CoreExpr
e2
diffExpr Bool
_ RnEnv2
_ CoreExpr
e1 CoreExpr
e2
= [[SDoc] -> SDoc
fsep [forall a. Outputable a => a -> SDoc
ppr CoreExpr
e1, String -> SDoc
text String
"/=", forall a. Outputable a => a -> SDoc
ppr CoreExpr
e2]]
diffBinds :: Bool -> RnEnv2 -> [(Var, CoreExpr)] -> [(Var, CoreExpr)]
-> ([SDoc], RnEnv2)
diffBinds :: Bool
-> RnEnv2
-> [(Var, CoreExpr)]
-> [(Var, CoreExpr)]
-> ([SDoc], RnEnv2)
diffBinds Bool
top RnEnv2
env [(Var, CoreExpr)]
binds1 = FullArgCount
-> RnEnv2
-> [(Var, CoreExpr)]
-> [(Var, CoreExpr)]
-> ([SDoc], RnEnv2)
go (forall (t :: * -> *) a. Foldable t => t a -> FullArgCount
length [(Var, CoreExpr)]
binds1) RnEnv2
env [(Var, CoreExpr)]
binds1
where go :: FullArgCount
-> RnEnv2
-> [(Var, CoreExpr)]
-> [(Var, CoreExpr)]
-> ([SDoc], RnEnv2)
go FullArgCount
_ RnEnv2
env [] []
= ([], RnEnv2
env)
go FullArgCount
fuel RnEnv2
env [(Var, CoreExpr)]
binds1 [(Var, CoreExpr)]
binds2
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Var, CoreExpr)]
binds1 Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Var, CoreExpr)]
binds2
= (RnEnv2 -> [(Var, CoreExpr)] -> [(Var, CoreExpr)] -> [SDoc]
warn RnEnv2
env [(Var, CoreExpr)]
binds1 [(Var, CoreExpr)]
binds2, RnEnv2
env)
| FullArgCount
fuel forall a. Eq a => a -> a -> Bool
== FullArgCount
0
= if Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ RnEnv2
env RnEnv2 -> Var -> Bool
`inRnEnvL` forall a b. (a, b) -> a
fst (forall a. [a] -> a
head [(Var, CoreExpr)]
binds1)
then let env' :: RnEnv2
env' = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (RnEnv2 -> [Var] -> [Var] -> RnEnv2
rnBndrs2 RnEnv2
env) forall a b. (a -> b) -> a -> b
$ forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$
forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. Ord a => [a] -> [a]
sort forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Var, CoreExpr)]
binds1) (forall a. Ord a => [a] -> [a]
sort forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Var, CoreExpr)]
binds2)
in FullArgCount
-> RnEnv2
-> [(Var, CoreExpr)]
-> [(Var, CoreExpr)]
-> ([SDoc], RnEnv2)
go (forall (t :: * -> *) a. Foldable t => t a -> FullArgCount
length [(Var, CoreExpr)]
binds1) RnEnv2
env' [(Var, CoreExpr)]
binds1 [(Var, CoreExpr)]
binds2
else (RnEnv2 -> [(Var, CoreExpr)] -> [(Var, CoreExpr)] -> [SDoc]
warn RnEnv2
env [(Var, CoreExpr)]
binds1 [(Var, CoreExpr)]
binds2, RnEnv2
env)
go FullArgCount
fuel RnEnv2
env ((Var
bndr1,CoreExpr
expr1):[(Var, CoreExpr)]
binds1) [(Var, CoreExpr)]
binds2
| let matchExpr :: (Var, CoreExpr) -> Bool
matchExpr (Var
bndr,CoreExpr
expr) =
(Bool -> Bool
not Bool
top Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Bool
null (RnEnv2 -> Var -> Var -> [SDoc]
diffIdInfo RnEnv2
env Var
bndr Var
bndr1)) Bool -> Bool -> Bool
&&
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
top (RnEnv2 -> Var -> Var -> RnEnv2
rnBndr2 RnEnv2
env Var
bndr1 Var
bndr) CoreExpr
expr1 CoreExpr
expr)
, ([(Var, CoreExpr)]
binds2l, (Var
bndr2,CoreExpr
_):[(Var, CoreExpr)]
binds2r) <- forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Var, CoreExpr) -> Bool
matchExpr [(Var, CoreExpr)]
binds2
= FullArgCount
-> RnEnv2
-> [(Var, CoreExpr)]
-> [(Var, CoreExpr)]
-> ([SDoc], RnEnv2)
go (forall (t :: * -> *) a. Foldable t => t a -> FullArgCount
length [(Var, CoreExpr)]
binds1) (RnEnv2 -> Var -> Var -> RnEnv2
rnBndr2 RnEnv2
env Var
bndr1 Var
bndr2)
[(Var, CoreExpr)]
binds1 ([(Var, CoreExpr)]
binds2l forall a. [a] -> [a] -> [a]
++ [(Var, CoreExpr)]
binds2r)
| Bool
otherwise
= FullArgCount
-> RnEnv2
-> [(Var, CoreExpr)]
-> [(Var, CoreExpr)]
-> ([SDoc], RnEnv2)
go (FullArgCount
fuelforall a. Num a => a -> a -> a
-FullArgCount
1) RnEnv2
env ([(Var, CoreExpr)]
binds1forall a. [a] -> [a] -> [a]
++[(Var
bndr1,CoreExpr
expr1)]) [(Var, CoreExpr)]
binds2
go FullArgCount
_ RnEnv2
_ [(Var, CoreExpr)]
_ [(Var, CoreExpr)]
_ = forall a. String -> a
panic String
"diffBinds: impossible"
warn :: RnEnv2 -> [(Var, CoreExpr)] -> [(Var, CoreExpr)] -> [SDoc]
warn RnEnv2
env [(Var, CoreExpr)]
binds1 [(Var, CoreExpr)]
binds2 =
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (RnEnv2 -> (Var, CoreExpr) -> (Var, CoreExpr) -> [SDoc]
diffBind RnEnv2
env)) (forall a b. [a] -> [b] -> [(a, b)]
zip [(Var, CoreExpr)]
binds1' [(Var, CoreExpr)]
binds2') forall a. [a] -> [a] -> [a]
++
forall {b}. OutputableBndr b => String -> [(b, Expr b)] -> [SDoc]
unmatched String
"unmatched left-hand:" (forall a. FullArgCount -> [a] -> [a]
drop FullArgCount
l [(Var, CoreExpr)]
binds1') forall a. [a] -> [a] -> [a]
++
forall {b}. OutputableBndr b => String -> [(b, Expr b)] -> [SDoc]
unmatched String
"unmatched right-hand:" (forall a. FullArgCount -> [a] -> [a]
drop FullArgCount
l [(Var, CoreExpr)]
binds2')
where binds1' :: [(Var, CoreExpr)]
binds1' = forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> a
fst) [(Var, CoreExpr)]
binds1
binds2' :: [(Var, CoreExpr)]
binds2' = forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> a
fst) [(Var, CoreExpr)]
binds2
l :: FullArgCount
l = forall a. Ord a => a -> a -> a
min (forall (t :: * -> *) a. Foldable t => t a -> FullArgCount
length [(Var, CoreExpr)]
binds1') (forall (t :: * -> *) a. Foldable t => t a -> FullArgCount
length [(Var, CoreExpr)]
binds2')
unmatched :: String -> [(b, Expr b)] -> [SDoc]
unmatched String
_ [] = []
unmatched String
txt [(b, Expr b)]
bs = [String -> SDoc
text String
txt SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr (forall b. [(b, Expr b)] -> Bind b
Rec [(b, Expr b)]
bs)]
diffBind :: RnEnv2 -> (Var, CoreExpr) -> (Var, CoreExpr) -> [SDoc]
diffBind RnEnv2
env (Var
bndr1,CoreExpr
expr1) (Var
bndr2,CoreExpr
expr2)
| ds :: [SDoc]
ds@(SDoc
_:[SDoc]
_) <- Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
top RnEnv2
env CoreExpr
expr1 CoreExpr
expr2
= String -> Var -> Var -> [SDoc] -> [SDoc]
locBind String
"in binding" Var
bndr1 Var
bndr2 [SDoc]
ds
| Bool
otherwise
= RnEnv2 -> Var -> Var -> [SDoc]
diffIdInfo RnEnv2
env Var
bndr1 Var
bndr2
diffIdInfo :: RnEnv2 -> Var -> Var -> [SDoc]
diffIdInfo :: RnEnv2 -> Var -> Var -> [SDoc]
diffIdInfo RnEnv2
env Var
bndr1 Var
bndr2
| IdInfo -> FullArgCount
arityInfo IdInfo
info1 forall a. Eq a => a -> a -> Bool
== IdInfo -> FullArgCount
arityInfo IdInfo
info2
Bool -> Bool -> Bool
&& IdInfo -> CafInfo
cafInfo IdInfo
info1 forall a. Eq a => a -> a -> Bool
== IdInfo -> CafInfo
cafInfo IdInfo
info2
Bool -> Bool -> Bool
&& IdInfo -> OneShotInfo
oneShotInfo IdInfo
info1 forall a. Eq a => a -> a -> Bool
== IdInfo -> OneShotInfo
oneShotInfo IdInfo
info2
Bool -> Bool -> Bool
&& IdInfo -> InlinePragma
inlinePragInfo IdInfo
info1 forall a. Eq a => a -> a -> Bool
== IdInfo -> InlinePragma
inlinePragInfo IdInfo
info2
Bool -> Bool -> Bool
&& IdInfo -> OccInfo
occInfo IdInfo
info1 forall a. Eq a => a -> a -> Bool
== IdInfo -> OccInfo
occInfo IdInfo
info2
Bool -> Bool -> Bool
&& IdInfo -> Demand
demandInfo IdInfo
info1 forall a. Eq a => a -> a -> Bool
== IdInfo -> Demand
demandInfo IdInfo
info2
Bool -> Bool -> Bool
&& IdInfo -> FullArgCount
callArityInfo IdInfo
info1 forall a. Eq a => a -> a -> Bool
== IdInfo -> FullArgCount
callArityInfo IdInfo
info2
Bool -> Bool -> Bool
&& IdInfo -> LevityInfo
levityInfo IdInfo
info1 forall a. Eq a => a -> a -> Bool
== IdInfo -> LevityInfo
levityInfo IdInfo
info2
= String -> Var -> Var -> [SDoc] -> [SDoc]
locBind String
"in unfolding of" Var
bndr1 Var
bndr2 forall a b. (a -> b) -> a -> b
$
RnEnv2 -> Unfolding -> Unfolding -> [SDoc]
diffUnfold RnEnv2
env (IdInfo -> Unfolding
unfoldingInfo IdInfo
info1) (IdInfo -> Unfolding
unfoldingInfo IdInfo
info2)
| Bool
otherwise
= String -> Var -> Var -> [SDoc] -> [SDoc]
locBind String
"in Id info of" Var
bndr1 Var
bndr2
[[SDoc] -> SDoc
fsep [forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
LetBind Var
bndr1, String -> SDoc
text String
"/=", forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
LetBind Var
bndr2]]
where info1 :: IdInfo
info1 = HasDebugCallStack => Var -> IdInfo
idInfo Var
bndr1; info2 :: IdInfo
info2 = HasDebugCallStack => Var -> IdInfo
idInfo Var
bndr2
diffUnfold :: RnEnv2 -> Unfolding -> Unfolding -> [SDoc]
diffUnfold :: RnEnv2 -> Unfolding -> Unfolding -> [SDoc]
diffUnfold RnEnv2
_ Unfolding
NoUnfolding Unfolding
NoUnfolding = []
diffUnfold RnEnv2
_ Unfolding
BootUnfolding Unfolding
BootUnfolding = []
diffUnfold RnEnv2
_ (OtherCon [AltCon]
cs1) (OtherCon [AltCon]
cs2) | [AltCon]
cs1 forall a. Eq a => a -> a -> Bool
== [AltCon]
cs2 = []
diffUnfold RnEnv2
env (DFunUnfolding [Var]
bs1 DataCon
c1 [CoreExpr]
a1)
(DFunUnfolding [Var]
bs2 DataCon
c2 [CoreExpr]
a2)
| DataCon
c1 forall a. Eq a => a -> a -> Bool
== DataCon
c2 Bool -> Bool -> Bool
&& forall a b. [a] -> [b] -> Bool
equalLength [Var]
bs1 [Var]
bs2
= forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
False RnEnv2
env')) (forall a b. [a] -> [b] -> [(a, b)]
zip [CoreExpr]
a1 [CoreExpr]
a2)
where env' :: RnEnv2
env' = RnEnv2 -> [Var] -> [Var] -> RnEnv2
rnBndrs2 RnEnv2
env [Var]
bs1 [Var]
bs2
diffUnfold RnEnv2
env (CoreUnfolding CoreExpr
t1 UnfoldingSource
_ Bool
_ Bool
v1 Bool
cl1 Bool
wf1 Bool
x1 UnfoldingGuidance
g1)
(CoreUnfolding CoreExpr
t2 UnfoldingSource
_ Bool
_ Bool
v2 Bool
cl2 Bool
wf2 Bool
x2 UnfoldingGuidance
g2)
| Bool
v1 forall a. Eq a => a -> a -> Bool
== Bool
v2 Bool -> Bool -> Bool
&& Bool
cl1 forall a. Eq a => a -> a -> Bool
== Bool
cl2
Bool -> Bool -> Bool
&& Bool
wf1 forall a. Eq a => a -> a -> Bool
== Bool
wf2 Bool -> Bool -> Bool
&& Bool
x1 forall a. Eq a => a -> a -> Bool
== Bool
x2 Bool -> Bool -> Bool
&& UnfoldingGuidance
g1 forall a. Eq a => a -> a -> Bool
== UnfoldingGuidance
g2
= Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
False RnEnv2
env CoreExpr
t1 CoreExpr
t2
diffUnfold RnEnv2
_ Unfolding
uf1 Unfolding
uf2
= [[SDoc] -> SDoc
fsep [forall a. Outputable a => a -> SDoc
ppr Unfolding
uf1, String -> SDoc
text String
"/=", forall a. Outputable a => a -> SDoc
ppr Unfolding
uf2]]
locBind :: String -> Var -> Var -> [SDoc] -> [SDoc]
locBind :: String -> Var -> Var -> [SDoc] -> [SDoc]
locBind String
loc Var
b1 Var
b2 [SDoc]
diffs = forall a b. (a -> b) -> [a] -> [b]
map SDoc -> SDoc
addLoc [SDoc]
diffs
where addLoc :: SDoc -> SDoc
addLoc SDoc
d = SDoc
d SDoc -> SDoc -> SDoc
$$ FullArgCount -> SDoc -> SDoc
nest FullArgCount
2 (SDoc -> SDoc
parens (String -> SDoc
text String
loc SDoc -> SDoc -> SDoc
<+> SDoc
bindLoc))
bindLoc :: SDoc
bindLoc | Var
b1 forall a. Eq a => a -> a -> Bool
== Var
b2 = forall a. Outputable a => a -> SDoc
ppr Var
b1
| Bool
otherwise = forall a. Outputable a => a -> SDoc
ppr Var
b1 SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
'/' SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Var
b2
tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr
tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr
tryEtaReduce [Var]
bndrs CoreExpr
body
= [Var] -> CoreExpr -> CoercionR -> Maybe CoreExpr
go (forall a. [a] -> [a]
reverse [Var]
bndrs) CoreExpr
body (Type -> CoercionR
mkRepReflCo (CoreExpr -> Type
exprType CoreExpr
body))
where
incoming_arity :: FullArgCount
incoming_arity = forall a. (a -> Bool) -> [a] -> FullArgCount
count Var -> Bool
isId [Var]
bndrs
go :: [Var]
-> CoreExpr
-> Coercion
-> Maybe CoreExpr
go :: [Var] -> CoreExpr -> CoercionR -> Maybe CoreExpr
go [] CoreExpr
fun CoercionR
co
| CoreExpr -> Bool
ok_fun CoreExpr
fun
, let used_vars :: VarSet
used_vars = CoreExpr -> VarSet
exprFreeVars CoreExpr
fun VarSet -> VarSet -> VarSet
`unionVarSet` CoercionR -> VarSet
tyCoVarsOfCo CoercionR
co
, Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Var -> VarSet -> Bool
`elemVarSet` VarSet
used_vars) [Var]
bndrs)
= forall a. a -> Maybe a
Just (CoreExpr -> CoercionR -> CoreExpr
mkCast CoreExpr
fun CoercionR
co)
go [Var]
bs (Tick CoreTickish
t CoreExpr
e) CoercionR
co
| forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable CoreTickish
t
= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t) forall a b. (a -> b) -> a -> b
$ [Var] -> CoreExpr -> CoercionR -> Maybe CoreExpr
go [Var]
bs CoreExpr
e CoercionR
co
go (Var
b : [Var]
bs) (App CoreExpr
fun CoreExpr
arg) CoercionR
co
| Just (CoercionR
co', [CoreTickish]
ticks) <- Var
-> CoreExpr
-> CoercionR
-> Type
-> Maybe (CoercionR, [CoreTickish])
ok_arg Var
b CoreExpr
arg CoercionR
co (CoreExpr -> Type
exprType CoreExpr
fun)
= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CoreTickish -> CoreExpr -> CoreExpr
mkTick) [CoreTickish]
ticks) forall a b. (a -> b) -> a -> b
$ [Var] -> CoreExpr -> CoercionR -> Maybe CoreExpr
go [Var]
bs CoreExpr
fun CoercionR
co'
go [Var]
_ CoreExpr
_ CoercionR
_ = forall a. Maybe a
Nothing
ok_fun :: CoreExpr -> Bool
ok_fun (App CoreExpr
fun (Type {})) = CoreExpr -> Bool
ok_fun CoreExpr
fun
ok_fun (Cast CoreExpr
fun CoercionR
_) = CoreExpr -> Bool
ok_fun CoreExpr
fun
ok_fun (Tick CoreTickish
_ CoreExpr
expr) = CoreExpr -> Bool
ok_fun CoreExpr
expr
ok_fun (Var Var
fun_id) = Var -> Bool
ok_fun_id Var
fun_id Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Var -> Bool
ok_lam [Var]
bndrs
ok_fun CoreExpr
_fun = Bool
False
ok_fun_id :: Var -> Bool
ok_fun_id Var
fun = Var -> FullArgCount
fun_arity Var
fun forall a. Ord a => a -> a -> Bool
>= FullArgCount
incoming_arity
fun_arity :: Var -> FullArgCount
fun_arity Var
fun
| Var -> Bool
isLocalId Var
fun
, OccInfo -> Bool
isStrongLoopBreaker (Var -> OccInfo
idOccInfo Var
fun) = FullArgCount
0
| FullArgCount
arity forall a. Ord a => a -> a -> Bool
> FullArgCount
0 = FullArgCount
arity
| Unfolding -> Bool
isEvaldUnfolding (Var -> Unfolding
idUnfolding Var
fun) = FullArgCount
1
| Bool
otherwise = FullArgCount
0
where
arity :: FullArgCount
arity = Var -> FullArgCount
idArity Var
fun
ok_lam :: Var -> Bool
ok_lam Var
v = Var -> Bool
isTyVar Var
v Bool -> Bool -> Bool
|| Var -> Bool
isEvVar Var
v
ok_arg :: Var
-> CoreExpr
-> Coercion
-> Type
-> Maybe (Coercion
, [CoreTickish])
ok_arg :: Var
-> CoreExpr
-> CoercionR
-> Type
-> Maybe (CoercionR, [CoreTickish])
ok_arg Var
bndr (Type Type
ty) CoercionR
co Type
_
| Just Var
tv <- Type -> Maybe Var
getTyVar_maybe Type
ty
, Var
bndr forall a. Eq a => a -> a -> Bool
== Var
tv = forall a. a -> Maybe a
Just ([Var] -> CoercionR -> CoercionR
mkHomoForAllCos [Var
tv] CoercionR
co, [])
ok_arg Var
bndr (Var Var
v) CoercionR
co Type
fun_ty
| Var
bndr forall a. Eq a => a -> a -> Bool
== Var
v
, let mult :: Type
mult = Var -> Type
idMult Var
bndr
, Just (Type
fun_mult, Type
_, Type
_) <- Type -> Maybe (Type, Type, Type)
splitFunTy_maybe Type
fun_ty
, Type
mult Type -> Type -> Bool
`eqType` Type
fun_mult
= forall a. a -> Maybe a
Just (Role -> Scaled Type -> CoercionR -> CoercionR
mkFunResCo Role
Representational (Var -> Scaled Type
idScaledType Var
bndr) CoercionR
co, [])
ok_arg Var
bndr (Cast CoreExpr
e CoercionR
co_arg) CoercionR
co Type
fun_ty
| ([CoreTickish]
ticks, Var Var
v) <- forall b.
(CoreTickish -> Bool) -> Expr b -> ([CoreTickish], Expr b)
stripTicksTop forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable CoreExpr
e
, Just (Type
fun_mult, Type
_, Type
_) <- Type -> Maybe (Type, Type, Type)
splitFunTy_maybe Type
fun_ty
, Var
bndr forall a. Eq a => a -> a -> Bool
== Var
v
, Type
fun_mult Type -> Type -> Bool
`eqType` Var -> Type
idMult Var
bndr
= forall a. a -> Maybe a
Just (Role -> CoercionR -> CoercionR -> CoercionR -> CoercionR
mkFunCo Role
Representational (Type -> CoercionR
multToCo Type
fun_mult) (CoercionR -> CoercionR
mkSymCo CoercionR
co_arg) CoercionR
co, [CoreTickish]
ticks)
ok_arg Var
bndr (Tick CoreTickish
t CoreExpr
arg) CoercionR
co Type
fun_ty
| forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable CoreTickish
t, Just (CoercionR
co', [CoreTickish]
ticks) <- Var
-> CoreExpr
-> CoercionR
-> Type
-> Maybe (CoercionR, [CoreTickish])
ok_arg Var
bndr CoreExpr
arg CoercionR
co Type
fun_ty
= forall a. a -> Maybe a
Just (CoercionR
co', CoreTickish
tforall a. a -> [a] -> [a]
:[CoreTickish]
ticks)
ok_arg Var
_ CoreExpr
_ CoercionR
_ Type
_ = forall a. Maybe a
Nothing
zapLamBndrs :: FullArgCount -> [Var] -> [Var]
zapLamBndrs :: FullArgCount -> [Var] -> [Var]
zapLamBndrs FullArgCount
arg_count [Var]
bndrs
| Bool
no_need_to_zap = [Var]
bndrs
| Bool
otherwise = FullArgCount -> [Var] -> [Var]
zap_em FullArgCount
arg_count [Var]
bndrs
where
no_need_to_zap :: Bool
no_need_to_zap = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Var -> Bool
isOneShotBndr (forall a. FullArgCount -> [a] -> [a]
drop FullArgCount
arg_count [Var]
bndrs)
zap_em :: FullArgCount -> [Var] -> [Var]
zap_em :: FullArgCount -> [Var] -> [Var]
zap_em FullArgCount
0 [Var]
bs = [Var]
bs
zap_em FullArgCount
_ [] = []
zap_em FullArgCount
n (Var
b:[Var]
bs) | Var -> Bool
isTyVar Var
b = Var
b forall a. a -> [a] -> [a]
: FullArgCount -> [Var] -> [Var]
zap_em (FullArgCount
nforall a. Num a => a -> a -> a
-FullArgCount
1) [Var]
bs
| Bool
otherwise = Var -> Var
zapLamIdInfo Var
b forall a. a -> [a] -> [a]
: FullArgCount -> [Var] -> [Var]
zap_em (FullArgCount
nforall a. Num a => a -> a -> a
-FullArgCount
1) [Var]
bs
isEmptyTy :: Type -> Bool
isEmptyTy :: Type -> Bool
isEmptyTy Type
ty
| Just (TyCon
tc, [Type]
inst_tys) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
, Just [DataCon]
dcs <- TyCon -> Maybe [DataCon]
tyConDataCons_maybe TyCon
tc
, forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([Type] -> DataCon -> Bool
dataConCannotMatch [Type]
inst_tys) [DataCon]
dcs
= Bool
True
| Bool
otherwise
= Bool
False
collectMakeStaticArgs
:: CoreExpr -> Maybe (CoreExpr, Type, CoreExpr, CoreExpr)
collectMakeStaticArgs :: CoreExpr -> Maybe (CoreExpr, Type, CoreExpr, CoreExpr)
collectMakeStaticArgs CoreExpr
e
| (fun :: CoreExpr
fun@(Var Var
b), [Type Type
t, CoreExpr
loc, CoreExpr
arg], [CoreTickish]
_) <- forall b.
(CoreTickish -> Bool)
-> Expr b -> (Expr b, [Expr b], [CoreTickish])
collectArgsTicks (forall a b. a -> b -> a
const Bool
True) CoreExpr
e
, Var -> Name
idName Var
b forall a. Eq a => a -> a -> Bool
== Name
makeStaticName = forall a. a -> Maybe a
Just (CoreExpr
fun, Type
t, CoreExpr
loc, CoreExpr
arg)
collectMakeStaticArgs CoreExpr
_ = forall a. Maybe a
Nothing
isJoinBind :: CoreBind -> Bool
isJoinBind :: Bind Var -> Bool
isJoinBind (NonRec Var
b CoreExpr
_) = Var -> Bool
isJoinId Var
b
isJoinBind (Rec ((Var
b, CoreExpr
_) : [(Var, CoreExpr)]
_)) = Var -> Bool
isJoinId Var
b
isJoinBind Bind Var
_ = Bool
False
dumpIdInfoOfProgram :: (IdInfo -> SDoc) -> CoreProgram -> SDoc
dumpIdInfoOfProgram :: (IdInfo -> SDoc) -> [Bind Var] -> SDoc
dumpIdInfoOfProgram IdInfo -> SDoc
ppr_id_info [Bind Var]
binds = [SDoc] -> SDoc
vcat (forall a b. (a -> b) -> [a] -> [b]
map Var -> SDoc
printId [Var]
ids)
where
ids :: [Var]
ids = forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Name -> Name -> Ordering
stableNameCmp forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a. NamedThing a => a -> Name
getName) (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a}. Bind a -> [a]
getIds [Bind Var]
binds)
getIds :: Bind a -> [a]
getIds (NonRec a
i Expr a
_) = [ a
i ]
getIds (Rec [(a, Expr a)]
bs) = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(a, Expr a)]
bs
printId :: Var -> SDoc
printId Var
id | Var -> Bool
isExportedId Var
id = forall a. Outputable a => a -> SDoc
ppr Var
id SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<+> (IdInfo -> SDoc
ppr_id_info (HasDebugCallStack => Var -> IdInfo
idInfo Var
id))
| Bool
otherwise = SDoc
empty
isUnsafeEqualityProof :: CoreExpr -> Bool
isUnsafeEqualityProof :: CoreExpr -> Bool
isUnsafeEqualityProof CoreExpr
e
| Var Var
v `App` Type Type
_ `App` Type Type
_ `App` Type Type
_ <- CoreExpr
e
= Var -> Name
idName Var
v forall a. Eq a => a -> a -> Bool
== Name
unsafeEqualityProofName
| Bool
otherwise
= Bool
False