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, exprIsDeadEnd,
getIdFromTrivialExpr_maybe,
exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun,
exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprIsWorkFree,
exprIsConLike,
isCheapApp, isExpandableApp, isSaturatedConApp,
exprIsTickedString, exprIsTickedString_maybe,
exprIsTopLevelBindable,
altsAreExhaustive,
cheapEqExpr, cheapEqExpr', eqExpr,
diffBinds,
tryEtaReduce, canEtaReduceToArity,
exprToType,
applyTypeToArgs,
dataConRepInstPat, dataConRepFSInstPat,
isEmptyTy, normSplitTyConApp_maybe,
stripTicksTop, stripTicksTopE, stripTicksTopT,
stripTicksE, stripTicksT,
collectMakeStaticArgs,
isJoinBind,
computeCbvInfo,
isUnsafeEqualityProof,
dumpIdInfoOfProgram
) where
import GHC.Prelude
import GHC.Platform
import GHC.Core
import GHC.Core.Ppr
import GHC.Core.FVs( exprFreeVars )
import GHC.Core.DataCon
import GHC.Core.Type as Type
import GHC.Core.FamInstEnv
import GHC.Core.Predicate
import GHC.Core.TyCo.Rep( TyCoBinder(..), TyBinder )
import GHC.Core.Coercion
import GHC.Core.Reduction
import GHC.Core.TyCon
import GHC.Core.Multiplicity
import GHC.Core.Map.Expr ( eqCoreExpr )
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.Unique
import GHC.Types.Basic
import GHC.Types.Demand
import GHC.Types.Unique.Set
import GHC.Data.FastString
import GHC.Data.Maybe
import GHC.Data.List.SetOps( minusList )
import GHC.Data.Pair
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 GHC.Utils.Trace
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
exprType :: HasDebugCallStack => CoreExpr -> Type
exprType :: 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] (HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
body)
| Bool
otherwise = HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
body
exprType (Case CoreExpr
_ Id
_ Type
ty [Alt Id]
_) = Type
ty
exprType (Cast CoreExpr
_ Coercion
co) = Pair Type -> Type
forall a. Pair a -> a
pSnd (Coercion -> Pair Type
coercionKind Coercion
co)
exprType (Tick CoreTickish
_ CoreExpr
e) = HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
e
exprType (Lam Id
binder CoreExpr
expr) = Id -> Type -> Type
mkLamType Id
binder (HasDebugCallStack => 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) -> HasDebugCallStack => SDoc -> Type -> [CoreExpr] -> Type
SDoc -> Type -> [CoreExpr] -> Type
applyTypeToArgs (CoreExpr -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr CoreExpr
e) (HasDebugCallStack => 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
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
rhs_ty)
where
rhs_ty :: Type
rhs_ty = HasDebugCallStack => 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. String -> a
panic String
"coreAltsType"
mkLamType :: Var -> Type -> Type
mkLamTypes :: [Var] -> Type -> Type
mkLamType :: Id -> Type -> Type
mkLamType Id
v Type
body_ty
| Id -> Bool
isTyVar Id
v
= Id -> ArgFlag -> Type -> Type
mkForAllTy Id
v ArgFlag
Inferred Type
body_ty
| Id -> Bool
isCoVar Id
v
, Id
v Id -> VarSet -> Bool
`elemVarSet` Type -> VarSet
tyCoVarsOfType Type
body_ty
= Id -> ArgFlag -> Type -> Type
mkForAllTy Id
v ArgFlag
Required Type
body_ty
| Bool
otherwise
= Type -> Type -> Type -> Type
mkFunctionType (Id -> Type
varMult Id
v) (Id -> Type
varType Id
v) Type
body_ty
mkFunctionType :: Mult -> Type -> Type -> Type
mkFunctionType :: Type -> Type -> Type -> Type
mkFunctionType Type
mult Type
arg_ty Type
res_ty
| HasDebugCallStack => Type -> Bool
Type -> Bool
isPredTy Type
arg_ty
= Bool -> Type -> Type
forall a. HasCallStack => Bool -> a -> a
assert (Type -> Type -> Bool
eqType Type
mult Type
Many) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
Type -> Type -> Type -> Type
mkInvisFunTy Type
mult Type
arg_ty Type
res_ty
| Bool
otherwise
= Type -> Type -> Type -> Type
mkVisFunTy Type
mult Type
arg_ty Type
res_ty
mkLamTypes :: [Id] -> Type -> Type
mkLamTypes [Id]
vs Type
ty = (Id -> Type -> Type) -> Type -> [Id] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Id -> Type -> Type
mkLamType Type
ty [Id]
vs
applyTypeToArgs :: HasDebugCallStack => SDoc -> Type -> [CoreExpr] -> Type
applyTypeToArgs :: SDoc -> Type -> [CoreExpr] -> Type
applyTypeToArgs SDoc
pp_e Type
op_ty [CoreExpr]
args
= Type -> [CoreExpr] -> Type
go Type
op_ty [CoreExpr]
args
where
go :: Type -> [CoreExpr] -> Type
go Type
op_ty [] = Type
op_ty
go Type
op_ty (Type Type
ty : [CoreExpr]
args) = Type -> [Type] -> [CoreExpr] -> Type
go_ty_args Type
op_ty [Type
ty] [CoreExpr]
args
go Type
op_ty (Coercion 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 (Type
_, Type
_, Type
res_ty) <- Type -> Maybe (Type, Type, Type)
splitFunTy_maybe Type
op_ty
= Type -> [CoreExpr] -> Type
go Type
res_ty [CoreExpr]
args
go Type
_ [CoreExpr]
args = 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 (HasDebugCallStack => 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
vcat [ String -> SDoc
text String
"Expression:" SDoc -> SDoc -> SDoc
<+> SDoc
pp_e
, String -> SDoc
text String
"Type:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
op_ty
, String -> SDoc
text String
"Args:" SDoc -> SDoc -> SDoc
<+> [CoreExpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CoreExpr]
args
, String -> SDoc
text String
"Args':" SDoc -> SDoc -> SDoc
<+> [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 :: CoreExpr -> CoercionR -> CoreExpr
mkCast :: 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
text String
"coercion" SDoc -> SDoc -> SDoc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"passed to mkCast"
SDoc -> SDoc -> SDoc
<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
e SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"has wrong role" SDoc -> SDoc -> SDoc
<+> 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
vcat ([ String -> SDoc
text String
"expr:" SDoc -> SDoc -> SDoc
<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
expr
, String -> SDoc
text String
"co2:" SDoc -> SDoc -> SDoc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co2
, String -> SDoc
text String
"co:" SDoc -> SDoc -> SDoc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co ])) (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
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 (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` HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
expr))
String
"Trying to coerce" (String -> SDoc
text String
"(" SDoc -> SDoc -> SDoc
<> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
expr
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"::" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
expr) SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
")"
SDoc -> SDoc -> SDoc
$$ Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Coercion -> Type
coercionType Coercion
co)
SDoc -> SDoc -> SDoc
$$ 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 (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 -> Arity
idArity Id
fun Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== [Expr b] -> Arity
forall b. [Arg b] -> Arity
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 :: (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 :: (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 :: (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 :: (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 :: (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 :: 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. String -> a
panic String
"mkAltExpr LitAlt"
mkAltExpr AltCon
DEFAULT [Id]
_ [Type]
_ = String -> CoreExpr
forall a. 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 (HasDebugCallStack => 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 = HasDebugCallStack => 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
$$ [Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
bndrs SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
body_ty)
findDefault :: [Alt b] -> ([Alt b], Maybe (Expr b))
findDefault :: [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 (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 :: [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 :: 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 :: 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 :: [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 (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 (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 :: TyCon -> [Type] -> [AltCon] -> [Alt b] -> ([AltCon], [Alt b])
filterAlts TyCon
_tycon [Type]
inst_tys [AltCon]
imposs_cons [Alt b]
alts
= ([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 :: [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 (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 (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 :: 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
exprIsDeadEnd :: CoreExpr -> Bool
exprIsDeadEnd :: CoreExpr -> Bool
exprIsDeadEnd CoreExpr
e
| Type -> Bool
isEmptyTy (HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
e)
= Bool
True
| Bool
otherwise
= Arity -> CoreExpr -> Bool
go Arity
0 CoreExpr
e
where
go :: Arity -> CoreExpr -> Bool
go Arity
n (Var Id
v) = Id -> Bool
isDeadEndId Id
v Bool -> Bool -> Bool
&& Arity
n Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
>= Id -> Arity
idArity Id
v
go Arity
n (App CoreExpr
e CoreExpr
a) | CoreExpr -> Bool
forall b. Expr b -> Bool
isTypeArg CoreExpr
a = Arity -> CoreExpr -> Bool
go Arity
n CoreExpr
e
| Bool
otherwise = Arity -> CoreExpr -> Bool
go (Arity
nArity -> Arity -> Arity
forall a. Num a => a -> a -> a
+Arity
1) CoreExpr
e
go Arity
n (Tick CoreTickish
_ CoreExpr
e) = Arity -> CoreExpr -> Bool
go Arity
n CoreExpr
e
go Arity
n (Cast CoreExpr
e Coercion
_) = Arity -> CoreExpr -> Bool
go Arity
n CoreExpr
e
go Arity
n (Let Bind Id
_ CoreExpr
e) = Arity -> CoreExpr -> Bool
go Arity
n CoreExpr
e
go Arity
n (Lam Id
v CoreExpr
e) | Id -> Bool
isTyVar Id
v = Arity -> CoreExpr -> Bool
go Arity
n CoreExpr
e
go Arity
_ (Case CoreExpr
_ Id
_ Type
_ [Alt Id]
alts) = [Alt Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Alt Id]
alts
go Arity
_ CoreExpr
_ = Bool
False
exprIsDupable :: Platform -> CoreExpr -> Bool
exprIsDupable :: Platform -> CoreExpr -> Bool
exprIsDupable Platform
platform CoreExpr
e
= Maybe Arity -> Bool
forall a. Maybe a -> Bool
isJust (Arity -> CoreExpr -> Maybe Arity
go Arity
dupAppSize CoreExpr
e)
where
go :: Int -> CoreExpr -> Maybe Int
go :: Arity -> CoreExpr -> Maybe Arity
go Arity
n (Type {}) = Arity -> Maybe Arity
forall a. a -> Maybe a
Just Arity
n
go Arity
n (Coercion {}) = Arity -> Maybe Arity
forall a. a -> Maybe a
Just Arity
n
go Arity
n (Var {}) = Arity -> Maybe Arity
decrement Arity
n
go Arity
n (Tick CoreTickish
_ CoreExpr
e) = Arity -> CoreExpr -> Maybe Arity
go Arity
n CoreExpr
e
go Arity
n (Cast CoreExpr
e Coercion
_) = Arity -> CoreExpr -> Maybe Arity
go Arity
n CoreExpr
e
go Arity
n (App CoreExpr
f CoreExpr
a) | Just Arity
n' <- Arity -> CoreExpr -> Maybe Arity
go Arity
n CoreExpr
a = Arity -> CoreExpr -> Maybe Arity
go Arity
n' CoreExpr
f
go Arity
n (Lit Literal
lit) | Platform -> Literal -> Bool
litIsDupable Platform
platform Literal
lit = Arity -> Maybe Arity
decrement Arity
n
go Arity
_ CoreExpr
_ = Maybe Arity
forall a. Maybe a
Nothing
decrement :: Int -> Maybe Int
decrement :: Arity -> Maybe Arity
decrement Arity
0 = Maybe Arity
forall a. Maybe a
Nothing
decrement Arity
n = Arity -> Maybe Arity
forall a. a -> Maybe a
Just (Arity
nArity -> Arity -> Arity
forall a. Num a => a -> a -> a
-Arity
1)
dupAppSize :: Int
dupAppSize :: Arity
dupAppSize = Arity
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 = Arity -> CoreExpr -> Bool
go Arity
0 CoreExpr
e
go :: Arity -> CoreExpr -> Bool
go Arity
n (Var Id
v) = CheapAppFun
ok_app Id
v Arity
n
go Arity
_ (Lit {}) = Bool
True
go Arity
_ (Type {}) = Bool
True
go Arity
_ (Coercion {}) = Bool
True
go Arity
n (Cast CoreExpr
e Coercion
_) = Arity -> CoreExpr -> Bool
go Arity
n CoreExpr
e
go Arity
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 [ Arity -> CoreExpr -> Bool
go Arity
n CoreExpr
rhs | Alt AltCon
_ [Id]
_ CoreExpr
rhs <- [Alt Id]
alts ]
go Arity
n (Tick CoreTickish
t CoreExpr
e) | CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishCounts CoreTickish
t = Bool
False
| Bool
otherwise = Arity -> CoreExpr -> Bool
go Arity
n CoreExpr
e
go Arity
n (Lam Id
x CoreExpr
e) | Id -> Bool
isRuntimeVar Id
x = Arity
nArity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
==Arity
0 Bool -> Bool -> Bool
|| Arity -> CoreExpr -> Bool
go (Arity
nArity -> Arity -> Arity
forall a. Num a => a -> a -> a
-Arity
1) CoreExpr
e
| Bool
otherwise = Arity -> CoreExpr -> Bool
go Arity
n CoreExpr
e
go Arity
n (App CoreExpr
f CoreExpr
e) | CoreExpr -> Bool
isRuntimeArg CoreExpr
e = Arity -> CoreExpr -> Bool
go (Arity
nArity -> Arity -> Arity
forall a. Num a => a -> a -> a
+Arity
1) CoreExpr
f Bool -> Bool -> Bool
&& CoreExpr -> Bool
ok CoreExpr
e
| Bool
otherwise = Arity -> CoreExpr -> Bool
go Arity
n CoreExpr
f
go Arity
n (Let (NonRec Id
_ CoreExpr
r) CoreExpr
e) = Arity -> CoreExpr -> Bool
go Arity
n CoreExpr
e Bool -> Bool -> Bool
&& CoreExpr -> Bool
ok CoreExpr
r
go Arity
n (Let (Rec [(Id, CoreExpr)]
prs) CoreExpr
e) = Arity -> CoreExpr -> Bool
go Arity
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 = Arity -> CoreExpr -> Bool
go Arity
0 CoreExpr
e
go :: Arity -> CoreExpr -> Bool
go Arity
n (Var Id
v) = CheapAppFun
isExpandableApp Id
v Arity
n
go Arity
_ (Lit {}) = Bool
True
go Arity
_ (Type {}) = Bool
True
go Arity
_ (Coercion {}) = Bool
True
go Arity
n (Cast CoreExpr
e Coercion
_) = Arity -> CoreExpr -> Bool
go Arity
n CoreExpr
e
go Arity
n (Tick CoreTickish
t CoreExpr
e) | CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishCounts CoreTickish
t = Bool
False
| Bool
otherwise = Arity -> CoreExpr -> Bool
go Arity
n CoreExpr
e
go Arity
n (Lam Id
x CoreExpr
e) | Id -> Bool
isRuntimeVar Id
x = Arity
nArity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
==Arity
0 Bool -> Bool -> Bool
|| Arity -> CoreExpr -> Bool
go (Arity
nArity -> Arity -> Arity
forall a. Num a => a -> a -> a
-Arity
1) CoreExpr
e
| Bool
otherwise = Arity -> CoreExpr -> Bool
go Arity
n CoreExpr
e
go Arity
n (App CoreExpr
f CoreExpr
e) | CoreExpr -> Bool
isRuntimeArg CoreExpr
e = Arity -> CoreExpr -> Bool
go (Arity
nArity -> Arity -> Arity
forall a. Num a => a -> a -> a
+Arity
1) CoreExpr
f Bool -> Bool -> Bool
&& CoreExpr -> Bool
ok CoreExpr
e
| Bool
otherwise = Arity -> CoreExpr -> Bool
go Arity
n CoreExpr
f
go Arity
_ (Case {}) = Bool
False
go Arity
_ (Let {}) = Bool
False
type CheapAppFun = Id -> Arity -> Bool
isWorkFreeApp :: CheapAppFun
isWorkFreeApp :: CheapAppFun
isWorkFreeApp Id
fn Arity
n_val_args
| Arity
n_val_args Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
0
= Bool
True
| Arity
n_val_args Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
< Id -> Arity
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 Arity
n_val_args
| CheapAppFun
isWorkFreeApp Id
fn Arity
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 {} -> Arity
n_val_args Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
1
ClassOpId {} -> Arity
n_val_args Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
1
PrimOpId PrimOp
op -> PrimOp -> Bool
primOpIsCheap PrimOp
op
IdDetails
_ -> Bool
False
isExpandableApp :: CheapAppFun
isExpandableApp :: CheapAppFun
isExpandableApp Id
fn Arity
n_val_args
| CheapAppFun
isWorkFreeApp Id
fn Arity
n_val_args = Bool
True
| Bool
otherwise
= case Id -> IdDetails
idDetails Id
fn of
RecSelId {} -> Arity
n_val_args Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
1
ClassOpId {} -> Arity
n_val_args Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
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 = Arity -> Type -> Bool
forall a. (Eq a, Num a) => a -> Type -> Bool
all_pred_args Arity
n_val_args (Id -> Type
idType Id
fn)
all_pred_args :: a -> Type -> Bool
all_pred_args a
n_val_args Type
ty
| a
n_val_args a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0
= Bool
True
| Just (TyCoBinder
bndr, Type
ty) <- Type -> Maybe (TyCoBinder, Type)
splitPiTy_maybe Type
ty
= case TyCoBinder
bndr of
Named {} -> a -> Type -> Bool
all_pred_args a
n_val_args Type
ty
Anon AnonArgFlag
InvisArg Scaled Type
_ -> a -> Type -> Bool
all_pred_args (a
n_val_argsa -> a -> a
forall a. Num a => a -> a -> a
-a
1) Type
ty
Anon AnonArgFlag
VisArg Scaled Type
_ -> Bool
False
| Bool
otherwise
= Bool
False
exprOkForSpeculation, exprOkForSideEffects :: CoreExpr -> Bool
exprOkForSpeculation :: CoreExpr -> Bool
exprOkForSpeculation = (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok PrimOp -> Bool
primOpOkForSpeculation
exprOkForSideEffects :: CoreExpr -> Bool
exprOkForSideEffects = (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok PrimOp -> Bool
primOpOkForSideEffects
expr_ok :: (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok :: (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok PrimOp -> Bool
_ (Lit Literal
_) = Bool
True
expr_ok PrimOp -> Bool
_ (Type Type
_) = Bool
True
expr_ok PrimOp -> Bool
_ (Coercion Coercion
_) = Bool
True
expr_ok PrimOp -> Bool
primop_ok (Var Id
v) = (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool
app_ok PrimOp -> Bool
primop_ok Id
v []
expr_ok PrimOp -> Bool
primop_ok (Cast CoreExpr
e Coercion
_) = (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok PrimOp -> Bool
primop_ok CoreExpr
e
expr_ok PrimOp -> Bool
primop_ok (Lam Id
b CoreExpr
e)
| Id -> Bool
isTyVar Id
b = (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok PrimOp -> Bool
primop_ok CoreExpr
e
| Bool
otherwise = Bool
True
expr_ok PrimOp -> Bool
primop_ok (Tick CoreTickish
tickish CoreExpr
e)
| CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishCounts CoreTickish
tickish = Bool
False
| Bool
otherwise = (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok PrimOp -> Bool
primop_ok CoreExpr
e
expr_ok PrimOp -> Bool
_ (Let {}) = Bool
False
expr_ok PrimOp -> Bool
primop_ok (Case CoreExpr
scrut Id
bndr Type
_ [Alt Id]
alts)
=
(PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok PrimOp -> Bool
primop_ok CoreExpr
scrut
Bool -> Bool -> Bool
&& HasDebugCallStack => 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) -> (PrimOp -> Bool) -> CoreExpr -> Bool
expr_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 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 ->
(PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool
app_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 :: (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool
app_ok :: (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool
app_ok PrimOp -> Bool
primop_ok Id
fun [CoreExpr]
args
= case Id -> IdDetails
idDetails Id
fun of
DFunId Bool
new_type -> Bool -> Bool
not Bool
new_type
DataConWorkId {} -> Bool
True
PrimOpId PrimOp
op
| PrimOp -> Bool
primOpIsDiv PrimOp
op
, [CoreExpr
arg1, Lit Literal
lit] <- [CoreExpr]
args
-> Bool -> Bool
not (Literal -> Bool
isZeroLit Literal
lit) Bool -> Bool -> Bool
&& (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok PrimOp -> Bool
primop_ok CoreExpr
arg1
| PrimOp
SeqOp <- PrimOp
op
-> Bool
False
| PrimOp
DataToTagOp <- PrimOp
op
-> Bool
False
| PrimOp
KeepAliveOp <- PrimOp
op
-> Bool
False
| Bool
otherwise
-> PrimOp -> Bool
primop_ok PrimOp
op
Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((TyCoBinder -> CoreExpr -> Bool)
-> [TyCoBinder] -> [CoreExpr] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith TyCoBinder -> CoreExpr -> Bool
arg_ok [TyCoBinder]
arg_tys [CoreExpr]
args)
IdDetails
_
| Just Levity
Unlifted <- HasDebugCallStack => 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 (Arity
n_val_args Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
0) (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
fun SDoc -> SDoc -> SDoc
$$ [CoreExpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CoreExpr]
args)
Bool
True
| Id -> Arity
idArity Id
fun Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
> Arity
n_val_args ->
[Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((TyCoBinder -> CoreExpr -> Bool)
-> [TyCoBinder] -> [CoreExpr] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith TyCoBinder -> CoreExpr -> Bool
arg_ok [TyCoBinder]
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 :: Arity
n_val_args = [CoreExpr] -> Arity
forall b. [Arg b] -> Arity
valArgCount [CoreExpr]
args
([TyCoBinder]
arg_tys, Type
_) = Type -> ([TyCoBinder], Type)
splitPiTys (Id -> Type
idType Id
fun)
arg_ok :: TyBinder -> CoreExpr -> Bool
arg_ok :: TyCoBinder -> CoreExpr -> Bool
arg_ok (Named TyCoVarBinder
_) CoreExpr
_ = Bool
True
arg_ok (Anon AnonArgFlag
_ Scaled Type
ty) CoreExpr
arg
| Just Levity
Lifted <- HasDebugCallStack => Type -> Maybe Levity
Type -> Maybe Levity
typeLevity_maybe (Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
ty)
= Bool
True
| Bool
otherwise
= (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok PrimOp -> Bool
primop_ok CoreExpr
arg
altsAreExhaustive :: [Alt b] -> Bool
altsAreExhaustive :: [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] -> Arity -> Bool
forall a. [a] -> Arity -> Bool
`lengthIs` (TyCon -> Arity
tyConFamilySize (DataCon -> TyCon
dataConTyCon DataCon
c) Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
- Arity
1)
exprIsHNF :: CoreExpr -> Bool
exprIsHNF :: CoreExpr -> Bool
exprIsHNF = HasDebugCallStack =>
(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 = HasDebugCallStack =>
(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 :: (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 Arity
0
Bool -> Bool -> Bool
|| Unfolding -> Bool
is_con_unf (Id -> Unfolding
idUnfolding Id
v)
Bool -> Bool -> Bool
|| ( HasDebugCallStack => 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 -> Arity -> Bool
app_is_value CoreExpr
e Arity
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 -> Arity -> Bool
app_is_value (Var Id
f) Arity
nva = CheapAppFun
id_app_is_value Id
f Arity
nva
app_is_value (Tick CoreTickish
_ CoreExpr
f) Arity
nva = CoreExpr -> Arity -> Bool
app_is_value CoreExpr
f Arity
nva
app_is_value (Cast CoreExpr
f Coercion
_) Arity
nva = CoreExpr -> Arity -> Bool
app_is_value CoreExpr
f Arity
nva
app_is_value (App CoreExpr
f CoreExpr
a) Arity
nva
| CoreExpr -> Bool
forall b. Expr b -> Bool
isValArg CoreExpr
a =
CoreExpr -> Arity -> Bool
app_is_value CoreExpr
f (Arity
nva Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
+ Arity
1) Bool -> Bool -> Bool
&&
Bool -> Bool
not (Type -> CoreExpr -> Bool
needsCaseBinding (HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
a) CoreExpr
a)
| Bool
otherwise = CoreExpr -> Arity -> Bool
app_is_value CoreExpr
f Arity
nva
app_is_value CoreExpr
_ Arity
_ = Bool
False
id_app_is_value :: CheapAppFun
id_app_is_value Id
id Arity
n_val_args
= Id -> Bool
is_con Id
id
Bool -> Bool -> Bool
|| Id -> Arity
idArity Id
id Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
> Arity
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 :: Arity
n_ex = [Id] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Id]
ex_tvs
([Unique]
ex_uniqs, [Unique]
id_uniqs) = Arity -> [Unique] -> ([Unique], [Unique])
forall a. Arity -> [a] -> ([a], [a])
splitAt Arity
n_ex [Unique]
uniqs
([FastString]
ex_fss, [FastString]
id_fss) = Arity -> [FastString] -> ([FastString], [FastString])
forall a. Arity -> [a] -> ([a], [a])
splitAt Arity
n_ex [FastString]
fss
univ_subst :: TCvSubst
univ_subst = [Id] -> [Type] -> TCvSubst
HasDebugCallStack => [Id] -> [Type] -> TCvSubst
zipTvSubst [Id]
univ_tvs [Type]
inst_tys
(TCvSubst
full_subst, [Id]
ex_bndrs) = (TCvSubst -> (Id, FastString, Unique) -> (TCvSubst, Id))
-> TCvSubst -> [(Id, FastString, Unique)] -> (TCvSubst, [Id])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL TCvSubst -> (Id, FastString, Unique) -> (TCvSubst, Id)
mk_ex_var TCvSubst
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 :: TCvSubst -> (TyCoVar, FastString, Unique) -> (TCvSubst, TyCoVar)
mk_ex_var :: TCvSubst -> (Id, FastString, Unique) -> (TCvSubst, Id)
mk_ex_var TCvSubst
subst (Id
tv, FastString
fs, Unique
uniq) = (TCvSubst -> Id -> Id -> TCvSubst
Type.extendTCvSubstWithClone TCvSubst
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 = TCvSubst -> Type -> Type
Type.substTyUnchecked TCvSubst
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) (HasDebugCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
Type.substTy TCvSubst
full_subst Type
ty)
where
name :: Name
name = Unique -> OccName -> SrcSpan -> Name
mkInternalName Unique
uniq (FastString -> OccName
mkVarOccFS FastString
fs) SrcSpan
noSrcSpan
cheapEqExpr :: Expr b -> Expr b -> Bool
cheapEqExpr :: 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' :: (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
eqExpr :: InScopeSet -> CoreExpr -> CoreExpr -> Bool
eqExpr :: InScopeSet -> CoreExpr -> CoreExpr -> Bool
eqExpr InScopeSet
_ = CoreExpr -> CoreExpr -> Bool
eqCoreExpr
{-# DEPRECATED eqExpr "Use 'GHC.Core.Map.Expr.eqCoreExpr', 'eqExpr' will be removed in GHC 9.6" #-}
eqTickish :: RnEnv2 -> CoreTickish -> CoreTickish -> Bool
eqTickish :: RnEnv2 -> CoreTickish -> CoreTickish -> Bool
eqTickish RnEnv2
env (Breakpoint XBreakpoint 'TickishPassCore
lext Arity
lid [XTickishId 'TickishPassCore]
lids) (Breakpoint XBreakpoint 'TickishPassCore
rext Arity
rid [XTickishId 'TickishPassCore]
rids)
= Arity
lid Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
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 = Arity
-> RnEnv2
-> [(Id, CoreExpr)]
-> [(Id, CoreExpr)]
-> ([SDoc], RnEnv2)
go ([(Id, CoreExpr)] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [(Id, CoreExpr)]
binds1) RnEnv2
env [(Id, CoreExpr)]
binds1
where go :: Arity
-> RnEnv2
-> [(Id, CoreExpr)]
-> [(Id, CoreExpr)]
-> ([SDoc], RnEnv2)
go Arity
_ RnEnv2
env [] []
= ([], RnEnv2
env)
go Arity
fuel RnEnv2
env [(Id, CoreExpr)]
binds1 [(Id, CoreExpr)]
binds2
| [(Id, CoreExpr)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Id, CoreExpr)]
binds1 Bool -> Bool -> Bool
|| [(Id, CoreExpr)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Id, CoreExpr)]
binds2
= (RnEnv2 -> [(Id, CoreExpr)] -> [(Id, CoreExpr)] -> [SDoc]
warn RnEnv2
env [(Id, CoreExpr)]
binds1 [(Id, CoreExpr)]
binds2, RnEnv2
env)
| Arity
fuel Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
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)] -> (Id, CoreExpr)
forall a. [a] -> a
head [(Id, CoreExpr)]
binds1)
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 Arity
-> RnEnv2
-> [(Id, CoreExpr)]
-> [(Id, CoreExpr)]
-> ([SDoc], RnEnv2)
go ([(Id, CoreExpr)] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
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 Arity
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 (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 (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
= Arity
-> RnEnv2
-> [(Id, CoreExpr)]
-> [(Id, CoreExpr)]
-> ([SDoc], RnEnv2)
go ([(Id, CoreExpr)] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
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
= Arity
-> RnEnv2
-> [(Id, CoreExpr)]
-> [(Id, CoreExpr)]
-> ([SDoc], RnEnv2)
go (Arity
fuelArity -> Arity -> Arity
forall a. Num a => a -> a -> a
-Arity
1) RnEnv2
env ([(Id, CoreExpr)]
binds1[(Id, CoreExpr)] -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. [a] -> [a] -> [a]
++[(Id
bndr1,CoreExpr
expr1)]) [(Id, CoreExpr)]
binds2
go Arity
_ RnEnv2
_ [(Id, CoreExpr)]
_ [(Id, CoreExpr)]
_ = String -> ([SDoc], RnEnv2)
forall a. String -> a
panic String
"diffBinds: impossible"
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:" (Arity -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. Arity -> [a] -> [a]
drop Arity
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:" (Arity -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. Arity -> [a] -> [a]
drop Arity
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 :: Arity
l = Arity -> Arity -> Arity
forall a. Ord a => a -> a -> a
min ([(Id, CoreExpr)] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [(Id, CoreExpr)]
binds1') ([(Id, CoreExpr)] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [(Id, CoreExpr)]
binds2')
unmatched :: String -> [(b, Expr b)] -> [SDoc]
unmatched String
_ [] = []
unmatched String
txt [(b, Expr b)]
bs = [String -> SDoc
text String
txt SDoc -> SDoc -> SDoc
$$ 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 (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
text String
"alt-cons " SDoc -> SDoc -> SDoc
<> AltCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr AltCon
c1 SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" /= " SDoc -> SDoc -> SDoc
<> 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
fsep [CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
e1, String -> SDoc
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 -> Arity
arityInfo IdInfo
info1 Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== IdInfo -> Arity
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 -> Arity
callArityInfo IdInfo
info1 Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== IdInfo -> Arity
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
fsep [BindingSite -> Id -> SDoc
forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
LetBind Id
bndr1, String -> SDoc
text String
"/=", BindingSite -> Id -> SDoc
forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
LetBind Id
bndr2]]
where info1 :: IdInfo
info1 = HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
bndr1; info2 :: IdInfo
info2 = HasDebugCallStack => 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
_ Bool
v1 Bool
cl1 Bool
wf1 Bool
x1 UnfoldingGuidance
g1)
(CoreUnfolding CoreExpr
t2 UnfoldingSource
_ Bool
_ Bool
v2 Bool
cl2 Bool
wf2 Bool
x2 UnfoldingGuidance
g2)
| Bool
v1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
v2 Bool -> Bool -> Bool
&& Bool
cl1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
cl2
Bool -> Bool -> Bool
&& Bool
wf1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
wf2 Bool -> Bool -> Bool
&& Bool
x1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
x2 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
fsep [Unfolding -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unfolding
uf1, String -> SDoc
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
$$ Arity -> SDoc -> SDoc
nest Arity
2 (SDoc -> SDoc
parens (String -> SDoc
text String
loc SDoc -> SDoc -> SDoc
<+> 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
<> Char -> SDoc
char Char
'/' SDoc -> SDoc -> SDoc
<> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
b2
tryEtaReduce :: [Var] -> CoreExpr -> SubDemand -> Maybe CoreExpr
tryEtaReduce :: [Id] -> CoreExpr -> SubDemand -> Maybe CoreExpr
tryEtaReduce [Id]
bndrs CoreExpr
body SubDemand
eval_sd
= [Id] -> CoreExpr -> Coercion -> Maybe CoreExpr
go ([Id] -> [Id]
forall a. [a] -> [a]
reverse [Id]
bndrs) CoreExpr
body (Type -> Coercion
mkRepReflCo (HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
body))
where
incoming_arity :: Arity
incoming_arity = (Id -> Bool) -> [Id] -> Arity
forall a. (a -> Bool) -> [a] -> Arity
count Id -> Bool
isId [Id]
bndrs
go :: [Var]
-> CoreExpr
-> Coercion
-> Maybe CoreExpr
go :: [Id] -> CoreExpr -> Coercion -> Maybe CoreExpr
go [Id]
bs (Tick CoreTickish
t CoreExpr
e) Coercion
co
| CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable CoreTickish
t
= (CoreExpr -> CoreExpr) -> Maybe CoreExpr -> Maybe CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t) (Maybe CoreExpr -> Maybe CoreExpr)
-> Maybe CoreExpr -> Maybe CoreExpr
forall a b. (a -> b) -> a -> b
$ [Id] -> CoreExpr -> Coercion -> Maybe CoreExpr
go [Id]
bs CoreExpr
e Coercion
co
go (Id
b : [Id]
bs) (App CoreExpr
fun CoreExpr
arg) Coercion
co
| Just (Coercion
co', [CoreTickish]
ticks) <- Id
-> CoreExpr -> Coercion -> Type -> Maybe (Coercion, [CoreTickish])
ok_arg Id
b CoreExpr
arg Coercion
co (HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
fun)
= (CoreExpr -> CoreExpr) -> Maybe CoreExpr -> Maybe CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CoreExpr -> [CoreTickish] -> CoreExpr)
-> [CoreTickish] -> CoreExpr -> CoreExpr
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((CoreTickish -> CoreExpr -> CoreExpr)
-> CoreExpr -> [CoreTickish] -> CoreExpr
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CoreTickish -> CoreExpr -> CoreExpr
mkTick) [CoreTickish]
ticks) (Maybe CoreExpr -> Maybe CoreExpr)
-> Maybe CoreExpr -> Maybe CoreExpr
forall a b. (a -> b) -> a -> b
$ [Id] -> CoreExpr -> Coercion -> Maybe CoreExpr
go [Id]
bs CoreExpr
fun Coercion
co'
go [Id]
remaining_bndrs CoreExpr
fun Coercion
co
| (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Id -> Bool
isTyVar [Id]
remaining_bndrs
, [Id]
remaining_bndrs [Id] -> [Id] -> Bool
forall a b. [a] -> [b] -> Bool
`ltLength` [Id]
bndrs
, CoreExpr -> Bool
ok_fun CoreExpr
fun
, let used_vars :: VarSet
used_vars = CoreExpr -> VarSet
exprFreeVars CoreExpr
fun VarSet -> VarSet -> VarSet
`unionVarSet` Coercion -> VarSet
tyCoVarsOfCo Coercion
co
reduced_bndrs :: VarSet
reduced_bndrs = [Id] -> VarSet
mkVarSet ([Id] -> [Id] -> [Id]
forall b a. [b] -> [a] -> [a]
dropList [Id]
remaining_bndrs [Id]
bndrs)
, VarSet
used_vars VarSet -> VarSet -> Bool
`disjointVarSet` VarSet
reduced_bndrs
= CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (CoreExpr -> Maybe CoreExpr) -> CoreExpr -> Maybe CoreExpr
forall a b. (a -> b) -> a -> b
$ [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams ([Id] -> [Id]
forall a. [a] -> [a]
reverse [Id]
remaining_bndrs) (CoreExpr -> Coercion -> CoreExpr
mkCast CoreExpr
fun Coercion
co)
go [Id]
_remaining_bndrs CoreExpr
_fun Coercion
_ =
Maybe CoreExpr
forall a. Maybe a
Nothing
ok_fun :: CoreExpr -> Bool
ok_fun (App CoreExpr
fun (Type {})) = CoreExpr -> Bool
ok_fun CoreExpr
fun
ok_fun (Cast CoreExpr
fun Coercion
_) = CoreExpr -> Bool
ok_fun CoreExpr
fun
ok_fun (Tick CoreTickish
_ CoreExpr
expr) = CoreExpr -> Bool
ok_fun CoreExpr
expr
ok_fun (Var Id
fun_id) = Id -> Bool
is_eta_reduction_sound Id
fun_id Bool -> Bool -> Bool
|| (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Id -> Bool
ok_lam [Id]
bndrs
ok_fun CoreExpr
_fun = Bool
False
is_eta_reduction_sound :: Id -> Bool
is_eta_reduction_sound Id
fun =
(Id -> Arity
fun_arity Id
fun Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
>= Arity
incoming_arity
Bool -> Bool -> Bool
|| Arity -> Bool
all_calls_with_arity Arity
incoming_arity)
Bool -> Bool -> Bool
&& Id -> Arity -> Arity -> Bool
canEtaReduceToArity Id
fun Arity
0 Arity
0
all_calls_with_arity :: Arity -> Bool
all_calls_with_arity Arity
n = Card -> Bool
isStrict (Arity -> SubDemand -> Card
peelManyCalls Arity
n SubDemand
eval_sd)
fun_arity :: Id -> Arity
fun_arity Id
fun
| Id -> Bool
isLocalId Id
fun
, OccInfo -> Bool
isStrongLoopBreaker (Id -> OccInfo
idOccInfo Id
fun) = Arity
0
| Arity
arity Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
> Arity
0 = Arity
arity
| Unfolding -> Bool
isEvaldUnfolding (Id -> Unfolding
idUnfolding Id
fun) = Arity
1
| Bool
otherwise = Arity
0
where
arity :: Arity
arity = Id -> Arity
idArity Id
fun
ok_lam :: Id -> Bool
ok_lam Id
v = Id -> Bool
isTyVar Id
v Bool -> Bool -> Bool
|| Id -> Bool
isEvVar Id
v
ok_arg :: Var
-> CoreExpr
-> Coercion
-> Type
-> Maybe (Coercion
, [CoreTickish])
ok_arg :: Id
-> CoreExpr -> Coercion -> Type -> Maybe (Coercion, [CoreTickish])
ok_arg Id
bndr (Type Type
ty) Coercion
co Type
_
| Just Id
tv <- Type -> Maybe Id
getTyVar_maybe Type
ty
, Id
bndr Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
tv = (Coercion, [CoreTickish]) -> Maybe (Coercion, [CoreTickish])
forall a. a -> Maybe a
Just ([Id] -> Coercion -> Coercion
mkHomoForAllCos [Id
tv] Coercion
co, [])
ok_arg Id
bndr (Var Id
v) Coercion
co Type
fun_ty
| Id
bndr Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
v
, let mult :: Type
mult = Id -> Type
idMult Id
bndr
, Just (Type
fun_mult, Type
_, Type
_) <- Type -> Maybe (Type, Type, Type)
splitFunTy_maybe Type
fun_ty
, Type
mult Type -> Type -> Bool
`eqType` Type
fun_mult
= (Coercion, [CoreTickish]) -> Maybe (Coercion, [CoreTickish])
forall a. a -> Maybe a
Just (Role -> Scaled Type -> Coercion -> Coercion
mkFunResCo Role
Representational (Id -> Scaled Type
idScaledType Id
bndr) Coercion
co, [])
ok_arg Id
bndr (Cast CoreExpr
e Coercion
co_arg) Coercion
co Type
fun_ty
| ([CoreTickish]
ticks, Var Id
v) <- (CoreTickish -> Bool) -> CoreExpr -> ([CoreTickish], CoreExpr)
forall b.
(CoreTickish -> Bool) -> Expr b -> ([CoreTickish], Expr b)
stripTicksTop CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable CoreExpr
e
, Just (Type
fun_mult, Type
_, Type
_) <- Type -> Maybe (Type, Type, Type)
splitFunTy_maybe Type
fun_ty
, Id
bndr Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
v
, Type
fun_mult Type -> Type -> Bool
`eqType` Id -> Type
idMult Id
bndr
= (Coercion, [CoreTickish]) -> Maybe (Coercion, [CoreTickish])
forall a. a -> Maybe a
Just (Role -> Coercion -> Coercion -> Coercion -> Coercion
mkFunCo Role
Representational (Type -> Coercion
multToCo Type
fun_mult) (Coercion -> Coercion
mkSymCo Coercion
co_arg) Coercion
co, [CoreTickish]
ticks)
ok_arg Id
bndr (Tick CoreTickish
t CoreExpr
arg) Coercion
co Type
fun_ty
| CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable CoreTickish
t, Just (Coercion
co', [CoreTickish]
ticks) <- Id
-> CoreExpr -> Coercion -> Type -> Maybe (Coercion, [CoreTickish])
ok_arg Id
bndr CoreExpr
arg Coercion
co Type
fun_ty
= (Coercion, [CoreTickish]) -> Maybe (Coercion, [CoreTickish])
forall a. a -> Maybe a
Just (Coercion
co', CoreTickish
tCoreTickish -> [CoreTickish] -> [CoreTickish]
forall a. a -> [a] -> [a]
:[CoreTickish]
ticks)
ok_arg Id
_ CoreExpr
_ Coercion
_ Type
_ = Maybe (Coercion, [CoreTickish])
forall a. Maybe a
Nothing
canEtaReduceToArity :: Id -> JoinArity -> Arity -> Bool
canEtaReduceToArity :: Id -> Arity -> Arity -> Bool
canEtaReduceToArity Id
fun Arity
dest_join_arity Arity
dest_arity =
Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
Id -> Bool
hasNoBinding Id
fun
Bool -> Bool -> Bool
|| ( Id -> Bool
isJoinId Id
fun Bool -> Bool -> Bool
&& Arity
dest_join_arity Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
< Id -> Arity
idJoinArity Id
fun )
Bool -> Bool -> Bool
|| ( Arity
dest_arity Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
< Id -> Arity
idCbvMarkArity Id
fun )
Bool -> Bool -> Bool
|| Type -> Bool
isLinearType (Id -> Type
idType Id
fun)
isEmptyTy :: Type -> Bool
isEmptyTy :: Type -> Bool
isEmptyTy Type
ty
| Just (TyCon
tc, [Type]
inst_tys) <- HasDebugCallStack => 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) <- HasDebugCallStack => 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
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
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 b. Bind b -> [b]
getIds [Bind Id]
binds)
getIds :: Bind b -> [b]
getIds (NonRec b
i Expr b
_) = [ b
i ]
getIds (Rec [(b, Expr b)]
bs) = ((b, Expr b) -> b) -> [(b, Expr b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (b, Expr b) -> b
forall a b. (a, b) -> a
fst [(b, Expr b)]
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
<> SDoc
colon SDoc -> SDoc -> SDoc
<+> (IdInfo -> SDoc
ppr_id_info (HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
id))
| Bool
otherwise = SDoc
empty
computeCbvInfo :: HasCallStack
=> Id
-> CoreExpr
-> Id
computeCbvInfo :: Id -> CoreExpr -> Id
computeCbvInfo Id
id CoreExpr
rhs =
Id
cbv_bndr
where
([Id]
_,[Id]
val_args,CoreExpr
_body) = CoreExpr -> ([Id], [Id], CoreExpr)
collectTyAndValBinders CoreExpr
rhs
new_marks :: [CbvMark]
new_marks = [Id] -> [CbvMark]
mkCbvMarks [Id]
val_args
cbv_marks :: [CbvMark]
cbv_marks = Bool -> SDoc -> [CbvMark] -> [CbvMark]
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Id -> [CbvMark] -> Bool
checkMarks Id
id [CbvMark]
new_marks)
(Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Type
idType Id
id) SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"old:" SDoc -> SDoc -> SDoc
<> Maybe [CbvMark] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Maybe [CbvMark]
idCbvMarks_maybe Id
id) SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"new:" SDoc -> SDoc -> SDoc
<> [CbvMark] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CbvMark]
new_marks SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"rhs:" SDoc -> SDoc -> SDoc
<> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
rhs)
[CbvMark]
new_marks
cbv_bndr :: Id
cbv_bndr
| [Id] -> Bool
forall (t :: * -> *). Foldable t => t Id -> Bool
valid_unlifted_worker [Id]
val_args
= [CbvMark]
cbv_marks [CbvMark] -> Id -> Id
forall a b. [a] -> b -> b
`seqList` Id -> [CbvMark] -> Id
setIdCbvMarks Id
id [CbvMark]
cbv_marks
| Bool
otherwise =
Id
id
valid_unlifted_worker :: t Id -> Bool
valid_unlifted_worker t Id
args =
Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ((Id -> Bool) -> t Id -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Id
arg -> Id -> Bool
isMultiValArg Id
arg) t Id
args)
isMultiValArg :: Id -> Bool
isMultiValArg Id
id =
let ty :: Type
ty = Id -> Type
idType Id
id
in Bool -> Bool
not (Type -> Bool
isStateType Type
ty) Bool -> Bool -> Bool
&& (Type -> Bool
isUnboxedTupleType Type
ty Bool -> Bool -> Bool
|| Type -> Bool
isUnboxedSumType Type
ty)
trimMarks :: [CbvMark] -> [Id] -> [CbvMark]
trimMarks :: [CbvMark] -> [Id] -> [CbvMark]
trimMarks [CbvMark]
marks [Id]
val_args =
((CbvMark, Id) -> CbvMark) -> [(CbvMark, Id)] -> [CbvMark]
forall a b. (a -> b) -> [a] -> [b]
map (CbvMark, Id) -> CbvMark
forall a b. (a, b) -> a
fst ([(CbvMark, Id)] -> [CbvMark])
-> ([(CbvMark, Id)] -> [(CbvMark, Id)])
-> [(CbvMark, Id)]
-> [CbvMark]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
((CbvMark, Id) -> Bool) -> [(CbvMark, Id)] -> [(CbvMark, Id)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEndLE (\(CbvMark
m,Id
v) -> Bool -> Bool
not (CbvMark -> Bool
isMarkedCbv CbvMark
m) Bool -> Bool -> Bool
|| HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType (Id -> Type
idType Id
v)) ([(CbvMark, Id)] -> [CbvMark]) -> [(CbvMark, Id)] -> [CbvMark]
forall a b. (a -> b) -> a -> b
$
[CbvMark] -> [Id] -> [(CbvMark, Id)]
forall a b. [a] -> [b] -> [(a, b)]
zip [CbvMark]
marks [Id]
val_args
mkCbvMarks :: ([Id]) -> [CbvMark]
mkCbvMarks :: [Id] -> [CbvMark]
mkCbvMarks = (Id -> CbvMark) -> [Id] -> [CbvMark]
forall a b. (a -> b) -> [a] -> [b]
map Id -> CbvMark
mkMark
where
cbv_arg :: Id -> Bool
cbv_arg Id
arg = Unfolding -> Bool
isEvaldUnfolding (Id -> Unfolding
idUnfolding Id
arg)
mkMark :: Id -> CbvMark
mkMark Id
arg
| Id -> Bool
cbv_arg Id
arg
, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType (Id -> Type
idType Id
arg)
= CbvMark
MarkedCbv
| Bool
otherwise
= CbvMark
NotMarkedCbv
checkMarks :: Id -> [CbvMark] -> Bool
checkMarks Id
id [CbvMark]
new_marks
| Just [CbvMark]
old_marks <- Id -> Maybe [CbvMark]
idCbvMarks_maybe Id
id
= [CbvMark] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length ([CbvMark] -> [Id] -> [CbvMark]
trimMarks [CbvMark]
old_marks [Id]
val_args) Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
<= [CbvMark] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [CbvMark]
new_marks Bool -> Bool -> Bool
&&
[Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((CbvMark -> CbvMark -> Bool) -> [CbvMark] -> [CbvMark] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith CbvMark -> CbvMark -> Bool
checkNewMark [CbvMark]
old_marks [CbvMark]
new_marks)
| Bool
otherwise = Bool
True
checkNewMark :: CbvMark -> CbvMark -> Bool
checkNewMark CbvMark
old CbvMark
new =
CbvMark -> Bool
isMarkedCbv CbvMark
new Bool -> Bool -> Bool
|| (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ CbvMark -> Bool
isMarkedCbv CbvMark
old)
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