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,
exprIsDupable, exprIsTrivial, getIdFromTrivialExpr,
getIdFromTrivialExpr_maybe,
exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun,
exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprOkForSpecEval,
exprIsWorkFree, exprIsConLike,
isCheapApp, isExpandableApp, isSaturatedConApp,
exprIsTickedString, exprIsTickedString_maybe,
exprIsTopLevelBindable,
altsAreExhaustive, etaExpansionTick,
cheapEqExpr, cheapEqExpr', diffBinds,
exprToType,
applyTypeToArgs,
dataConRepInstPat, dataConRepFSInstPat,
isEmptyTy, normSplitTyConApp_maybe,
stripTicksTop, stripTicksTopE, stripTicksTopT,
stripTicksE, stripTicksT,
mkInScopeSetBndrs, extendInScopeSetBind, extendInScopeSetBndrs,
collectMakeStaticArgs,
isJoinBind,
mkStrictFieldSeqs, shouldStrictifyIdForCbv, shouldUseCbvForId,
isUnsafeEqualityProof,
dumpIdInfoOfProgram
) where
import GHC.Prelude
import GHC.Platform
import GHC.Core
import GHC.Core.Ppr
import GHC.Core.DataCon
import GHC.Core.Type as Type
import GHC.Core.FamInstEnv
import GHC.Core.TyCo.Compare( eqType, eqTypeX )
import GHC.Core.Coercion
import GHC.Core.Reduction
import GHC.Core.TyCon
import GHC.Core.Multiplicity
import GHC.Builtin.Names ( makeStaticName, unsafeEqualityProofIdKey )
import GHC.Builtin.PrimOps
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.Id
import GHC.Types.Id.Info
import GHC.Types.Basic( Arity, Levity(..)
)
import GHC.Types.Unique
import GHC.Types.Unique.Set
import GHC.Types.Demand
import GHC.Data.FastString
import GHC.Data.Maybe
import GHC.Data.List.SetOps( minusList )
import GHC.Data.OrdList
import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
import Data.ByteString ( ByteString )
import Data.Function ( on )
import Data.List ( sort, sortBy, partition, zipWith4, mapAccumL )
import Data.Ord ( comparing )
import qualified Data.Set as Set
import GHC.Types.RepType (isZeroBitTy)
exprType :: HasDebugCallStack => CoreExpr -> Type
exprType :: (() :: Constraint) => CoreExpr -> Type
exprType (Var Id
var) = Id -> Type
idType Id
var
exprType (Lit Literal
lit) = Literal -> Type
literalType Literal
lit
exprType (Coercion Coercion
co) = Coercion -> Type
coercionType Coercion
co
exprType (Let Bind Id
bind CoreExpr
body)
| NonRec Id
tv CoreExpr
rhs <- Bind Id
bind
, Type Type
ty <- CoreExpr
rhs = [Id] -> [Type] -> Type -> Type
substTyWithUnchecked [Id
tv] [Type
ty] ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
body)
| Bool
otherwise = (() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
body
exprType (Case CoreExpr
_ Id
_ Type
ty [Alt Id]
_) = Type
ty
exprType (Cast CoreExpr
_ Coercion
co) = Coercion -> Type
coercionRKind Coercion
co
exprType (Tick CoreTickish
_ CoreExpr
e) = (() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
e
exprType (Lam Id
binder CoreExpr
expr) = (() :: Constraint) => Id -> Type -> Type
Id -> Type -> Type
mkLamType Id
binder ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
expr)
exprType e :: CoreExpr
e@(App CoreExpr
_ CoreExpr
_)
= case CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs CoreExpr
e of
(CoreExpr
fun, [CoreExpr]
args) -> (() :: Constraint) => SDoc -> Type -> [CoreExpr] -> Type
SDoc -> Type -> [CoreExpr] -> Type
applyTypeToArgs (CoreExpr -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr CoreExpr
e) ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
fun) [CoreExpr]
args
exprType CoreExpr
other = String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"exprType" (CoreExpr -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr CoreExpr
other)
coreAltType :: CoreAlt -> Type
coreAltType :: Alt Id -> Type
coreAltType alt :: Alt Id
alt@(Alt AltCon
_ [Id]
bs CoreExpr
rhs)
= case [Id] -> Type -> Maybe Type
occCheckExpand [Id]
bs Type
rhs_ty of
Just Type
ty -> Type
ty
Maybe Type
Nothing -> String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"coreAltType" (Alt Id -> SDoc
forall a. OutputableBndr a => Alt a -> SDoc
pprCoreAlt Alt Id
alt SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
rhs_ty)
where
rhs_ty :: Type
rhs_ty = (() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
rhs
coreAltsType :: [CoreAlt] -> Type
coreAltsType :: [Alt Id] -> Type
coreAltsType (Alt Id
alt:[Alt Id]
_) = Alt Id -> Type
coreAltType Alt Id
alt
coreAltsType [] = String -> Type
forall a. HasCallStack => String -> a
panic String
"coreAltsType"
mkLamType :: HasDebugCallStack => Var -> Type -> Type
mkLamTypes :: [Var] -> Type -> Type
mkLamType :: (() :: Constraint) => Id -> Type -> Type
mkLamType Id
v Type
body_ty
| Id -> Bool
isTyVar Id
v
= ForAllTyBinder -> Type -> Type
mkForAllTy (Id -> ForAllTyFlag -> ForAllTyBinder
forall var argf. var -> argf -> VarBndr var argf
Bndr Id
v ForAllTyFlag
Inferred) Type
body_ty
| Id -> Bool
isCoVar Id
v
, Id
v Id -> VarSet -> Bool
`elemVarSet` Type -> VarSet
tyCoVarsOfType Type
body_ty
= ForAllTyBinder -> Type -> Type
mkForAllTy (Id -> ForAllTyFlag -> ForAllTyBinder
forall var argf. var -> argf -> VarBndr var argf
Bndr Id
v ForAllTyFlag
Required) Type
body_ty
| Bool
otherwise
= (() :: Constraint) => Type -> Type -> Type -> Type
Type -> Type -> Type -> Type
mkFunctionType (Id -> Type
varMult Id
v) (Id -> Type
varType Id
v) Type
body_ty
mkLamTypes :: [Id] -> Type -> Type
mkLamTypes [Id]
vs Type
ty = (Id -> Type -> Type) -> Type -> [Id] -> Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (() :: Constraint) => Id -> Type -> Type
Id -> Type -> Type
mkLamType Type
ty [Id]
vs
applyTypeToArgs :: HasDebugCallStack => SDoc -> Type -> [CoreExpr] -> Type
applyTypeToArgs :: (() :: Constraint) => 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 Coercion
co : [CoreExpr]
args) = Type -> [Type] -> [CoreExpr] -> Type
go_ty_args Type
op_ty [Coercion -> Type
mkCoercionTy Coercion
co] [CoreExpr]
args
go Type
op_ty (CoreExpr
_ : [CoreExpr]
args) | Just (FunTyFlag
_, Type
_, Type
_, Type
res_ty) <- Type -> Maybe (FunTyFlag, Type, Type, Type)
splitFunTy_maybe Type
op_ty
= Type -> [CoreExpr] -> Type
go Type
res_ty [CoreExpr]
args
go Type
_ [CoreExpr]
args = String -> SDoc -> Type
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
tyType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
rev_tys) [CoreExpr]
args
go_ty_args Type
op_ty [Type]
rev_tys (Coercion Coercion
co : [CoreExpr]
args)
= Type -> [Type] -> [CoreExpr] -> Type
go_ty_args Type
op_ty (Coercion -> Type
mkCoercionTy Coercion
co Type -> [Type] -> [Type]
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 ((() :: Constraint) => Type -> [Type] -> Type
Type -> [Type] -> Type
piResultTys Type
op_ty ([Type] -> [Type]
forall a. [a] -> [a]
reverse [Type]
rev_tys)) [CoreExpr]
args
panic_msg :: [CoreExpr] -> SDoc
panic_msg [CoreExpr]
as = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Expression:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
pp_e
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Type:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
op_ty
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Args:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [CoreExpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CoreExpr]
args
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Args':" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [CoreExpr] -> 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 Coercion
co) = CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
e Coercion
co
mkPiMCo :: Var -> MCoercionR -> MCoercionR
mkPiMCo :: Id -> MCoercionR -> MCoercionR
mkPiMCo Id
_ MCoercionR
MRefl = MCoercionR
MRefl
mkPiMCo Id
v (MCo Coercion
co) = Coercion -> MCoercionR
MCo (Role -> Id -> Coercion -> Coercion
mkPiCo Role
Representational Id
v Coercion
co)
mkCast :: HasDebugCallStack => CoreExpr -> CoercionR -> CoreExpr
mkCast :: (() :: Constraint) => CoreExpr -> Coercion -> CoreExpr
mkCast CoreExpr
e Coercion
co
| Bool -> SDoc -> Bool -> Bool
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Coercion -> Role
coercionRole Coercion
co Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
Representational)
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"coercion" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"passed to mkCast"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
e SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"has wrong role" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Role -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Coercion -> Role
coercionRole Coercion
co)) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
Coercion -> Bool
isReflCo Coercion
co
= CoreExpr
e
mkCast (Coercion Coercion
e_co) Coercion
co
| Type -> Bool
isCoVarType (Coercion -> Type
coercionRKind Coercion
co)
= Coercion -> CoreExpr
forall b. Coercion -> Expr b
Coercion (Coercion -> Coercion -> Coercion
mkCoCast Coercion
e_co Coercion
co)
mkCast (Cast CoreExpr
expr Coercion
co2) Coercion
co
= Bool -> String -> SDoc -> CoreExpr -> CoreExpr
forall a. HasCallStack => Bool -> String -> SDoc -> a -> a
warnPprTrace (let { from_ty :: Type
from_ty = Coercion -> Type
coercionLKind Coercion
co;
to_ty2 :: Type
to_ty2 = Coercion -> Type
coercionRKind Coercion
co2 } in
Bool -> Bool
not (Type
from_ty Type -> Type -> Bool
`eqType` Type
to_ty2))
String
"mkCast"
([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"expr:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
expr
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"co2:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co2
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"co:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co ])) (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
(() :: Constraint) => CoreExpr -> Coercion -> CoreExpr
CoreExpr -> Coercion -> CoreExpr
mkCast CoreExpr
expr (Coercion -> Coercion -> Coercion
mkTransCo Coercion
co2 Coercion
co)
mkCast (Tick CoreTickish
t CoreExpr
expr) Coercion
co
= CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t ((() :: Constraint) => CoreExpr -> Coercion -> CoreExpr
CoreExpr -> Coercion -> CoreExpr
mkCast CoreExpr
expr Coercion
co)
mkCast CoreExpr
expr Coercion
co
= let from_ty :: Type
from_ty = Coercion -> Type
coercionLKind Coercion
co in
Bool -> String -> SDoc -> CoreExpr -> CoreExpr
forall a. HasCallStack => Bool -> String -> SDoc -> a -> a
warnPprTrace (Bool -> Bool
not (Type
from_ty Type -> Type -> Bool
`eqType` (() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
expr))
String
"Trying to coerce" (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"(" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
expr
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"::" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
expr) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
")"
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Coercion -> Type
coercionType Coercion
co)
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
HasCallStack => SDoc
callStackDoc) (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
(CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
expr Coercion
co)
mkTick :: CoreTickish -> CoreExpr -> CoreExpr
mkTick :: CoreTickish -> CoreExpr -> CoreExpr
mkTick CoreTickish
t CoreExpr
orig_expr = (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
mkTick' CoreExpr -> CoreExpr
forall a. a -> a
id CoreExpr -> CoreExpr
forall a. a -> a
id CoreExpr
orig_expr
where
canSplit :: Bool
canSplit = CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishCanSplit CoreTickish
t Bool -> Bool -> Bool
&& CoreTickish -> TickishPlacement
forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
tickishPlace (CoreTickish -> CoreTickish
forall (pass :: TickishPass). GenTickish pass -> GenTickish pass
mkNoCount CoreTickish
t) TickishPlacement -> TickishPlacement -> Bool
forall a. Eq a => a -> a -> Bool
/= CoreTickish -> TickishPlacement
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 (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr
rest CoreExpr
expr
| CoreTickish -> TickishPlacement
forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
tickishPlace CoreTickish
t2 TickishPlacement -> TickishPlacement -> Bool
forall a. Eq a => a -> a -> Bool
/= CoreTickish -> TickishPlacement
forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
tickishPlace CoreTickish
t -> (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
mkTick' (CoreExpr -> CoreExpr
top (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t2) CoreExpr -> CoreExpr
rest CoreExpr
e
| CoreTickish -> CoreTickish -> Bool
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
| CoreTickish -> CoreTickish -> Bool
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 (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t2) CoreExpr
e
Cast CoreExpr
e Coercion
co -> (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
mkTick' (CoreExpr -> CoreExpr
top (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CoreExpr -> Coercion -> CoreExpr)
-> Coercion -> CoreExpr -> CoreExpr
forall a b c. (a -> b -> c) -> b -> a -> c
flip CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast Coercion
co) CoreExpr -> CoreExpr
rest CoreExpr
e
Coercion Coercion
co -> Coercion -> CoreExpr
forall b. Coercion -> Expr b
Coercion Coercion
co
Lam Id
x CoreExpr
e
| Bool -> Bool
not (Id -> Bool
isRuntimeVar Id
x) Bool -> Bool -> Bool
|| CoreTickish -> TickishPlacement
forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
tickishPlace CoreTickish
t TickishPlacement -> TickishPlacement -> Bool
forall a. Eq a => a -> a -> Bool
/= TickishPlacement
PlaceRuntime
-> (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
mkTick' (CoreExpr -> CoreExpr
top (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
x) CoreExpr -> CoreExpr
rest CoreExpr
e
| Bool
canSplit
-> CoreExpr -> CoreExpr
top (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick (CoreTickish -> CoreTickish
forall (pass :: TickishPass). GenTickish pass -> GenTickish pass
mkNoScope CoreTickish
t) (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr
rest (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
x (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreTickish -> CoreExpr -> CoreExpr
mkTick (CoreTickish -> CoreTickish
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 (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CoreExpr -> CoreExpr -> CoreExpr)
-> CoreExpr -> CoreExpr -> CoreExpr
forall a b c. (a -> b -> c) -> b -> a -> c
flip CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
arg) CoreExpr -> CoreExpr
rest CoreExpr
f
| CoreExpr -> Bool
isSaturatedConApp CoreExpr
expr Bool -> Bool -> Bool
&& (CoreTickish -> TickishPlacement
forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
tickishPlace CoreTickish
tTickishPlacement -> TickishPlacement -> Bool
forall a. Eq a => a -> a -> Bool
==TickishPlacement
PlaceCostCentre Bool -> Bool -> Bool
|| Bool
canSplit)
-> if CoreTickish -> TickishPlacement
forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
tickishPlace CoreTickish
t TickishPlacement -> TickishPlacement -> Bool
forall a. Eq a => a -> a -> Bool
== TickishPlacement
PlaceCostCentre
then CoreExpr -> CoreExpr
top (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr
rest (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreTickish -> CoreExpr -> CoreExpr
tickHNFArgs CoreTickish
t CoreExpr
expr
else CoreExpr -> CoreExpr
top (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick (CoreTickish -> CoreTickish
forall (pass :: TickishPass). GenTickish pass -> GenTickish pass
mkNoScope CoreTickish
t) (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr
rest (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreTickish -> CoreExpr -> CoreExpr
tickHNFArgs (CoreTickish -> CoreTickish
forall (pass :: TickishPass). GenTickish pass -> GenTickish pass
mkNoCount CoreTickish
t) CoreExpr
expr
Var Id
x
| Bool
notFunction Bool -> Bool -> Bool
&& CoreTickish -> TickishPlacement
forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
tickishPlace CoreTickish
t TickishPlacement -> TickishPlacement -> Bool
forall a. Eq a => a -> a -> Bool
== TickishPlacement
PlaceCostCentre
-> CoreExpr
orig_expr
| Bool
notFunction Bool -> Bool -> Bool
&& Bool
canSplit
-> CoreExpr -> CoreExpr
top (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick (CoreTickish -> CoreTickish
forall (pass :: TickishPass). GenTickish pass -> GenTickish pass
mkNoScope CoreTickish
t) (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr
rest CoreExpr
expr
where
notFunction :: Bool
notFunction = Bool -> Bool
not (Type -> Bool
isFunTy (Id -> Type
idType Id
x))
Lit{}
| CoreTickish -> TickishPlacement
forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
tickishPlace CoreTickish
t TickishPlacement -> TickishPlacement -> Bool
forall a. Eq a => a -> a -> Bool
== TickishPlacement
PlaceCostCentre
-> CoreExpr
orig_expr
CoreExpr
_any -> CoreExpr -> CoreExpr
top (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
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 = (CoreTickish -> CoreExpr -> CoreExpr)
-> CoreExpr -> [CoreTickish] -> CoreExpr
forall a b. (a -> b -> b) -> b -> [a] -> b
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 = CoreExpr -> [CoreExpr] -> Bool
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
aExpr b -> [Expr b] -> [Expr b]
forall a. a -> [a] -> [a]
:[Expr b]
as)
go (Var Id
fun) [Expr b]
args
= Id -> Bool
isConLikeId Id
fun Bool -> Bool -> Bool
&& Id -> Int
idArity Id
fun Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Expr b] -> Int
forall b. [Arg b] -> Int
valArgCount [Expr b]
args
go (Cast Expr b
f Coercion
_) [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)) = CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (CoreTickish -> CoreExpr -> CoreExpr
push CoreTickish
t CoreExpr
f) (Type -> CoreExpr
forall b. Type -> Expr b
Type Type
u)
push CoreTickish
t (App CoreExpr
f CoreExpr
arg) = CoreExpr -> CoreExpr -> CoreExpr
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
tCoreTickish -> [CoreTickish] -> [CoreTickish]
forall a. a -> [a] -> [a]
:[CoreTickish]
ts) Expr b
e
go [CoreTickish]
ts Expr b
other = ([CoreTickish] -> [CoreTickish]
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
tCoreTickish -> [CoreTickish] -> [CoreTickish]
forall 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) = Expr b -> Expr b -> Expr b
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) = b -> Expr b -> Expr b
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) = Bind b -> Expr b -> Expr b
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) = Expr b -> b -> Type -> [Alt b] -> Expr b
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (Expr b -> Expr b
go Expr b
e) b
b Type
t ((Alt b -> Alt b) -> [Alt b] -> [Alt b]
forall a b. (a -> b) -> [a] -> [b]
map Alt b -> Alt b
go_a [Alt b]
as)
go (Cast Expr b
e Coercion
c) = Expr b -> Coercion -> Expr b
forall b. Expr b -> Coercion -> Expr b
Cast (Expr b -> Expr b
go Expr b
e) Coercion
c
go (Tick CoreTickish
t Expr b
e)
| CoreTickish -> Bool
p CoreTickish
t = Expr b -> Expr b
go Expr b
e
| Bool
otherwise = CoreTickish -> Expr b -> Expr b
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) = b -> Expr b -> Bind b
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) = [(b, Expr b)] -> Bind b
forall b. [(b, Expr b)] -> Bind b
Rec (((b, Expr b) -> (b, Expr b)) -> [(b, Expr b)] -> [(b, Expr b)]
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) = AltCon -> [b] -> Expr b -> Alt b
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 = OrdList CoreTickish -> [CoreTickish]
forall a. OrdList a -> [a]
fromOL (OrdList CoreTickish -> [CoreTickish])
-> OrdList CoreTickish -> [CoreTickish]
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 OrdList CoreTickish -> OrdList CoreTickish -> OrdList CoreTickish
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 OrdList CoreTickish -> OrdList CoreTickish -> OrdList CoreTickish
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 OrdList CoreTickish -> OrdList CoreTickish -> OrdList CoreTickish
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [OrdList CoreTickish] -> OrdList CoreTickish
forall a. [OrdList a] -> OrdList a
concatOL ((Alt b -> OrdList CoreTickish) -> [Alt b] -> [OrdList CoreTickish]
forall a b. (a -> b) -> [a] -> [b]
map Alt b -> OrdList CoreTickish
go_a [Alt b]
as)
go (Cast Expr b
e Coercion
_) = Expr b -> OrdList CoreTickish
go Expr b
e
go (Tick CoreTickish
t Expr b
e)
| CoreTickish -> Bool
p CoreTickish
t = CoreTickish
t CoreTickish -> OrdList CoreTickish -> OrdList CoreTickish
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
_ = OrdList CoreTickish
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) = [OrdList CoreTickish] -> OrdList CoreTickish
forall a. [OrdList a] -> OrdList a
concatOL (((b, Expr b) -> OrdList CoreTickish)
-> [(b, Expr b)] -> [OrdList CoreTickish]
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 :: HasDebugCallStack => Id -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec :: (() :: Constraint) => Id -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec Id
bndr CoreExpr
rhs CoreExpr
body
| Id -> Bool
isTyVar Id
bndr = CoreExpr
let_bind
| Id -> Bool
isCoVar Id
bndr = if CoreExpr -> Bool
forall b. Expr b -> Bool
isCoArg CoreExpr
rhs then CoreExpr
let_bind
else CoreExpr
case_bind
| Id -> Bool
isJoinId Id
bndr = CoreExpr
let_bind
| Type -> CoreExpr -> Bool
needsCaseBinding (Id -> Type
idType Id
bndr) CoreExpr
rhs = CoreExpr
case_bind
| Bool
otherwise = CoreExpr
let_bind
where
case_bind :: CoreExpr
case_bind = CoreExpr -> Id -> CoreExpr -> CoreExpr
mkDefaultCase CoreExpr
rhs Id
bndr CoreExpr
body
let_bind :: CoreExpr
let_bind = Bind Id -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let (Id -> CoreExpr -> Bind Id
forall b. b -> Expr b -> Bind b
NonRec Id
bndr CoreExpr
rhs) CoreExpr
body
needsCaseBinding :: Type -> CoreExpr -> Bool
needsCaseBinding :: Type -> CoreExpr -> Bool
needsCaseBinding Type
ty CoreExpr
rhs =
Type -> Bool
mightBeUnliftedType Type
ty Bool -> Bool -> Bool
&& Bool -> Bool
not (CoreExpr -> Bool
exprOkForSpeculation CoreExpr
rhs)
mkAltExpr :: AltCon
-> [CoreBndr]
-> [Type]
-> CoreExpr
mkAltExpr :: AltCon -> [Id] -> [Type] -> CoreExpr
mkAltExpr (DataAlt DataCon
con) [Id]
args [Type]
inst_tys
= DataCon -> [CoreExpr] -> CoreExpr
forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
con ((Type -> CoreExpr) -> [Type] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Type -> CoreExpr
forall b. Type -> Expr b
Type [Type]
inst_tys [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++ [Id] -> [CoreExpr]
forall b. [Id] -> [Expr b]
varsToCoreExprs [Id]
args)
mkAltExpr (LitAlt Literal
lit) [] []
= Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
lit
mkAltExpr (LitAlt Literal
_) [Id]
_ [Type]
_ = String -> CoreExpr
forall a. HasCallStack => String -> a
panic String
"mkAltExpr LitAlt"
mkAltExpr AltCon
DEFAULT [Id]
_ [Type]
_ = String -> CoreExpr
forall a. HasCallStack => String -> a
panic String
"mkAltExpr DEFAULT"
mkDefaultCase :: CoreExpr -> Id -> CoreExpr -> CoreExpr
mkDefaultCase :: CoreExpr -> Id -> CoreExpr -> CoreExpr
mkDefaultCase CoreExpr
scrut Id
case_bndr CoreExpr
body
= CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
scrut Id
case_bndr ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
body) [AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] CoreExpr
body]
mkSingleAltCase :: CoreExpr -> Id -> AltCon -> [Var] -> CoreExpr -> CoreExpr
mkSingleAltCase :: CoreExpr -> Id -> AltCon -> [Id] -> CoreExpr -> CoreExpr
mkSingleAltCase CoreExpr
scrut Id
case_bndr AltCon
con [Id]
bndrs CoreExpr
body
= CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
scrut Id
case_bndr Type
case_ty [AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [Id]
bndrs CoreExpr
body]
where
body_ty :: Type
body_ty = (() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
body
case_ty :: Type
case_ty
| Just Type
body_ty' <- [Id] -> Type -> Maybe Type
occCheckExpand [Id]
bndrs Type
body_ty
= Type
body_ty'
| Bool
otherwise
= String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkSingleAltCase" (CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
scrut SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
bndrs SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Type -> 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) = Bool -> ([Alt b], Maybe (Expr b)) -> ([Alt b], Maybe (Expr b))
forall a. HasCallStack => Bool -> a -> a
assert ([b] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [b]
args) ([Alt b]
alts, Expr b -> Maybe (Expr b)
forall a. a -> Maybe a
Just Expr b
rhs)
findDefault [Alt b]
alts = ([Alt b]
alts, Maybe (Expr b)
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) = AltCon -> [b] -> Expr b -> Alt b
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] Expr b
rhs Alt b -> [Alt b] -> [Alt b]
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 (Alt b -> Maybe (Alt b)
forall a. a -> Maybe a
Just Alt b
deflt)
[Alt b]
_ -> [Alt b] -> Maybe (Alt b) -> Maybe (Alt b)
go [Alt b]
alts Maybe (Alt b)
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 -> Alt b -> Maybe (Alt b)
forall a. a -> Maybe a
Just Alt b
alt
Ordering
GT -> Bool -> Maybe (Alt b) -> Maybe (Alt b)
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (AltCon
con1 AltCon -> AltCon -> Bool
forall a. Eq a => a -> a -> Bool
== AltCon
DEFAULT)) (Maybe (Alt b) -> Maybe (Alt b)) -> Maybe (Alt b) -> Maybe (Alt b)
forall a b. (a -> b) -> a -> b
$ [Alt b] -> Maybe (Alt b) -> Maybe (Alt b)
go [Alt b]
alts Maybe (Alt b)
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 Alt a -> Alt a -> Ordering
forall a. Alt a -> Alt a -> Ordering
`cmpAlt` Alt a
a2 of
Ordering
LT -> Alt a
a1 Alt a -> [Alt a] -> [Alt a]
forall a. a -> [a] -> [a]
: [Alt a] -> [Alt a] -> [Alt a]
forall a. [Alt a] -> [Alt a] -> [Alt a]
mergeAlts [Alt a]
as1 (Alt a
a2Alt a -> [Alt a] -> [Alt a]
forall a. a -> [a] -> [a]
:[Alt a]
as2)
Ordering
EQ -> Alt a
a1 Alt a -> [Alt a] -> [Alt a]
forall a. a -> [a] -> [a]
: [Alt a] -> [Alt a] -> [Alt a]
forall a. [Alt a] -> [Alt a] -> [Alt a]
mergeAlts [Alt a]
as1 [Alt a]
as2
Ordering
GT -> Alt a
a2 Alt a -> [Alt a] -> [Alt a]
forall a. a -> [a] -> [a]
: [Alt a] -> [Alt a] -> [Alt a]
forall a. [Alt a] -> [Alt a] -> [Alt a]
mergeAlts (Alt a
a1Alt a -> [Alt a] -> [Alt a]
forall a. a -> [a] -> [a]
:[Alt a]
as1) [Alt a]
as2
trimConArgs :: AltCon -> [CoreArg] -> [CoreArg]
trimConArgs :: AltCon -> [CoreExpr] -> [CoreExpr]
trimConArgs AltCon
DEFAULT [CoreExpr]
args = Bool -> [CoreExpr] -> [CoreExpr]
forall a. HasCallStack => Bool -> a -> a
assert ([CoreExpr] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreExpr]
args) []
trimConArgs (LitAlt Literal
_) [CoreExpr]
args = Bool -> [CoreExpr] -> [CoreExpr]
forall a. HasCallStack => Bool -> a -> a
assert ([CoreExpr] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreExpr]
args) []
trimConArgs (DataAlt DataCon
dc) [CoreExpr]
args = [Id] -> [CoreExpr] -> [CoreExpr]
forall b a. [b] -> [a] -> [a]
dropList (DataCon -> [Id]
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 [AltCon] -> ([AltCon], [Alt b]) -> ([AltCon], [Alt b])
forall a b. [a] -> b -> b
`seqList`
([AltCon]
imposs_deflt_cons, [Alt b] -> Maybe (Expr b) -> [Alt b]
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) = [Alt b] -> ([Alt b], Maybe (Expr b))
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 = (Alt b -> Bool) -> [Alt b] -> [Alt b]
forall a. (a -> Bool) -> [a] -> [a]
filterOut ([Type] -> Alt b -> Bool
forall b. [Type] -> Alt b -> Bool
impossible_alt [Type]
inst_tys) [Alt b]
alts_wo_default
imposs_cons_set :: Set AltCon
imposs_cons_set = [AltCon] -> Set AltCon
forall a. Ord a => [a] -> Set a
Set.fromList [AltCon]
imposs_cons
imposs_deflt_cons :: [AltCon]
imposs_deflt_cons =
[AltCon]
imposs_cons [AltCon] -> [AltCon] -> [AltCon]
forall a. [a] -> [a] -> [a]
++ (AltCon -> Bool) -> [AltCon] -> [AltCon]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (AltCon -> Set AltCon -> Bool
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 AltCon -> Set AltCon -> Bool
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 Id]
-> (Bool, [Alt Id])
refineDefaultAlt [Unique]
us Type
mult TyCon
tycon [Type]
tys [AltCon]
imposs_deflt_cons [Alt Id]
all_alts
| Alt AltCon
DEFAULT [Id]
_ CoreExpr
rhs : [Alt Id]
rest_alts <- [Alt Id]
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 = [DataCon] -> UniqSet DataCon
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 DataCon -> UniqSet DataCon -> Bool
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 (DataCon -> Bool) -> [DataCon] -> [DataCon]
forall a. (a -> Bool) -> [a] -> [a]
filterOut DataCon -> Bool
impossible [DataCon]
all_cons of
[] -> (Bool
False, [Alt Id]
rest_alts)
[DataCon
con] -> (Bool
True, [Alt Id] -> [Alt Id] -> [Alt Id]
forall a. [Alt a] -> [Alt a] -> [Alt a]
mergeAlts [Alt Id]
rest_alts [AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
con) ([Id]
ex_tvs [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
arg_ids) CoreExpr
rhs])
where
([Id]
ex_tvs, [Id]
arg_ids) = [Unique] -> Type -> DataCon -> [Type] -> ([Id], [Id])
dataConRepInstPat [Unique]
us Type
mult DataCon
con [Type]
tys
[DataCon]
_ -> (Bool
False, [Alt Id]
all_alts)
| Bool
debugIsOn, TyCon -> Bool
isAlgTyCon TyCon
tycon, [DataCon] -> Bool
forall a. [a] -> Bool
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 Id]
all_alts)
| Bool
otherwise
= (Bool
False, [Alt Id]
all_alts)
combineIdenticalAlts :: [AltCon]
-> [CoreAlt]
-> (Bool,
[AltCon],
[CoreAlt])
combineIdenticalAlts :: [AltCon] -> [Alt Id] -> (Bool, [AltCon], [Alt Id])
combineIdenticalAlts [AltCon]
imposs_deflt_cons (Alt AltCon
con1 [Id]
bndrs1 CoreExpr
rhs1 : [Alt Id]
rest_alts)
| (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Id -> Bool
isDeadBinder [Id]
bndrs1
, Bool -> Bool
not ([Alt Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Alt Id]
elim_rest)
= (Bool
True, [AltCon]
imposs_deflt_cons', Alt Id
deflt_alt Alt Id -> [Alt Id] -> [Alt Id]
forall a. a -> [a] -> [a]
: [Alt Id]
filtered_rest)
where
([Alt Id]
elim_rest, [Alt Id]
filtered_rest) = (Alt Id -> Bool) -> [Alt Id] -> ([Alt Id], [Alt Id])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Alt Id -> Bool
identical_to_alt1 [Alt Id]
rest_alts
deflt_alt :: Alt Id
deflt_alt = AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] ([CoreTickish] -> CoreExpr -> CoreExpr
mkTicks ([[CoreTickish]] -> [CoreTickish]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[CoreTickish]]
tickss) CoreExpr
rhs1)
imposs_deflt_cons' :: [AltCon]
imposs_deflt_cons' = [AltCon]
imposs_deflt_cons [AltCon] -> [AltCon] -> [AltCon]
forall a. Ord a => [a] -> [a] -> [a]
`minusList` [AltCon]
elim_cons
elim_cons :: [AltCon]
elim_cons = [AltCon]
elim_con1 [AltCon] -> [AltCon] -> [AltCon]
forall a. [a] -> [a] -> [a]
++ (Alt Id -> AltCon) -> [Alt Id] -> [AltCon]
forall a b. (a -> b) -> [a] -> [b]
map (\(Alt AltCon
con [Id]
_ CoreExpr
_) -> AltCon
con) [Alt Id]
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 = (CoreTickish -> Bool) -> Expr b -> Expr b -> Bool
forall b. (CoreTickish -> Bool) -> Expr b -> Expr b -> Bool
cheapEqExpr' CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable Expr b
e1 Expr b
e2
identical_to_alt1 :: Alt Id -> Bool
identical_to_alt1 (Alt AltCon
_con [Id]
bndrs CoreExpr
rhs)
= (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Id -> Bool
isDeadBinder [Id]
bndrs Bool -> Bool -> Bool
&& CoreExpr
rhs CoreExpr -> CoreExpr -> Bool
forall {b}. Expr b -> Expr b -> Bool
`cheapEqTicked` CoreExpr
rhs1
tickss :: [[CoreTickish]]
tickss = (Alt Id -> [CoreTickish]) -> [Alt Id] -> [[CoreTickish]]
forall a b. (a -> b) -> [a] -> [b]
map (\(Alt AltCon
_ [Id]
_ CoreExpr
rhs) -> (CoreTickish -> Bool) -> CoreExpr -> [CoreTickish]
forall b. (CoreTickish -> Bool) -> Expr b -> [CoreTickish]
stripTicksT CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable CoreExpr
rhs) [Alt Id]
elim_rest
combineIdenticalAlts [AltCon]
imposs_cons [Alt Id]
alts
= (Bool
False, [AltCon]
imposs_cons, [Alt Id]
alts)
scaleAltsBy :: Mult -> [CoreAlt] -> [CoreAlt]
scaleAltsBy :: Type -> [Alt Id] -> [Alt Id]
scaleAltsBy Type
w [Alt Id]
alts = (Alt Id -> Alt Id) -> [Alt Id] -> [Alt Id]
forall a b. (a -> b) -> [a] -> [b]
map Alt Id -> Alt Id
scaleAlt [Alt Id]
alts
where
scaleAlt :: CoreAlt -> CoreAlt
scaleAlt :: Alt Id -> Alt Id
scaleAlt (Alt AltCon
con [Id]
bndrs CoreExpr
rhs) = AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con ((Id -> Id) -> [Id] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Id
scaleBndr [Id]
bndrs) CoreExpr
rhs
scaleBndr :: CoreBndr -> CoreBndr
scaleBndr :: Id -> Id
scaleBndr Id
b = Type -> Id -> Id
scaleVarBy Type
w Id
b
exprIsTrivial :: CoreExpr -> Bool
exprIsTrivial :: CoreExpr -> Bool
exprIsTrivial (Var Id
_) = Bool
True
exprIsTrivial (Type Type
_) = Bool
True
exprIsTrivial (Coercion Coercion
_) = 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 Id
b CoreExpr
e) = Bool -> Bool
not (Id -> Bool
isRuntimeVar Id
b) Bool -> Bool -> Bool
&& CoreExpr -> Bool
exprIsTrivial CoreExpr
e
exprIsTrivial (Tick CoreTickish
t CoreExpr
e) = Bool -> Bool
not (CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode CoreTickish
t) Bool -> Bool -> Bool
&& CoreExpr -> Bool
exprIsTrivial CoreExpr
e
exprIsTrivial (Cast CoreExpr
e Coercion
_) = CoreExpr -> Bool
exprIsTrivial CoreExpr
e
exprIsTrivial (Case CoreExpr
e Id
_ Type
_ []) = CoreExpr -> Bool
exprIsTrivial CoreExpr
e
exprIsTrivial CoreExpr
_ = Bool
False
getIdFromTrivialExpr :: HasDebugCallStack => CoreExpr -> Id
getIdFromTrivialExpr :: (() :: Constraint) => CoreExpr -> Id
getIdFromTrivialExpr CoreExpr
e
= Id -> Maybe Id -> Id
forall a. a -> Maybe a -> a
fromMaybe (String -> SDoc -> Id
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getIdFromTrivialExpr" (CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
e))
(CoreExpr -> Maybe Id
getIdFromTrivialExpr_maybe CoreExpr
e)
getIdFromTrivialExpr_maybe :: CoreExpr -> Maybe Id
getIdFromTrivialExpr_maybe :: CoreExpr -> Maybe Id
getIdFromTrivialExpr_maybe CoreExpr
e
= CoreExpr -> Maybe Id
go CoreExpr
e
where
go :: CoreExpr -> Maybe Id
go (App CoreExpr
f CoreExpr
t) | Bool -> Bool
not (CoreExpr -> Bool
isRuntimeArg CoreExpr
t) = CoreExpr -> Maybe Id
go CoreExpr
f
go (Tick CoreTickish
t CoreExpr
e) | Bool -> Bool
not (CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode CoreTickish
t) = CoreExpr -> Maybe Id
go CoreExpr
e
go (Cast CoreExpr
e Coercion
_) = CoreExpr -> Maybe Id
go CoreExpr
e
go (Lam Id
b CoreExpr
e) | Bool -> Bool
not (Id -> Bool
isRuntimeVar Id
b) = CoreExpr -> Maybe Id
go CoreExpr
e
go (Case CoreExpr
e Id
_ Type
_ []) = CoreExpr -> Maybe Id
go CoreExpr
e
go (Var Id
v) = Id -> Maybe Id
forall a. a -> Maybe a
Just Id
v
go CoreExpr
_ = Maybe Id
forall a. Maybe a
Nothing
exprIsDupable :: Platform -> CoreExpr -> Bool
exprIsDupable :: Platform -> CoreExpr -> Bool
exprIsDupable Platform
platform CoreExpr
e
= Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (Int -> CoreExpr -> Maybe Int
go Int
dupAppSize CoreExpr
e)
where
go :: Int -> CoreExpr -> Maybe Int
go :: Int -> CoreExpr -> Maybe Int
go Int
n (Type {}) = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n
go Int
n (Coercion {}) = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n
go Int
n (Var {}) = Int -> Maybe Int
decrement Int
n
go Int
n (Tick CoreTickish
_ CoreExpr
e) = Int -> CoreExpr -> Maybe Int
go Int
n CoreExpr
e
go Int
n (Cast CoreExpr
e Coercion
_) = Int -> CoreExpr -> Maybe Int
go Int
n CoreExpr
e
go Int
n (App CoreExpr
f CoreExpr
a) | Just Int
n' <- Int -> CoreExpr -> Maybe Int
go Int
n CoreExpr
a = Int -> CoreExpr -> Maybe Int
go Int
n' CoreExpr
f
go Int
n (Lit Literal
lit) | Platform -> Literal -> Bool
litIsDupable Platform
platform Literal
lit = Int -> Maybe Int
decrement Int
n
go Int
_ CoreExpr
_ = Maybe Int
forall a. Maybe a
Nothing
decrement :: Int -> Maybe Int
decrement :: Int -> Maybe Int
decrement Int
0 = Maybe Int
forall a. Maybe a
Nothing
decrement Int
n = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
dupAppSize :: Int
dupAppSize :: Int
dupAppSize = Int
8
exprIsWorkFree :: CoreExpr -> Bool
exprIsWorkFree :: CoreExpr -> Bool
exprIsWorkFree CoreExpr
e = CheapAppFun -> CoreExpr -> Bool
exprIsCheapX CheapAppFun
isWorkFreeApp CoreExpr
e
exprIsCheap :: CoreExpr -> Bool
exprIsCheap :: CoreExpr -> Bool
exprIsCheap CoreExpr
e = CheapAppFun -> CoreExpr -> Bool
exprIsCheapX CheapAppFun
isCheapApp CoreExpr
e
exprIsCheapX :: CheapAppFun -> CoreExpr -> Bool
{-# INLINE exprIsCheapX #-}
exprIsCheapX :: CheapAppFun -> CoreExpr -> Bool
exprIsCheapX CheapAppFun
ok_app CoreExpr
e
= CoreExpr -> Bool
ok CoreExpr
e
where
ok :: CoreExpr -> Bool
ok CoreExpr
e = Int -> CoreExpr -> Bool
go Int
0 CoreExpr
e
go :: Int -> CoreExpr -> Bool
go Int
n (Var Id
v) = CheapAppFun
ok_app Id
v Int
n
go Int
_ (Lit {}) = Bool
True
go Int
_ (Type {}) = Bool
True
go Int
_ (Coercion {}) = Bool
True
go Int
n (Cast CoreExpr
e Coercion
_) = Int -> CoreExpr -> Bool
go Int
n CoreExpr
e
go Int
n (Case CoreExpr
scrut Id
_ Type
_ [Alt Id]
alts) = CoreExpr -> Bool
ok CoreExpr
scrut Bool -> Bool -> Bool
&&
[Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ Int -> CoreExpr -> Bool
go Int
n CoreExpr
rhs | Alt AltCon
_ [Id]
_ CoreExpr
rhs <- [Alt Id]
alts ]
go Int
n (Tick CoreTickish
t CoreExpr
e) | CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishCounts CoreTickish
t = Bool
False
| Bool
otherwise = Int -> CoreExpr -> Bool
go Int
n CoreExpr
e
go Int
n (Lam Id
x CoreExpr
e) | Id -> Bool
isRuntimeVar Id
x = Int
nInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0 Bool -> Bool -> Bool
|| Int -> CoreExpr -> Bool
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) CoreExpr
e
| Bool
otherwise = Int -> CoreExpr -> Bool
go Int
n CoreExpr
e
go Int
n (App CoreExpr
f CoreExpr
e) | CoreExpr -> Bool
isRuntimeArg CoreExpr
e = Int -> CoreExpr -> Bool
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) CoreExpr
f Bool -> Bool -> Bool
&& CoreExpr -> Bool
ok CoreExpr
e
| Bool
otherwise = Int -> CoreExpr -> Bool
go Int
n CoreExpr
f
go Int
n (Let (NonRec Id
_ CoreExpr
r) CoreExpr
e) = Int -> CoreExpr -> Bool
go Int
n CoreExpr
e Bool -> Bool -> Bool
&& CoreExpr -> Bool
ok CoreExpr
r
go Int
n (Let (Rec [(Id, CoreExpr)]
prs) CoreExpr
e) = Int -> CoreExpr -> Bool
go Int
n CoreExpr
e Bool -> Bool -> Bool
&& ((Id, CoreExpr) -> Bool) -> [(Id, CoreExpr)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (CoreExpr -> Bool
ok (CoreExpr -> Bool)
-> ((Id, CoreExpr) -> CoreExpr) -> (Id, CoreExpr) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id, CoreExpr) -> CoreExpr
forall a b. (a, b) -> b
snd) [(Id, CoreExpr)]
prs
exprIsExpandable :: CoreExpr -> Bool
exprIsExpandable :: CoreExpr -> Bool
exprIsExpandable CoreExpr
e
= CoreExpr -> Bool
ok CoreExpr
e
where
ok :: CoreExpr -> Bool
ok CoreExpr
e = Int -> CoreExpr -> Bool
go Int
0 CoreExpr
e
go :: Int -> CoreExpr -> Bool
go Int
n (Var Id
v) = CheapAppFun
isExpandableApp Id
v Int
n
go Int
_ (Lit {}) = Bool
True
go Int
_ (Type {}) = Bool
True
go Int
_ (Coercion {}) = Bool
True
go Int
n (Cast CoreExpr
e Coercion
_) = Int -> CoreExpr -> Bool
go Int
n CoreExpr
e
go Int
n (Tick CoreTickish
t CoreExpr
e) | CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishCounts CoreTickish
t = Bool
False
| Bool
otherwise = Int -> CoreExpr -> Bool
go Int
n CoreExpr
e
go Int
n (Lam Id
x CoreExpr
e) | Id -> Bool
isRuntimeVar Id
x = Int
nInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0 Bool -> Bool -> Bool
|| Int -> CoreExpr -> Bool
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) CoreExpr
e
| Bool
otherwise = Int -> CoreExpr -> Bool
go Int
n CoreExpr
e
go Int
n (App CoreExpr
f CoreExpr
e) | CoreExpr -> Bool
isRuntimeArg CoreExpr
e = Int -> CoreExpr -> Bool
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) CoreExpr
f Bool -> Bool -> Bool
&& CoreExpr -> Bool
ok CoreExpr
e
| Bool
otherwise = Int -> CoreExpr -> Bool
go Int
n CoreExpr
f
go Int
_ (Case {}) = Bool
False
go Int
_ (Let {}) = Bool
False
type CheapAppFun = Id -> Arity -> Bool
isWorkFreeApp :: CheapAppFun
isWorkFreeApp :: CheapAppFun
isWorkFreeApp Id
fn Int
n_val_args
| Int
n_val_args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
= Bool
True
| Int
n_val_args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Id -> Int
idArity Id
fn
= Bool
True
| Bool
otherwise
= case Id -> IdDetails
idDetails Id
fn of
DataConWorkId {} -> Bool
True
IdDetails
_ -> Bool
False
isCheapApp :: CheapAppFun
isCheapApp :: CheapAppFun
isCheapApp Id
fn Int
n_val_args
| CheapAppFun
isWorkFreeApp Id
fn Int
n_val_args = Bool
True
| Id -> Bool
isDeadEndId Id
fn = Bool
True
| Bool
otherwise
= case Id -> IdDetails
idDetails Id
fn of
DataConWorkId {} -> Bool
True
RecSelId {} -> Int
n_val_args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
ClassOpId {} -> Int
n_val_args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
PrimOpId PrimOp
op Bool
_ -> PrimOp -> Bool
primOpIsCheap PrimOp
op
IdDetails
_ -> Bool
False
isExpandableApp :: CheapAppFun
isExpandableApp :: CheapAppFun
isExpandableApp Id
fn Int
n_val_args
| CheapAppFun
isWorkFreeApp Id
fn Int
n_val_args = Bool
True
| Bool
otherwise
= case Id -> IdDetails
idDetails Id
fn of
RecSelId {} -> Int
n_val_args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
ClassOpId {} -> Int
n_val_args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
PrimOpId {} -> Bool
False
IdDetails
_ | Id -> Bool
isDeadEndId Id
fn -> Bool
False
| Id -> Bool
isConLikeId Id
fn -> Bool
True
| Bool
all_args_are_preds -> Bool
True
| Bool
otherwise -> Bool
False
where
all_args_are_preds :: Bool
all_args_are_preds = Int -> Type -> Bool
forall {t}. (Eq t, Num t) => t -> Type -> Bool
all_pred_args Int
n_val_args (Id -> Type
idType Id
fn)
all_pred_args :: t -> Type -> Bool
all_pred_args t
n_val_args Type
ty
| t
n_val_args t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
0
= Bool
True
| Just (PiTyBinder
bndr, Type
ty) <- Type -> Maybe (PiTyBinder, Type)
splitPiTy_maybe Type
ty
= case PiTyBinder
bndr of
Named {} -> t -> Type -> Bool
all_pred_args t
n_val_args Type
ty
Anon Scaled Type
_ FunTyFlag
af -> FunTyFlag -> Bool
isInvisibleFunArg FunTyFlag
af Bool -> Bool -> Bool
&& t -> Type -> Bool
all_pred_args (t
n_val_argst -> t -> t
forall a. Num a => a -> a -> a
-t
1) Type
ty
| Bool
otherwise
= Bool
False
exprOkForSpeculation, exprOkForSideEffects :: CoreExpr -> Bool
exprOkForSpeculation :: CoreExpr -> Bool
exprOkForSpeculation = (Id -> Bool) -> (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok Id -> Bool
fun_always_ok PrimOp -> Bool
primOpOkForSpeculation
exprOkForSideEffects :: CoreExpr -> Bool
exprOkForSideEffects = (Id -> Bool) -> (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok Id -> Bool
fun_always_ok PrimOp -> Bool
primOpOkForSideEffects
fun_always_ok :: Id -> Bool
fun_always_ok :: Id -> Bool
fun_always_ok Id
_ = Bool
True
exprOkForSpecEval :: (Id -> Bool) -> CoreExpr -> Bool
exprOkForSpecEval :: (Id -> Bool) -> CoreExpr -> Bool
exprOkForSpecEval Id -> Bool
fun_ok = (Id -> Bool) -> (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok Id -> Bool
fun_ok PrimOp -> Bool
primOpOkForSpeculation
expr_ok :: (Id -> Bool) -> (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok :: (Id -> Bool) -> (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok Id -> Bool
_ PrimOp -> Bool
_ (Lit Literal
_) = Bool
True
expr_ok Id -> Bool
_ PrimOp -> Bool
_ (Type Type
_) = Bool
True
expr_ok Id -> Bool
_ PrimOp -> Bool
_ (Coercion Coercion
_) = Bool
True
expr_ok Id -> Bool
fun_ok PrimOp -> Bool
primop_ok (Var Id
v) = (Id -> Bool) -> (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool
app_ok Id -> Bool
fun_ok PrimOp -> Bool
primop_ok Id
v []
expr_ok Id -> Bool
fun_ok PrimOp -> Bool
primop_ok (Cast CoreExpr
e Coercion
_) = (Id -> Bool) -> (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok Id -> Bool
fun_ok PrimOp -> Bool
primop_ok CoreExpr
e
expr_ok Id -> Bool
fun_ok PrimOp -> Bool
primop_ok (Lam Id
b CoreExpr
e)
| Id -> Bool
isTyVar Id
b = (Id -> Bool) -> (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok Id -> Bool
fun_ok PrimOp -> Bool
primop_ok CoreExpr
e
| Bool
otherwise = Bool
True
expr_ok Id -> Bool
fun_ok PrimOp -> Bool
primop_ok (Tick CoreTickish
tickish CoreExpr
e)
| CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishCounts CoreTickish
tickish = Bool
False
| Bool
otherwise = (Id -> Bool) -> (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok Id -> Bool
fun_ok PrimOp -> Bool
primop_ok CoreExpr
e
expr_ok Id -> Bool
_ PrimOp -> Bool
_ (Let {}) = Bool
False
expr_ok Id -> Bool
fun_ok PrimOp -> Bool
primop_ok (Case CoreExpr
scrut Id
bndr Type
_ [Alt Id]
alts)
=
(Id -> Bool) -> (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok Id -> Bool
fun_ok PrimOp -> Bool
primop_ok CoreExpr
scrut
Bool -> Bool -> Bool
&& (() :: Constraint) => Type -> Bool
Type -> Bool
isUnliftedType (Id -> Type
idType Id
bndr)
Bool -> Bool -> Bool
&& (Alt Id -> Bool) -> [Alt Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(Alt AltCon
_ [Id]
_ CoreExpr
rhs) -> (Id -> Bool) -> (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok Id -> Bool
fun_ok PrimOp -> Bool
primop_ok CoreExpr
rhs) [Alt Id]
alts
Bool -> Bool -> Bool
&& [Alt Id] -> Bool
forall b. [Alt b] -> Bool
altsAreExhaustive [Alt Id]
alts
expr_ok Id -> Bool
fun_ok PrimOp -> Bool
primop_ok CoreExpr
other_expr
| (CoreExpr
expr, [CoreExpr]
args) <- CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs CoreExpr
other_expr
= case (CoreTickish -> Bool) -> CoreExpr -> CoreExpr
forall b. (CoreTickish -> Bool) -> Expr b -> Expr b
stripTicksTopE (Bool -> Bool
not (Bool -> Bool) -> (CoreTickish -> Bool) -> CoreTickish -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishCounts) CoreExpr
expr of
Var Id
f ->
(Id -> Bool) -> (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool
app_ok Id -> Bool
fun_ok PrimOp -> Bool
primop_ok Id
f [CoreExpr]
args
Lit Literal
lit | Bool
debugIsOn, Bool -> Bool
not (Literal -> Bool
isLitRubbish Literal
lit)
-> String -> SDoc -> Bool
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Non-rubbish lit in app head" (Literal -> SDoc
forall a. Outputable a => a -> SDoc
ppr Literal
lit)
| Bool
otherwise
-> Bool
True
CoreExpr
_ -> Bool
False
app_ok :: (Id -> Bool) -> (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool
app_ok :: (Id -> Bool) -> (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool
app_ok Id -> Bool
fun_ok PrimOp -> Bool
primop_ok Id
fun [CoreExpr]
args
| Bool -> Bool
not (Id -> Bool
fun_ok Id
fun)
= Bool
False
| Bool
otherwise
= case Id -> IdDetails
idDetails Id
fun of
DFunId Bool
new_type -> Bool -> Bool
not Bool
new_type
DataConWorkId {} -> Bool
True
PrimOpId PrimOp
op Bool
_
| PrimOp -> Bool
primOpIsDiv PrimOp
op
, [CoreExpr
arg1, Lit Literal
lit] <- [CoreExpr]
args
-> Bool -> Bool
not (Literal -> Bool
isZeroLit Literal
lit) Bool -> Bool -> Bool
&& (Id -> Bool) -> (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok Id -> Bool
fun_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
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((PiTyBinder -> CoreExpr -> Bool)
-> [PiTyBinder] -> [CoreExpr] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith PiTyBinder -> CoreExpr -> Bool
arg_ok [PiTyBinder]
arg_tys [CoreExpr]
args)
IdDetails
_
| Just Levity
Unlifted <- (() :: Constraint) => Type -> Maybe Levity
Type -> Maybe Levity
typeLevity_maybe (Id -> Type
idType Id
fun)
-> Bool -> SDoc -> Bool -> Bool
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Int
n_val_args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
fun SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [CoreExpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CoreExpr]
args)
Bool
True
| Id -> Int
idArity Id
fun Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n_val_args ->
[Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((PiTyBinder -> CoreExpr -> Bool)
-> [PiTyBinder] -> [CoreExpr] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith PiTyBinder -> CoreExpr -> Bool
arg_ok [PiTyBinder]
arg_tys [CoreExpr]
args)
| Id
fun Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
unsafeEqualityProofIdKey -> Bool
True
| Bool
otherwise -> Bool
False
where
n_val_args :: Int
n_val_args = [CoreExpr] -> Int
forall b. [Arg b] -> Int
valArgCount [CoreExpr]
args
([PiTyBinder]
arg_tys, Type
_) = Type -> ([PiTyBinder], Type)
splitPiTys (Id -> Type
idType Id
fun)
arg_ok :: PiTyVarBinder -> CoreExpr -> Bool
arg_ok :: PiTyBinder -> CoreExpr -> Bool
arg_ok (Named ForAllTyBinder
_) CoreExpr
_ = Bool
True
arg_ok (Anon Scaled Type
ty FunTyFlag
_) CoreExpr
arg
| Just Levity
Lifted <- (() :: Constraint) => Type -> Maybe Levity
Type -> Maybe Levity
typeLevity_maybe (Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
ty)
= Bool
True
| Bool
otherwise
= (Id -> Bool) -> (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok Id -> Bool
fun_ok PrimOp -> Bool
primop_ok CoreExpr
arg
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 [Alt b] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` (TyCon -> Int
tyConFamilySize (DataCon -> TyCon
dataConTyCon DataCon
c) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
etaExpansionTick :: Id -> GenTickish pass -> Bool
etaExpansionTick :: forall (pass :: TickishPass). Id -> GenTickish pass -> Bool
etaExpansionTick Id
id GenTickish pass
t
= Id -> Bool
hasNoBinding Id
id Bool -> Bool -> Bool
&&
( GenTickish pass -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable GenTickish pass
t Bool -> Bool -> Bool
|| GenTickish pass -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
isProfTick GenTickish pass
t )
exprIsHNF :: CoreExpr -> Bool
exprIsHNF :: CoreExpr -> Bool
exprIsHNF = (() :: Constraint) =>
(Id -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool
(Id -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool
exprIsHNFlike Id -> Bool
isDataConWorkId Unfolding -> Bool
isEvaldUnfolding
exprIsConLike :: CoreExpr -> Bool
exprIsConLike :: CoreExpr -> Bool
exprIsConLike = (() :: Constraint) =>
(Id -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool
(Id -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool
exprIsHNFlike Id -> Bool
isConLikeId Unfolding -> Bool
isConLikeUnfolding
exprIsHNFlike :: HasDebugCallStack => (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool
exprIsHNFlike :: (() :: Constraint) =>
(Id -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool
exprIsHNFlike Id -> Bool
is_con Unfolding -> Bool
is_con_unf = CoreExpr -> Bool
is_hnf_like
where
is_hnf_like :: CoreExpr -> Bool
is_hnf_like (Var Id
v)
= CheapAppFun
id_app_is_value Id
v Int
0
Bool -> Bool -> Bool
|| Unfolding -> Bool
is_con_unf (Id -> Unfolding
idUnfolding Id
v)
Bool -> Bool -> Bool
|| ( (() :: Constraint) => Type -> Maybe Levity
Type -> Maybe Levity
typeLevity_maybe (Id -> Type
idType Id
v) Maybe Levity -> Maybe Levity -> Bool
forall a. Eq a => a -> a -> Bool
== Levity -> Maybe Levity
forall a. a -> Maybe a
Just Levity
Unlifted )
is_hnf_like (Lit Literal
l) = Bool -> Bool
not (Literal -> Bool
isLitRubbish Literal
l)
is_hnf_like (Type Type
_) = Bool
True
is_hnf_like (Coercion Coercion
_) = Bool
True
is_hnf_like (Lam Id
b CoreExpr
e) = Id -> Bool
isRuntimeVar Id
b Bool -> Bool -> Bool
|| CoreExpr -> Bool
is_hnf_like CoreExpr
e
is_hnf_like (Tick CoreTickish
tickish CoreExpr
e) = Bool -> Bool
not (CoreTickish -> Bool
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 Coercion
_) = CoreExpr -> Bool
is_hnf_like CoreExpr
e
is_hnf_like (App CoreExpr
e CoreExpr
a)
| CoreExpr -> Bool
forall b. Expr b -> Bool
isValArg CoreExpr
a = CoreExpr -> Int -> Bool
app_is_value CoreExpr
e Int
1
| Bool
otherwise = CoreExpr -> Bool
is_hnf_like CoreExpr
e
is_hnf_like (Let Bind Id
_ 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 -> Int -> Bool
app_is_value (Var Id
f) Int
nva = CheapAppFun
id_app_is_value Id
f Int
nva
app_is_value (Tick CoreTickish
_ CoreExpr
f) Int
nva = CoreExpr -> Int -> Bool
app_is_value CoreExpr
f Int
nva
app_is_value (Cast CoreExpr
f Coercion
_) Int
nva = CoreExpr -> Int -> Bool
app_is_value CoreExpr
f Int
nva
app_is_value (App CoreExpr
f CoreExpr
a) Int
nva
| CoreExpr -> Bool
forall b. Expr b -> Bool
isValArg CoreExpr
a =
CoreExpr -> Int -> Bool
app_is_value CoreExpr
f (Int
nva Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Bool -> Bool -> Bool
&&
Bool -> Bool
not (Type -> CoreExpr -> Bool
needsCaseBinding ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
a) CoreExpr
a)
| Bool
otherwise = CoreExpr -> Int -> Bool
app_is_value CoreExpr
f Int
nva
app_is_value CoreExpr
_ Int
_ = Bool
False
id_app_is_value :: CheapAppFun
id_app_is_value Id
id Int
n_val_args
= Id -> Bool
is_con Id
id
Bool -> Bool -> Bool
|| Id -> Int
idArity Id
id Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n_val_args
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 = Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust (Maybe ByteString -> Bool)
-> (CoreExpr -> Maybe ByteString) -> CoreExpr -> Bool
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)) = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
bs
exprIsTickedString_maybe (Tick CoreTickish
t CoreExpr
e)
| CoreTickish -> TickishPlacement
forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
tickishPlace CoreTickish
t TickishPlacement -> TickishPlacement -> Bool
forall a. Eq a => a -> a -> Bool
== TickishPlacement
PlaceCostCentre = Maybe ByteString
forall a. Maybe a
Nothing
| Bool
otherwise = CoreExpr -> Maybe ByteString
exprIsTickedString_maybe CoreExpr
e
exprIsTickedString_maybe CoreExpr
_ = Maybe ByteString
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] -> ([Id], [Id])
dataConRepInstPat = [FastString]
-> [Unique] -> Type -> DataCon -> [Type] -> ([Id], [Id])
dataConInstPat (FastString -> [FastString]
forall a. a -> [a]
repeat ((String -> FastString
fsLit String
"ipv")))
dataConRepFSInstPat :: [FastString]
-> [Unique] -> Type -> DataCon -> [Type] -> ([Id], [Id])
dataConRepFSInstPat = [FastString]
-> [Unique] -> Type -> DataCon -> [Type] -> ([Id], [Id])
dataConInstPat
dataConInstPat :: [FastString]
-> [Unique]
-> Mult
-> DataCon
-> [Type]
-> ([TyCoVar], [Id])
dataConInstPat :: [FastString]
-> [Unique] -> Type -> DataCon -> [Type] -> ([Id], [Id])
dataConInstPat [FastString]
fss [Unique]
uniqs Type
mult DataCon
con [Type]
inst_tys
= Bool -> ([Id], [Id]) -> ([Id], [Id])
forall a. HasCallStack => Bool -> a -> a
assert ([Id]
univ_tvs [Id] -> [Type] -> Bool
forall a b. [a] -> [b] -> Bool
`equalLength` [Type]
inst_tys) (([Id], [Id]) -> ([Id], [Id])) -> ([Id], [Id]) -> ([Id], [Id])
forall a b. (a -> b) -> a -> b
$
([Id]
ex_bndrs, [Id]
arg_ids)
where
univ_tvs :: [Id]
univ_tvs = DataCon -> [Id]
dataConUnivTyVars DataCon
con
ex_tvs :: [Id]
ex_tvs = DataCon -> [Id]
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 :: Int
n_ex = [Id] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
ex_tvs
([Unique]
ex_uniqs, [Unique]
id_uniqs) = Int -> [Unique] -> ([Unique], [Unique])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n_ex [Unique]
uniqs
([FastString]
ex_fss, [FastString]
id_fss) = Int -> [FastString] -> ([FastString], [FastString])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n_ex [FastString]
fss
univ_subst :: Subst
univ_subst = [Id] -> [Type] -> Subst
(() :: Constraint) => [Id] -> [Type] -> Subst
zipTvSubst [Id]
univ_tvs [Type]
inst_tys
(Subst
full_subst, [Id]
ex_bndrs) = (Subst -> (Id, FastString, Unique) -> (Subst, Id))
-> Subst -> [(Id, FastString, Unique)] -> (Subst, [Id])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL Subst -> (Id, FastString, Unique) -> (Subst, Id)
mk_ex_var Subst
univ_subst
([Id] -> [FastString] -> [Unique] -> [(Id, FastString, Unique)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Id]
ex_tvs [FastString]
ex_fss [Unique]
ex_uniqs)
mk_ex_var :: Subst -> (TyCoVar, FastString, Unique) -> (Subst, TyCoVar)
mk_ex_var :: Subst -> (Id, FastString, Unique) -> (Subst, Id)
mk_ex_var Subst
subst (Id
tv, FastString
fs, Unique
uniq) = (Subst -> Id -> Id -> Subst
Type.extendTCvSubstWithClone Subst
subst Id
tv
Id
new_tv
, Id
new_tv)
where
new_tv :: Id
new_tv | Id -> Bool
isTyVar Id
tv
= Name -> Type -> Id
mkTyVar (Unique -> FastString -> Name
mkSysTvName Unique
uniq FastString
fs) Type
kind
| Bool
otherwise
= Name -> Type -> Id
mkCoVar (Unique -> FastString -> Name
mkSystemVarName Unique
uniq FastString
fs) Type
kind
kind :: Type
kind = Subst -> Type -> Type
Type.substTyUnchecked Subst
subst (Id -> Type
varType Id
tv)
arg_ids :: [Id]
arg_ids = (Unique -> FastString -> Scaled Type -> StrictnessMark -> Id)
-> [Unique]
-> [FastString]
-> [Scaled Type]
-> [StrictnessMark]
-> [Id]
forall a b c d e.
(a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e]
zipWith4 Unique -> FastString -> Scaled Type -> StrictnessMark -> Id
mk_id_var [Unique]
id_uniqs [FastString]
id_fss [Scaled Type]
arg_tys [StrictnessMark]
arg_strs
mk_id_var :: Unique -> FastString -> Scaled Type -> StrictnessMark -> Id
mk_id_var Unique
uniq FastString
fs (Scaled Type
m Type
ty) StrictnessMark
str
= StrictnessMark -> Id -> Id
setCaseBndrEvald StrictnessMark
str (Id -> Id) -> Id -> Id
forall a b. (a -> b) -> a -> b
$
Name -> Type -> Type -> Id
mkLocalIdOrCoVar Name
name (Type
mult Type -> Type -> Type
`mkMultMul` Type
m) ((() :: Constraint) => Subst -> Type -> Type
Subst -> Type -> Type
Type.substTy Subst
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 = (CoreTickish -> Bool) -> Expr b -> Expr b -> Bool
forall b. (CoreTickish -> Bool) -> Expr b -> Expr b -> Bool
cheapEqExpr' (Bool -> CoreTickish -> Bool
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 Id
v1) (Var Id
v2) = Id
v1 Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
v2
go (Lit Literal
lit1) (Lit Literal
lit2) = Literal
lit1 Literal -> Literal -> Bool
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 Coercion
c1) (Coercion Coercion
c2) = Coercion
c1 Coercion -> Coercion -> Bool
`eqCoercion` Coercion
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 Coercion
t1) (Cast Expr b
e2 Coercion
t2) = Expr b
e1 Expr b -> Expr b -> Bool
`go` Expr b
e2 Bool -> Bool -> Bool
&& Coercion
t1 Coercion -> Coercion -> Bool
`eqCoercion` Coercion
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 CoreTickish -> CoreTickish -> Bool
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
eqTickish :: RnEnv2 -> CoreTickish -> CoreTickish -> Bool
eqTickish :: RnEnv2 -> CoreTickish -> CoreTickish -> Bool
eqTickish RnEnv2
env (Breakpoint XBreakpoint 'TickishPassCore
lext Int
lid [XTickishId 'TickishPassCore]
lids) (Breakpoint XBreakpoint 'TickishPassCore
rext Int
rid [XTickishId 'TickishPassCore]
rids)
= Int
lid Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
rid Bool -> Bool -> Bool
&&
(Id -> Id) -> [Id] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (RnEnv2 -> Id -> Id
rnOccL RnEnv2
env) [Id]
[XTickishId 'TickishPassCore]
lids [Id] -> [Id] -> Bool
forall a. Eq a => a -> a -> Bool
== (Id -> Id) -> [Id] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (RnEnv2 -> Id -> Id
rnOccR RnEnv2
env) [Id]
[XTickishId 'TickishPassCore]
rids Bool -> Bool -> Bool
&&
NoExtField
XBreakpoint 'TickishPassCore
lext NoExtField -> NoExtField -> Bool
forall a. Eq a => a -> a -> Bool
== NoExtField
XBreakpoint 'TickishPassCore
rext
eqTickish RnEnv2
_ CoreTickish
l CoreTickish
r = CoreTickish
l CoreTickish -> CoreTickish -> Bool
forall a. Eq a => a -> a -> Bool
== CoreTickish
r
diffBinds :: Bool -> RnEnv2 -> [(Var, CoreExpr)] -> [(Var, CoreExpr)]
-> ([SDoc], RnEnv2)
diffBinds :: Bool
-> RnEnv2
-> [(Id, CoreExpr)]
-> [(Id, CoreExpr)]
-> ([SDoc], RnEnv2)
diffBinds Bool
top RnEnv2
env [(Id, CoreExpr)]
binds1 = Int
-> RnEnv2
-> [(Id, CoreExpr)]
-> [(Id, CoreExpr)]
-> ([SDoc], RnEnv2)
go ([(Id, CoreExpr)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Id, CoreExpr)]
binds1) RnEnv2
env [(Id, CoreExpr)]
binds1
where go :: Int
-> RnEnv2
-> [(Id, CoreExpr)]
-> [(Id, CoreExpr)]
-> ([SDoc], RnEnv2)
go Int
_ RnEnv2
env [] []
= ([], RnEnv2
env)
go Int
_fuel RnEnv2
env [] [(Id, CoreExpr)]
binds2
= (RnEnv2 -> [(Id, CoreExpr)] -> [(Id, CoreExpr)] -> [SDoc]
warn RnEnv2
env [] [(Id, CoreExpr)]
binds2, RnEnv2
env)
go Int
_fuel RnEnv2
env [(Id, CoreExpr)]
binds1 []
= (RnEnv2 -> [(Id, CoreExpr)] -> [(Id, CoreExpr)] -> [SDoc]
warn RnEnv2
env [(Id, CoreExpr)]
binds1 [], RnEnv2
env)
go Int
fuel RnEnv2
env binds1 :: [(Id, CoreExpr)]
binds1@((Id, CoreExpr)
bind1:[(Id, CoreExpr)]
_) binds2 :: [(Id, CoreExpr)]
binds2@((Id, CoreExpr)
_:[(Id, CoreExpr)]
_)
| Int
fuel Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
= if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ RnEnv2
env RnEnv2 -> Id -> Bool
`inRnEnvL` (Id, CoreExpr) -> Id
forall a b. (a, b) -> a
fst (Id, CoreExpr)
bind1
then let env' :: RnEnv2
env' = ([Id] -> [Id] -> RnEnv2) -> ([Id], [Id]) -> RnEnv2
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (RnEnv2 -> [Id] -> [Id] -> RnEnv2
rnBndrs2 RnEnv2
env) (([Id], [Id]) -> RnEnv2) -> ([Id], [Id]) -> RnEnv2
forall a b. (a -> b) -> a -> b
$ [(Id, Id)] -> ([Id], [Id])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Id, Id)] -> ([Id], [Id])) -> [(Id, Id)] -> ([Id], [Id])
forall a b. (a -> b) -> a -> b
$
[Id] -> [Id] -> [(Id, Id)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Id] -> [Id]
forall a. Ord a => [a] -> [a]
sort ([Id] -> [Id]) -> [Id] -> [Id]
forall a b. (a -> b) -> a -> b
$ ((Id, CoreExpr) -> Id) -> [(Id, CoreExpr)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, CoreExpr) -> Id
forall a b. (a, b) -> a
fst [(Id, CoreExpr)]
binds1) ([Id] -> [Id]
forall a. Ord a => [a] -> [a]
sort ([Id] -> [Id]) -> [Id] -> [Id]
forall a b. (a -> b) -> a -> b
$ ((Id, CoreExpr) -> Id) -> [(Id, CoreExpr)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, CoreExpr) -> Id
forall a b. (a, b) -> a
fst [(Id, CoreExpr)]
binds2)
in Int
-> RnEnv2
-> [(Id, CoreExpr)]
-> [(Id, CoreExpr)]
-> ([SDoc], RnEnv2)
go ([(Id, CoreExpr)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Id, CoreExpr)]
binds1) RnEnv2
env' [(Id, CoreExpr)]
binds1 [(Id, CoreExpr)]
binds2
else (RnEnv2 -> [(Id, CoreExpr)] -> [(Id, CoreExpr)] -> [SDoc]
warn RnEnv2
env [(Id, CoreExpr)]
binds1 [(Id, CoreExpr)]
binds2, RnEnv2
env)
go Int
fuel RnEnv2
env ((Id
bndr1,CoreExpr
expr1):[(Id, CoreExpr)]
binds1) [(Id, CoreExpr)]
binds2
| let matchExpr :: (Id, CoreExpr) -> Bool
matchExpr (Id
bndr,CoreExpr
expr) =
(Id -> Bool
isTyVar Id
bndr Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
top Bool -> Bool -> Bool
|| [SDoc] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (RnEnv2 -> Id -> Id -> [SDoc]
diffIdInfo RnEnv2
env Id
bndr Id
bndr1)) Bool -> Bool -> Bool
&&
[SDoc] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
top (RnEnv2 -> Id -> Id -> RnEnv2
rnBndr2 RnEnv2
env Id
bndr1 Id
bndr) CoreExpr
expr1 CoreExpr
expr)
, ([(Id, CoreExpr)]
binds2l, (Id
bndr2,CoreExpr
_):[(Id, CoreExpr)]
binds2r) <- ((Id, CoreExpr) -> Bool)
-> [(Id, CoreExpr)] -> ([(Id, CoreExpr)], [(Id, CoreExpr)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Id, CoreExpr) -> Bool
matchExpr [(Id, CoreExpr)]
binds2
= Int
-> RnEnv2
-> [(Id, CoreExpr)]
-> [(Id, CoreExpr)]
-> ([SDoc], RnEnv2)
go ([(Id, CoreExpr)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Id, CoreExpr)]
binds1) (RnEnv2 -> Id -> Id -> RnEnv2
rnBndr2 RnEnv2
env Id
bndr1 Id
bndr2)
[(Id, CoreExpr)]
binds1 ([(Id, CoreExpr)]
binds2l [(Id, CoreExpr)] -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. [a] -> [a] -> [a]
++ [(Id, CoreExpr)]
binds2r)
| Bool
otherwise
= Int
-> RnEnv2
-> [(Id, CoreExpr)]
-> [(Id, CoreExpr)]
-> ([SDoc], RnEnv2)
go (Int
fuelInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) RnEnv2
env ([(Id, CoreExpr)]
binds1[(Id, CoreExpr)] -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. [a] -> [a] -> [a]
++[(Id
bndr1,CoreExpr
expr1)]) [(Id, CoreExpr)]
binds2
warn :: RnEnv2 -> [(Id, CoreExpr)] -> [(Id, CoreExpr)] -> [SDoc]
warn RnEnv2
env [(Id, CoreExpr)]
binds1 [(Id, CoreExpr)]
binds2 =
(((Id, CoreExpr), (Id, CoreExpr)) -> [SDoc])
-> [((Id, CoreExpr), (Id, CoreExpr))] -> [SDoc]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((Id, CoreExpr) -> (Id, CoreExpr) -> [SDoc])
-> ((Id, CoreExpr), (Id, CoreExpr)) -> [SDoc]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (RnEnv2 -> (Id, CoreExpr) -> (Id, CoreExpr) -> [SDoc]
diffBind RnEnv2
env)) ([(Id, CoreExpr)]
-> [(Id, CoreExpr)] -> [((Id, CoreExpr), (Id, CoreExpr))]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Id, CoreExpr)]
binds1' [(Id, CoreExpr)]
binds2') [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++
String -> [(Id, CoreExpr)] -> [SDoc]
forall {b}. OutputableBndr b => String -> [(b, Expr b)] -> [SDoc]
unmatched String
"unmatched left-hand:" (Int -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. Int -> [a] -> [a]
drop Int
l [(Id, CoreExpr)]
binds1') [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++
String -> [(Id, CoreExpr)] -> [SDoc]
forall {b}. OutputableBndr b => String -> [(b, Expr b)] -> [SDoc]
unmatched String
"unmatched right-hand:" (Int -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. Int -> [a] -> [a]
drop Int
l [(Id, CoreExpr)]
binds2')
where binds1' :: [(Id, CoreExpr)]
binds1' = ((Id, CoreExpr) -> (Id, CoreExpr) -> Ordering)
-> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Id, CoreExpr) -> Id)
-> (Id, CoreExpr) -> (Id, CoreExpr) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Id, CoreExpr) -> Id
forall a b. (a, b) -> a
fst) [(Id, CoreExpr)]
binds1
binds2' :: [(Id, CoreExpr)]
binds2' = ((Id, CoreExpr) -> (Id, CoreExpr) -> Ordering)
-> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Id, CoreExpr) -> Id)
-> (Id, CoreExpr) -> (Id, CoreExpr) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Id, CoreExpr) -> Id
forall a b. (a, b) -> a
fst) [(Id, CoreExpr)]
binds2
l :: Int
l = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min ([(Id, CoreExpr)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Id, CoreExpr)]
binds1') ([(Id, CoreExpr)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Id, CoreExpr)]
binds2')
unmatched :: String -> [(b, Expr b)] -> [SDoc]
unmatched String
_ [] = []
unmatched String
txt [(b, Expr b)]
bs = [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
txt SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Bind b -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([(b, Expr b)] -> Bind b
forall b. [(b, Expr b)] -> Bind b
Rec [(b, Expr b)]
bs)]
diffBind :: RnEnv2 -> (Id, CoreExpr) -> (Id, CoreExpr) -> [SDoc]
diffBind RnEnv2
env (Id
bndr1,CoreExpr
expr1) (Id
bndr2,CoreExpr
expr2)
| ds :: [SDoc]
ds@(SDoc
_:[SDoc]
_) <- Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
top RnEnv2
env CoreExpr
expr1 CoreExpr
expr2
= String -> Id -> Id -> [SDoc] -> [SDoc]
locBind String
"in binding" Id
bndr1 Id
bndr2 [SDoc]
ds
| Id -> Bool
isTyVar Id
bndr1 Bool -> Bool -> Bool
&& Id -> Bool
isTyVar Id
bndr2
= []
| Bool
otherwise
= RnEnv2 -> Id -> Id -> [SDoc]
diffIdInfo RnEnv2
env Id
bndr1 Id
bndr2
diffExpr :: Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr :: Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
_ RnEnv2
env (Var Id
v1) (Var Id
v2) | RnEnv2 -> Id -> Id
rnOccL RnEnv2
env Id
v1 Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== RnEnv2 -> Id -> Id
rnOccR RnEnv2
env Id
v2 = []
diffExpr Bool
_ RnEnv2
_ (Lit Literal
lit1) (Lit Literal
lit2) | Literal
lit1 Literal -> Literal -> Bool
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 Coercion
co1) (Coercion Coercion
co2)
| RnEnv2 -> Coercion -> Coercion -> Bool
eqCoercionX RnEnv2
env Coercion
co1 Coercion
co2 = []
diffExpr Bool
top RnEnv2
env (Cast CoreExpr
e1 Coercion
co1) (Cast CoreExpr
e2 Coercion
co2)
| RnEnv2 -> Coercion -> Coercion -> Bool
eqCoercionX RnEnv2
env Coercion
co1 Coercion
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 (CoreTickish -> Bool
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 (CoreTickish -> Bool
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 Id
absent) CoreExpr
_) CoreExpr
_)
(App (App (Var Id
absent2) CoreExpr
_) CoreExpr
_)
| Id -> Bool
isDeadEndId Id
absent Bool -> Bool -> Bool
&& Id -> Bool
isDeadEndId Id
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 [SDoc] -> [SDoc] -> [SDoc]
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 Id
b1 CoreExpr
e1) (Lam Id
b2 CoreExpr
e2)
| RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env (Id -> Type
varType Id
b1) (Id -> Type
varType Id
b2)
= Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
top (RnEnv2 -> Id -> Id -> RnEnv2
rnBndr2 RnEnv2
env Id
b1 Id
b2) CoreExpr
e1 CoreExpr
e2
diffExpr Bool
top RnEnv2
env (Let Bind Id
bs1 CoreExpr
e1) (Let Bind Id
bs2 CoreExpr
e2)
= let ([SDoc]
ds, RnEnv2
env') = Bool
-> RnEnv2
-> [(Id, CoreExpr)]
-> [(Id, CoreExpr)]
-> ([SDoc], RnEnv2)
diffBinds Bool
top RnEnv2
env ([Bind Id] -> [(Id, CoreExpr)]
forall b. [Bind b] -> [(b, Expr b)]
flattenBinds [Bind Id
bs1]) ([Bind Id] -> [(Id, CoreExpr)]
forall b. [Bind b] -> [(b, Expr b)]
flattenBinds [Bind Id
bs2])
in [SDoc]
ds [SDoc] -> [SDoc] -> [SDoc]
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 Id
b1 Type
t1 [Alt Id]
a1) (Case CoreExpr
e2 Id
b2 Type
t2 [Alt Id]
a2)
| [Alt Id] -> [Alt Id] -> Bool
forall a b. [a] -> [b] -> Bool
equalLength [Alt Id]
a1 [Alt Id]
a2 Bool -> Bool -> Bool
&& Bool -> Bool
not ([Alt Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Alt Id]
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 [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [[SDoc]] -> [SDoc]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((Alt Id -> Alt Id -> [SDoc]) -> [Alt Id] -> [Alt Id] -> [[SDoc]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Alt Id -> Alt Id -> [SDoc]
diffAlt [Alt Id]
a1 [Alt Id]
a2)
where env' :: RnEnv2
env' = RnEnv2 -> Id -> Id -> RnEnv2
rnBndr2 RnEnv2
env Id
b1 Id
b2
diffAlt :: Alt Id -> Alt Id -> [SDoc]
diffAlt (Alt AltCon
c1 [Id]
bs1 CoreExpr
e1) (Alt AltCon
c2 [Id]
bs2 CoreExpr
e2)
| AltCon
c1 AltCon -> AltCon -> Bool
forall a. Eq a => a -> a -> Bool
/= AltCon
c2 = [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"alt-cons " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> AltCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr AltCon
c1 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" /= " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> AltCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr AltCon
c2]
| Bool
otherwise = Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
top (RnEnv2 -> [Id] -> [Id] -> RnEnv2
rnBndrs2 RnEnv2
env' [Id]
bs1 [Id]
bs2) CoreExpr
e1 CoreExpr
e2
diffExpr Bool
_ RnEnv2
_ CoreExpr
e1 CoreExpr
e2
= [[SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
fsep [CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
e1, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"/=", CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
e2]]
diffIdInfo :: RnEnv2 -> Var -> Var -> [SDoc]
diffIdInfo :: RnEnv2 -> Id -> Id -> [SDoc]
diffIdInfo RnEnv2
env Id
bndr1 Id
bndr2
| IdInfo -> Int
arityInfo IdInfo
info1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== IdInfo -> Int
arityInfo IdInfo
info2
Bool -> Bool -> Bool
&& IdInfo -> CafInfo
cafInfo IdInfo
info1 CafInfo -> CafInfo -> Bool
forall a. Eq a => a -> a -> Bool
== IdInfo -> CafInfo
cafInfo IdInfo
info2
Bool -> Bool -> Bool
&& IdInfo -> OneShotInfo
oneShotInfo IdInfo
info1 OneShotInfo -> OneShotInfo -> Bool
forall a. Eq a => a -> a -> Bool
== IdInfo -> OneShotInfo
oneShotInfo IdInfo
info2
Bool -> Bool -> Bool
&& IdInfo -> InlinePragma
inlinePragInfo IdInfo
info1 InlinePragma -> InlinePragma -> Bool
forall a. Eq a => a -> a -> Bool
== IdInfo -> InlinePragma
inlinePragInfo IdInfo
info2
Bool -> Bool -> Bool
&& IdInfo -> OccInfo
occInfo IdInfo
info1 OccInfo -> OccInfo -> Bool
forall a. Eq a => a -> a -> Bool
== IdInfo -> OccInfo
occInfo IdInfo
info2
Bool -> Bool -> Bool
&& IdInfo -> Demand
demandInfo IdInfo
info1 Demand -> Demand -> Bool
forall a. Eq a => a -> a -> Bool
== IdInfo -> Demand
demandInfo IdInfo
info2
Bool -> Bool -> Bool
&& IdInfo -> Int
callArityInfo IdInfo
info1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== IdInfo -> Int
callArityInfo IdInfo
info2
= String -> Id -> Id -> [SDoc] -> [SDoc]
locBind String
"in unfolding of" Id
bndr1 Id
bndr2 ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$
RnEnv2 -> Unfolding -> Unfolding -> [SDoc]
diffUnfold RnEnv2
env (IdInfo -> Unfolding
realUnfoldingInfo IdInfo
info1) (IdInfo -> Unfolding
realUnfoldingInfo IdInfo
info2)
| Bool
otherwise
= String -> Id -> Id -> [SDoc] -> [SDoc]
locBind String
"in Id info of" Id
bndr1 Id
bndr2
[[SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
fsep [BindingSite -> Id -> SDoc
forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
LetBind Id
bndr1, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"/=", BindingSite -> Id -> SDoc
forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
LetBind Id
bndr2]]
where info1 :: IdInfo
info1 = (() :: Constraint) => Id -> IdInfo
Id -> IdInfo
idInfo Id
bndr1; info2 :: IdInfo
info2 = (() :: Constraint) => Id -> IdInfo
Id -> IdInfo
idInfo Id
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 [AltCon] -> [AltCon] -> Bool
forall a. Eq a => a -> a -> Bool
== [AltCon]
cs2 = []
diffUnfold RnEnv2
env (DFunUnfolding [Id]
bs1 DataCon
c1 [CoreExpr]
a1)
(DFunUnfolding [Id]
bs2 DataCon
c2 [CoreExpr]
a2)
| DataCon
c1 DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
c2 Bool -> Bool -> Bool
&& [Id] -> [Id] -> Bool
forall a b. [a] -> [b] -> Bool
equalLength [Id]
bs1 [Id]
bs2
= ((CoreExpr, CoreExpr) -> [SDoc])
-> [(CoreExpr, CoreExpr)] -> [SDoc]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((CoreExpr -> CoreExpr -> [SDoc]) -> (CoreExpr, CoreExpr) -> [SDoc]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
False RnEnv2
env')) ([CoreExpr] -> [CoreExpr] -> [(CoreExpr, CoreExpr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [CoreExpr]
a1 [CoreExpr]
a2)
where env' :: RnEnv2
env' = RnEnv2 -> [Id] -> [Id] -> RnEnv2
rnBndrs2 RnEnv2
env [Id]
bs1 [Id]
bs2
diffUnfold RnEnv2
env (CoreUnfolding CoreExpr
t1 UnfoldingSource
_ Bool
_ UnfoldingCache
c1 UnfoldingGuidance
g1)
(CoreUnfolding CoreExpr
t2 UnfoldingSource
_ Bool
_ UnfoldingCache
c2 UnfoldingGuidance
g2)
| UnfoldingCache
c1 UnfoldingCache -> UnfoldingCache -> Bool
forall a. Eq a => a -> a -> Bool
== UnfoldingCache
c2 Bool -> Bool -> Bool
&& UnfoldingGuidance
g1 UnfoldingGuidance -> UnfoldingGuidance -> Bool
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
forall doc. IsLine doc => [doc] -> doc
fsep [Unfolding -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unfolding
uf1, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"/=", Unfolding -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unfolding
uf2]]
locBind :: String -> Var -> Var -> [SDoc] -> [SDoc]
locBind :: String -> Id -> Id -> [SDoc] -> [SDoc]
locBind String
loc Id
b1 Id
b2 [SDoc]
diffs = (SDoc -> SDoc) -> [SDoc] -> [SDoc]
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
forall doc. IsDoc doc => doc -> doc -> doc
$$ Int -> SDoc -> SDoc
nest Int
2 (SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
loc SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
bindLoc))
bindLoc :: SDoc
bindLoc | Id
b1 Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
b2 = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
b1
| Bool
otherwise = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
b1 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'/' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
b2
isEmptyTy :: Type -> Bool
isEmptyTy :: Type -> Bool
isEmptyTy Type
ty
| Just (TyCon
tc, [Type]
inst_tys) <- (() :: Constraint) => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
, Just [DataCon]
dcs <- TyCon -> Maybe [DataCon]
tyConDataCons_maybe TyCon
tc
, (DataCon -> Bool) -> [DataCon] -> Bool
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
normSplitTyConApp_maybe :: FamInstEnvs -> Type -> Maybe (TyCon, [Type], Coercion)
normSplitTyConApp_maybe :: FamInstEnvs -> Type -> Maybe (TyCon, [Type], Coercion)
normSplitTyConApp_maybe FamInstEnvs
fam_envs Type
ty
| let Reduction Coercion
co Type
ty1 = FamInstEnvs -> Type -> Maybe Reduction
topNormaliseType_maybe FamInstEnvs
fam_envs Type
ty
Maybe Reduction -> Reduction -> Reduction
forall a. Maybe a -> a -> a
`orElse` (Role -> Type -> Reduction
mkReflRedn Role
Representational Type
ty)
, Just (TyCon
tc, [Type]
tc_args) <- (() :: Constraint) => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty1
= (TyCon, [Type], Coercion) -> Maybe (TyCon, [Type], Coercion)
forall a. a -> Maybe a
Just (TyCon
tc, [Type]
tc_args, Coercion
co)
normSplitTyConApp_maybe FamInstEnvs
_ Type
_ = Maybe (TyCon, [Type], Coercion)
forall a. Maybe a
Nothing
extendInScopeSetBind :: InScopeSet -> CoreBind -> InScopeSet
extendInScopeSetBind :: InScopeSet -> Bind Id -> InScopeSet
extendInScopeSetBind (InScope VarSet
in_scope) Bind Id
binds
= VarSet -> InScopeSet
InScope (VarSet -> InScopeSet) -> VarSet -> InScopeSet
forall a b. (a -> b) -> a -> b
$ (VarSet -> Id -> VarSet) -> VarSet -> Bind Id -> VarSet
forall a b. (a -> b -> a) -> a -> Bind b -> a
foldBindersOfBindStrict VarSet -> Id -> VarSet
extendVarSet VarSet
in_scope Bind Id
binds
extendInScopeSetBndrs :: InScopeSet -> [CoreBind] -> InScopeSet
extendInScopeSetBndrs :: InScopeSet -> [Bind Id] -> InScopeSet
extendInScopeSetBndrs (InScope VarSet
in_scope) [Bind Id]
binds
= VarSet -> InScopeSet
InScope (VarSet -> InScopeSet) -> VarSet -> InScopeSet
forall a b. (a -> b) -> a -> b
$ (VarSet -> Id -> VarSet) -> VarSet -> [Bind Id] -> VarSet
forall a b. (a -> b -> a) -> a -> [Bind b] -> a
foldBindersOfBindsStrict VarSet -> Id -> VarSet
extendVarSet VarSet
in_scope [Bind Id]
binds
mkInScopeSetBndrs :: [CoreBind] -> InScopeSet
mkInScopeSetBndrs :: [Bind Id] -> InScopeSet
mkInScopeSetBndrs [Bind Id]
binds = (InScopeSet -> Id -> InScopeSet)
-> InScopeSet -> [Bind Id] -> InScopeSet
forall a b. (a -> b -> a) -> a -> [Bind b] -> a
foldBindersOfBindsStrict InScopeSet -> Id -> InScopeSet
extendInScopeSet InScopeSet
emptyInScopeSet [Bind Id]
binds
collectMakeStaticArgs
:: CoreExpr -> Maybe (CoreExpr, Type, CoreExpr, CoreExpr)
collectMakeStaticArgs :: CoreExpr -> Maybe (CoreExpr, Type, CoreExpr, CoreExpr)
collectMakeStaticArgs CoreExpr
e
| (fun :: CoreExpr
fun@(Var Id
b), [Type Type
t, CoreExpr
loc, CoreExpr
arg], [CoreTickish]
_) <- (CoreTickish -> Bool)
-> CoreExpr -> (CoreExpr, [CoreExpr], [CoreTickish])
forall b.
(CoreTickish -> Bool)
-> Expr b -> (Expr b, [Expr b], [CoreTickish])
collectArgsTicks (Bool -> CoreTickish -> Bool
forall a b. a -> b -> a
const Bool
True) CoreExpr
e
, Id -> Name
idName Id
b Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
makeStaticName = (CoreExpr, Type, CoreExpr, CoreExpr)
-> Maybe (CoreExpr, Type, CoreExpr, CoreExpr)
forall a. a -> Maybe a
Just (CoreExpr
fun, Type
t, CoreExpr
loc, CoreExpr
arg)
collectMakeStaticArgs CoreExpr
_ = Maybe (CoreExpr, Type, CoreExpr, CoreExpr)
forall a. Maybe a
Nothing
isJoinBind :: CoreBind -> Bool
isJoinBind :: Bind Id -> Bool
isJoinBind (NonRec Id
b CoreExpr
_) = Id -> Bool
isJoinId Id
b
isJoinBind (Rec ((Id
b, CoreExpr
_) : [(Id, CoreExpr)]
_)) = Id -> Bool
isJoinId Id
b
isJoinBind Bind Id
_ = Bool
False
dumpIdInfoOfProgram :: Bool -> (IdInfo -> SDoc) -> CoreProgram -> SDoc
dumpIdInfoOfProgram :: Bool -> (IdInfo -> SDoc) -> [Bind Id] -> SDoc
dumpIdInfoOfProgram Bool
dump_locals IdInfo -> SDoc
ppr_id_info [Bind Id]
binds = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((Id -> SDoc) -> [Id] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Id -> SDoc
printId [Id]
ids)
where
ids :: [Id]
ids = (Id -> Id -> Ordering) -> [Id] -> [Id]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Name -> Name -> Ordering
stableNameCmp (Name -> Name -> Ordering) -> (Id -> Name) -> Id -> Id -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Id -> Name
forall a. NamedThing a => a -> Name
getName) ((Bind Id -> [Id]) -> [Bind Id] -> [Id]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Bind Id -> [Id]
forall {a}. Bind a -> [a]
getIds [Bind Id]
binds)
getIds :: Bind a -> [a]
getIds (NonRec a
i Expr a
_) = [ a
i ]
getIds (Rec [(a, Expr a)]
bs) = ((a, Expr a) -> a) -> [(a, Expr a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, Expr a) -> a
forall a b. (a, b) -> a
fst [(a, Expr a)]
bs
printId :: Id -> SDoc
printId Id
id | Id -> Bool
isExportedId Id
id Bool -> Bool -> Bool
|| Bool
dump_locals = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> (IdInfo -> SDoc
ppr_id_info ((() :: Constraint) => Id -> IdInfo
Id -> IdInfo
idInfo Id
id))
| Bool
otherwise = SDoc
forall doc. IsOutput doc => doc
empty
mkStrictFieldSeqs :: [(Id,StrictnessMark)] -> CoreExpr -> (CoreExpr)
mkStrictFieldSeqs :: [(Id, StrictnessMark)] -> CoreExpr -> CoreExpr
mkStrictFieldSeqs [(Id, StrictnessMark)]
args CoreExpr
rhs =
((Id, StrictnessMark) -> CoreExpr -> CoreExpr)
-> CoreExpr -> [(Id, StrictnessMark)] -> CoreExpr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Id, StrictnessMark) -> CoreExpr -> CoreExpr
addEval CoreExpr
rhs [(Id, StrictnessMark)]
args
where
case_ty :: Type
case_ty = (() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
rhs
addEval :: (Id,StrictnessMark) -> (CoreExpr) -> (CoreExpr)
addEval :: (Id, StrictnessMark) -> CoreExpr -> CoreExpr
addEval (Id
arg_id,StrictnessMark
arg_cbv) (CoreExpr
rhs)
| StrictnessMark -> Bool
isMarkedStrict StrictnessMark
arg_cbv
, Id -> Bool
shouldStrictifyIdForCbv Id
arg_id
= CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (Id -> CoreExpr
forall b. Id -> Expr b
Var (Id -> CoreExpr) -> Id -> CoreExpr
forall a b. (a -> b) -> a -> b
$! Id -> Id
zapIdUnfolding Id
arg_id) Id
arg_id Type
case_ty ([AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] CoreExpr
rhs])
| Bool
otherwise = do
CoreExpr
rhs
shouldStrictifyIdForCbv :: Var -> Bool
shouldStrictifyIdForCbv :: Id -> Bool
shouldStrictifyIdForCbv = Bool -> Id -> Bool
wantCbvForId Bool
False
shouldUseCbvForId :: Var -> Bool
shouldUseCbvForId :: Id -> Bool
shouldUseCbvForId = Bool -> Id -> Bool
wantCbvForId Bool
True
wantCbvForId :: Bool -> Var -> Bool
wantCbvForId :: Bool -> Id -> Bool
wantCbvForId Bool
cbv_for_strict Id
v
| Id -> Bool
isId Id
v
, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (() :: Constraint) => Type -> Bool
Type -> Bool
isZeroBitTy Type
ty
, Type -> Bool
mightBeLiftedType Type
ty
, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Type -> Bool
isFunTy Type
ty
, Bool -> Bool
not (Demand -> Bool
isStrictDmd Demand
dmd) Bool -> Bool -> Bool
|| Bool
cbv_for_strict
, Bool -> Bool
not (Demand -> Bool
isAbsDmd Demand
dmd)
= Bool
True
| Bool
otherwise
= Bool
False
where
ty :: Type
ty = Id -> Type
idType Id
v
dmd :: Demand
dmd = Id -> Demand
idDemandInfo Id
v
isUnsafeEqualityProof :: CoreExpr -> Bool
isUnsafeEqualityProof :: CoreExpr -> Bool
isUnsafeEqualityProof CoreExpr
e
| Var Id
v `App` Type Type
_ `App` Type Type
_ `App` Type Type
_ <- CoreExpr
e
= Id
v Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
unsafeEqualityProofIdKey
| Bool
otherwise
= Bool
False