{-# LANGUAGE CPP #-}
module GHC.Core.Utils (
mkCast, mkCastMCo, mkPiMCo,
mkTick, mkTicks, mkTickNoHNF, tickHNFArgs,
bindNonRec, needsCaseBinding,
mkAltExpr, mkDefaultCase, mkSingleAltCase,
findDefault, addDefault, findAlt, isDefaultAlt,
mergeAlts, trimConArgs,
filterAlts, combineIdenticalAlts, refineDefaultAlt,
scaleAltsBy,
exprType, coreAltType, coreAltsType, mkLamType, mkLamTypes,
mkFunctionType,
isExprLevPoly,
exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsDeadEnd,
getIdFromTrivialExpr_maybe,
exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun,
exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprIsWorkFree,
exprIsConLike,
isCheapApp, isExpandableApp,
exprIsTickedString, exprIsTickedString_maybe,
exprIsTopLevelBindable,
altsAreExhaustive,
cheapEqExpr, cheapEqExpr', eqExpr,
diffExpr, diffBinds,
tryEtaReduce, zapLamBndrs,
exprToType, exprToCoercion_maybe,
applyTypeToArgs, applyTypeToArg,
dataConRepInstPat, dataConRepFSInstPat,
isEmptyTy,
stripTicksTop, stripTicksTopE, stripTicksTopT,
stripTicksE, stripTicksT,
collectMakeStaticArgs,
isJoinBind,
isUnsafeEqualityProof,
dumpIdInfoOfProgram
) where
#include "GhclibHsVersions.h"
import GHC.Prelude
import GHC.Platform
import GHC.Driver.Ppr
import GHC.Core
import GHC.Builtin.Names (absentErrorIdKey, makeStaticName, unsafeEqualityProofName)
import GHC.Core.Ppr
import GHC.Core.FVs( exprFreeVars )
import GHC.Types.Var
import GHC.Types.SrcLoc
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Types.Name
import GHC.Types.Literal
import GHC.Types.Tickish
import GHC.Core.DataCon
import GHC.Builtin.PrimOps
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Core.Type as Type
import GHC.Core.Predicate
import GHC.Core.TyCo.Rep( TyCoBinder(..), TyBinder )
import GHC.Core.Coercion
import GHC.Core.TyCon
import GHC.Core.Multiplicity
import GHC.Types.Unique
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Data.FastString
import GHC.Data.Maybe
import GHC.Data.List.SetOps( minusList )
import GHC.Types.Basic ( Arity, FullArgCount )
import GHC.Utils.Misc
import GHC.Data.Pair
import Data.ByteString ( ByteString )
import Data.Function ( on )
import Data.List ( sort, sortBy, partition, zipWith4, mapAccumL )
import Data.Ord ( comparing )
import GHC.Data.OrdList
import qualified Data.Set as Set
import GHC.Types.Unique.Set
exprType :: CoreExpr -> Type
exprType :: CoreExpr -> Type
exprType (Var 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] (CoreExpr -> Type
exprType CoreExpr
body)
| Bool
otherwise = 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) = CoreExpr -> Type
exprType CoreExpr
e
exprType (Lam Id
binder CoreExpr
expr) = Id -> Type -> Type
mkLamType Id
binder (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) -> SDoc -> Type -> [CoreExpr] -> Type
applyTypeToArgs (CoreExpr -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr CoreExpr
e) (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 = 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
"corAltsType"
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
= ASSERT(eqType mult Many)
Type -> Type -> Type -> Type
mkInvisFunTy Type
mult Type
arg_ty Type
res_ty
| Bool
otherwise
= Type -> Type -> Type -> Type
mkVisFunTy Type
mult Type
arg_ty Type
res_ty
mkLamTypes :: [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
isExprLevPoly :: CoreExpr -> Bool
isExprLevPoly :: CoreExpr -> Bool
isExprLevPoly = CoreExpr -> Bool
go
where
go :: CoreExpr -> Bool
go (Var Id
_) = Bool
False
go (Lit Literal
_) = Bool
False
go e :: CoreExpr
e@(App CoreExpr
f CoreExpr
_) | Bool -> Bool
not (CoreExpr -> Bool
forall b. OutputableBndr b => Expr b -> Bool
go_app CoreExpr
f) = Bool
False
| Bool
otherwise = CoreExpr -> Bool
check_type CoreExpr
e
go (Lam Id
_ CoreExpr
_) = Bool
False
go (Let Bind Id
_ CoreExpr
e) = CoreExpr -> Bool
go CoreExpr
e
go e :: CoreExpr
e@(Case {}) = CoreExpr -> Bool
check_type CoreExpr
e
go e :: CoreExpr
e@(Cast {}) = CoreExpr -> Bool
check_type CoreExpr
e
go (Tick CoreTickish
_ CoreExpr
e) = CoreExpr -> Bool
go CoreExpr
e
go e :: CoreExpr
e@(Type {}) = String -> SDoc -> Bool
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"isExprLevPoly ty" (CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
e)
go (Coercion {}) = Bool
False
check_type :: CoreExpr -> Bool
check_type = Type -> Bool
isTypeLevPoly (Type -> Bool) -> (CoreExpr -> Type) -> CoreExpr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> Type
exprType
go_app :: Expr b -> Bool
go_app (Var Id
id) = Bool -> Bool
not (Id -> Bool
isNeverLevPolyId Id
id)
go_app (Lit Literal
_) = Bool
False
go_app (App Expr b
f Expr b
_) = Expr b -> Bool
go_app Expr b
f
go_app (Lam b
_ Expr b
e) = Expr b -> Bool
go_app Expr b
e
go_app (Let Bind b
_ Expr b
e) = Expr b -> Bool
go_app Expr b
e
go_app (Case Expr b
_ b
_ Type
ty [Alt b]
_) = Type -> Bool
resultIsLevPoly Type
ty
go_app (Cast Expr b
_ Coercion
co) = Type -> Bool
resultIsLevPoly (Coercion -> Type
coercionRKind Coercion
co)
go_app (Tick CoreTickish
_ Expr b
e) = Expr b -> Bool
go_app Expr b
e
go_app e :: Expr b
e@(Type {}) = String -> SDoc -> Bool
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"isExprLevPoly app ty" (Expr b -> SDoc
forall a. Outputable a => a -> SDoc
ppr Expr b
e)
go_app e :: Expr b
e@(Coercion {}) = String -> SDoc -> Bool
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"isExprLevPoly app co" (Expr b -> SDoc
forall a. Outputable a => a -> SDoc
ppr Expr b
e)
applyTypeToArgs :: SDoc -> Type -> [CoreExpr] -> Type
applyTypeToArgs :: SDoc -> Type -> [CoreExpr] -> Type
applyTypeToArgs SDoc
pp_e Type
op_ty [CoreExpr]
args
= Type -> [CoreExpr] -> Type
go Type
op_ty [CoreExpr]
args
where
go :: Type -> [CoreExpr] -> Type
go Type
op_ty [] = Type
op_ty
go Type
op_ty (Type Type
ty : [CoreExpr]
args) = Type -> [Type] -> [CoreExpr] -> Type
go_ty_args Type
op_ty [Type
ty] [CoreExpr]
args
go Type
op_ty (Coercion 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
| ASSERT2( coercionRole co == Representational
, text "coercion" <+> ppr co <+> ptext (sLit "passed to mkCast")
<+> ppr e <+> text "has wrong role" <+> ppr (coercionRole co) )
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
= WARN(let { from_ty = coercionLKind co;
to_ty2 = coercionRKind co2 } in
not (from_ty `eqType` to_ty2),
vcat ([ text "expr:" <+> ppr expr
, text "co2:" <+> ppr co2
, text "co:" <+> ppr co ]) )
CoreExpr -> 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
WARN( not (from_ty `eqType` exprType expr),
text "Trying to coerce" <+> text "(" <> ppr expr
$$ text "::" <+> ppr (exprType expr) <> text ")"
$$ ppr co $$ ppr (coercionType co)
$$ callStackDoc )
(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 -> Int
idArity Id
fun Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Expr b] -> Int
forall b. [Arg b] -> Int
valArgCount [Expr b]
args
go (Cast Expr b
f Coercion
_) [Expr b]
as = Expr b -> [Expr b] -> Bool
go Expr b
f [Expr b]
as
go Expr b
_ [Expr b]
_ = Bool
False
mkTickNoHNF :: CoreTickish -> CoreExpr -> CoreExpr
mkTickNoHNF :: CoreTickish -> CoreExpr -> CoreExpr
mkTickNoHNF CoreTickish
t CoreExpr
e
| CoreExpr -> Bool
exprIsHNF CoreExpr
e = CoreTickish -> CoreExpr -> CoreExpr
tickHNFArgs CoreTickish
t CoreExpr
e
| Bool
otherwise = CoreTickish -> CoreExpr -> CoreExpr
mkTick CoreTickish
t CoreExpr
e
tickHNFArgs :: CoreTickish -> CoreExpr -> CoreExpr
tickHNFArgs :: CoreTickish -> CoreExpr -> CoreExpr
tickHNFArgs CoreTickish
t CoreExpr
e = CoreTickish -> CoreExpr -> CoreExpr
push CoreTickish
t CoreExpr
e
where
push :: CoreTickish -> CoreExpr -> CoreExpr
push CoreTickish
t (App CoreExpr
f (Type Type
u)) = CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (CoreTickish -> CoreExpr -> CoreExpr
push CoreTickish
t CoreExpr
f) (Type -> CoreExpr
forall b. Type -> Expr b
Type Type
u)
push CoreTickish
t (App CoreExpr
f CoreExpr
arg) = CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (CoreTickish -> CoreExpr -> CoreExpr
push CoreTickish
t CoreExpr
f) (CoreTickish -> CoreExpr -> CoreExpr
mkTick CoreTickish
t CoreExpr
arg)
push CoreTickish
_t CoreExpr
e = CoreExpr
e
stripTicksTop :: (CoreTickish -> Bool) -> Expr b -> ([CoreTickish], Expr b)
stripTicksTop :: (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 :: 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 = HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType 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 (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 = 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) = ASSERT( null args ) (alts, Just 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 -> ASSERT( not (con1 == DEFAULT) ) go alts 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 = ASSERT( null args ) []
trimConArgs (LitAlt Literal
_) [CoreExpr]
args = ASSERT( null 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 (CoreExpr -> Type
exprType CoreExpr
e)
= Bool
True
| Bool
otherwise
= Int -> CoreExpr -> Bool
go Int
0 CoreExpr
e
where
go :: Int -> CoreExpr -> Bool
go Int
n (Var Id
v) = Id -> Bool
isDeadEndId Id
v Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Id -> Int
idArity Id
v
go Int
n (App CoreExpr
e CoreExpr
a) | CoreExpr -> Bool
forall b. Expr b -> Bool
isTypeArg CoreExpr
a = Int -> CoreExpr -> Bool
go Int
n CoreExpr
e
| Bool
otherwise = Int -> CoreExpr -> Bool
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) CoreExpr
e
go Int
n (Tick CoreTickish
_ CoreExpr
e) = Int -> CoreExpr -> Bool
go Int
n CoreExpr
e
go Int
n (Cast CoreExpr
e Coercion
_) = Int -> CoreExpr -> Bool
go Int
n CoreExpr
e
go Int
n (Let Bind Id
_ CoreExpr
e) = Int -> CoreExpr -> Bool
go Int
n CoreExpr
e
go Int
n (Lam Id
v CoreExpr
e) | Id -> Bool
isTyVar Id
v = Int -> CoreExpr -> Bool
go Int
n CoreExpr
e
go Int
_ (Case CoreExpr
_ Id
_ Type
_ [Alt Id]
alts) = [Alt Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Alt Id]
alts
go Int
_ CoreExpr
_ = Bool
False
exprIsDupable :: Platform -> CoreExpr -> Bool
exprIsDupable :: Platform -> CoreExpr -> Bool
exprIsDupable Platform
platform CoreExpr
e
= Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (Int -> CoreExpr -> Maybe Int
go Int
dupAppSize CoreExpr
e)
where
go :: Int -> CoreExpr -> Maybe Int
go :: Int -> CoreExpr -> Maybe Int
go Int
n (Type {}) = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n
go Int
n (Coercion {}) = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n
go Int
n (Var {}) = Int -> Maybe Int
decrement Int
n
go Int
n (Tick CoreTickish
_ CoreExpr
e) = Int -> CoreExpr -> Maybe Int
go Int
n CoreExpr
e
go Int
n (Cast CoreExpr
e Coercion
_) = Int -> CoreExpr -> Maybe Int
go Int
n CoreExpr
e
go Int
n (App CoreExpr
f CoreExpr
a) | Just Int
n' <- Int -> CoreExpr -> Maybe Int
go Int
n CoreExpr
a = Int -> CoreExpr -> Maybe Int
go Int
n' CoreExpr
f
go Int
n (Lit Literal
lit) | Platform -> Literal -> Bool
litIsDupable Platform
platform Literal
lit = Int -> Maybe Int
decrement Int
n
go Int
_ CoreExpr
_ = Maybe Int
forall a. Maybe a
Nothing
decrement :: Int -> Maybe Int
decrement :: Int -> Maybe Int
decrement Int
0 = Maybe Int
forall a. Maybe a
Nothing
decrement Int
n = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
dupAppSize :: Int
dupAppSize :: Int
dupAppSize = Int
8
exprIsWorkFree :: CoreExpr -> Bool
exprIsWorkFree :: CoreExpr -> Bool
exprIsWorkFree = CheapAppFun -> CoreExpr -> Bool
exprIsCheapX CheapAppFun
isWorkFreeApp
exprIsCheap :: CoreExpr -> Bool
exprIsCheap :: CoreExpr -> Bool
exprIsCheap = CheapAppFun -> CoreExpr -> Bool
exprIsCheapX CheapAppFun
isCheapApp
exprIsCheapX :: CheapAppFun -> CoreExpr -> Bool
exprIsCheapX :: CheapAppFun -> CoreExpr -> Bool
exprIsCheapX CheapAppFun
ok_app CoreExpr
e
= CoreExpr -> Bool
ok CoreExpr
e
where
ok :: CoreExpr -> Bool
ok CoreExpr
e = Int -> CoreExpr -> Bool
go Int
0 CoreExpr
e
go :: Int -> CoreExpr -> Bool
go Int
n (Var Id
v) = CheapAppFun
ok_app Id
v Int
n
go Int
_ (Lit {}) = Bool
True
go Int
_ (Type {}) = Bool
True
go Int
_ (Coercion {}) = Bool
True
go Int
n (Cast CoreExpr
e Coercion
_) = Int -> CoreExpr -> Bool
go Int
n CoreExpr
e
go Int
n (Case CoreExpr
scrut Id
_ Type
_ [Alt Id]
alts) = CoreExpr -> Bool
ok CoreExpr
scrut Bool -> Bool -> Bool
&&
[Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ Int -> CoreExpr -> Bool
go Int
n CoreExpr
rhs | Alt AltCon
_ [Id]
_ CoreExpr
rhs <- [Alt Id]
alts ]
go Int
n (Tick CoreTickish
t CoreExpr
e) | CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishCounts CoreTickish
t = Bool
False
| Bool
otherwise = Int -> CoreExpr -> Bool
go Int
n CoreExpr
e
go Int
n (Lam Id
x CoreExpr
e) | Id -> Bool
isRuntimeVar Id
x = Int
nInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0 Bool -> Bool -> Bool
|| Int -> CoreExpr -> Bool
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) CoreExpr
e
| Bool
otherwise = Int -> CoreExpr -> Bool
go Int
n CoreExpr
e
go Int
n (App CoreExpr
f CoreExpr
e) | CoreExpr -> Bool
isRuntimeArg CoreExpr
e = Int -> CoreExpr -> Bool
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) CoreExpr
f Bool -> Bool -> Bool
&& CoreExpr -> Bool
ok CoreExpr
e
| Bool
otherwise = Int -> CoreExpr -> Bool
go Int
n CoreExpr
f
go Int
n (Let (NonRec Id
_ CoreExpr
r) CoreExpr
e) = Int -> CoreExpr -> Bool
go Int
n CoreExpr
e Bool -> Bool -> Bool
&& CoreExpr -> Bool
ok CoreExpr
r
go Int
n (Let (Rec [(Id, CoreExpr)]
prs) CoreExpr
e) = Int -> CoreExpr -> Bool
go Int
n CoreExpr
e Bool -> Bool -> Bool
&& ((Id, CoreExpr) -> Bool) -> [(Id, CoreExpr)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (CoreExpr -> Bool
ok (CoreExpr -> Bool)
-> ((Id, CoreExpr) -> CoreExpr) -> (Id, CoreExpr) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id, CoreExpr) -> CoreExpr
forall a b. (a, b) -> b
snd) [(Id, CoreExpr)]
prs
exprIsExpandable :: CoreExpr -> Bool
exprIsExpandable :: CoreExpr -> Bool
exprIsExpandable CoreExpr
e
= CoreExpr -> Bool
ok CoreExpr
e
where
ok :: CoreExpr -> Bool
ok CoreExpr
e = Int -> CoreExpr -> Bool
go Int
0 CoreExpr
e
go :: Int -> CoreExpr -> Bool
go Int
n (Var Id
v) = CheapAppFun
isExpandableApp Id
v Int
n
go Int
_ (Lit {}) = Bool
True
go Int
_ (Type {}) = Bool
True
go Int
_ (Coercion {}) = Bool
True
go Int
n (Cast CoreExpr
e Coercion
_) = Int -> CoreExpr -> Bool
go Int
n CoreExpr
e
go Int
n (Tick CoreTickish
t CoreExpr
e) | CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishCounts CoreTickish
t = Bool
False
| Bool
otherwise = Int -> CoreExpr -> Bool
go Int
n CoreExpr
e
go Int
n (Lam Id
x CoreExpr
e) | Id -> Bool
isRuntimeVar Id
x = Int
nInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0 Bool -> Bool -> Bool
|| Int -> CoreExpr -> Bool
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) CoreExpr
e
| Bool
otherwise = Int -> CoreExpr -> Bool
go Int
n CoreExpr
e
go Int
n (App CoreExpr
f CoreExpr
e) | CoreExpr -> Bool
isRuntimeArg CoreExpr
e = Int -> CoreExpr -> Bool
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) CoreExpr
f Bool -> Bool -> Bool
&& CoreExpr -> Bool
ok CoreExpr
e
| Bool
otherwise = Int -> CoreExpr -> Bool
go Int
n CoreExpr
f
go Int
_ (Case {}) = Bool
False
go Int
_ (Let {}) = Bool
False
type CheapAppFun = Id -> Arity -> Bool
isWorkFreeApp :: CheapAppFun
isWorkFreeApp :: CheapAppFun
isWorkFreeApp Id
fn Int
n_val_args
| Int
n_val_args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
= Bool
True
| Int
n_val_args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Id -> Int
idArity Id
fn
= Bool
True
| Bool
otherwise
= case Id -> IdDetails
idDetails Id
fn of
DataConWorkId {} -> Bool
True
IdDetails
_ -> Bool
False
isCheapApp :: CheapAppFun
isCheapApp :: CheapAppFun
isCheapApp Id
fn Int
n_val_args
| CheapAppFun
isWorkFreeApp Id
fn Int
n_val_args = Bool
True
| Id -> Bool
isDeadEndId Id
fn = Bool
True
| Bool
otherwise
= case Id -> IdDetails
idDetails Id
fn of
DataConWorkId {} -> Bool
True
RecSelId {} -> Int
n_val_args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
ClassOpId {} -> Int
n_val_args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
PrimOpId PrimOp
op -> PrimOp -> Bool
primOpIsCheap PrimOp
op
IdDetails
_ -> Bool
False
isExpandableApp :: CheapAppFun
isExpandableApp :: CheapAppFun
isExpandableApp Id
fn Int
n_val_args
| CheapAppFun
isWorkFreeApp Id
fn Int
n_val_args = Bool
True
| Bool
otherwise
= case Id -> IdDetails
idDetails Id
fn of
RecSelId {} -> Int
n_val_args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
ClassOpId {} -> Int
n_val_args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
PrimOpId {} -> Bool
False
IdDetails
_ | Id -> Bool
isDeadEndId Id
fn -> Bool
False
| Id -> Bool
isConLikeId Id
fn -> Bool
True
| Bool
all_args_are_preds -> Bool
True
| Bool
otherwise -> Bool
False
where
all_args_are_preds :: Bool
all_args_are_preds = Int -> Type -> Bool
forall a. (Eq a, Num a) => a -> Type -> Bool
all_pred_args Int
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 -> ASSERT( isRubbishLit lit ) 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
primop_arg_ok [TyCoBinder]
arg_tys [CoreExpr]
args)
IdDetails
_other -> HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType (Id -> Type
idType Id
fun)
Bool -> Bool -> Bool
|| Id -> Int
idArity Id
fun Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n_val_args
where
n_val_args :: Int
n_val_args = [CoreExpr] -> Int
forall b. [Arg b] -> Int
valArgCount [CoreExpr]
args
where
([TyCoBinder]
arg_tys, Type
_) = Type -> ([TyCoBinder], Type)
splitPiTys (Id -> Type
idType Id
fun)
primop_arg_ok :: TyBinder -> CoreExpr -> Bool
primop_arg_ok :: TyCoBinder -> CoreExpr -> Bool
primop_arg_ok (Named TyCoVarBinder
_) CoreExpr
_ = Bool
True
primop_arg_ok (Anon AnonArgFlag
_ Scaled Type
ty) CoreExpr
arg
| HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType (Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
ty) = (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok PrimOp -> Bool
primop_ok CoreExpr
arg
| Bool
otherwise = Bool
True
altsAreExhaustive :: [Alt b] -> Bool
altsAreExhaustive :: [Alt b] -> Bool
altsAreExhaustive []
= Bool
False
altsAreExhaustive (Alt AltCon
con1 [b]
_ Expr b
_ : [Alt b]
alts)
= case AltCon
con1 of
AltCon
DEFAULT -> Bool
True
LitAlt {} -> Bool
False
DataAlt DataCon
c -> [Alt b]
alts [Alt b] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` (TyCon -> Int
tyConFamilySize (DataCon -> TyCon
dataConTyCon DataCon
c) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
exprIsHNF :: CoreExpr -> Bool
exprIsHNF :: CoreExpr -> Bool
exprIsHNF = (Id -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool
exprIsHNFlike Id -> Bool
isDataConWorkId Unfolding -> Bool
isEvaldUnfolding
exprIsConLike :: CoreExpr -> Bool
exprIsConLike :: CoreExpr -> Bool
exprIsConLike = (Id -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool
exprIsHNFlike Id -> Bool
isConLikeId Unfolding -> Bool
isConLikeUnfolding
exprIsHNFlike :: (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 Int
0
Bool -> Bool -> Bool
|| Unfolding -> Bool
is_con_unf (Id -> Unfolding
idUnfolding Id
v)
is_hnf_like (Lit Literal
_) = Bool
True
is_hnf_like (Type Type
_) = Bool
True
is_hnf_like (Coercion Coercion
_) = Bool
True
is_hnf_like (Lam Id
b CoreExpr
e) = Id -> Bool
isRuntimeVar Id
b Bool -> Bool -> Bool
|| CoreExpr -> Bool
is_hnf_like CoreExpr
e
is_hnf_like (Tick CoreTickish
tickish CoreExpr
e) = Bool -> Bool
not (CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishCounts CoreTickish
tickish)
Bool -> Bool -> Bool
&& CoreExpr -> Bool
is_hnf_like CoreExpr
e
is_hnf_like (Cast CoreExpr
e Coercion
_) = CoreExpr -> Bool
is_hnf_like CoreExpr
e
is_hnf_like (App CoreExpr
e CoreExpr
a)
| CoreExpr -> Bool
forall b. Expr b -> Bool
isValArg CoreExpr
a = CoreExpr -> Int -> Bool
app_is_value CoreExpr
e Int
1
| Bool
otherwise = CoreExpr -> Bool
is_hnf_like CoreExpr
e
is_hnf_like (Let Bind Id
_ CoreExpr
e) = CoreExpr -> Bool
is_hnf_like CoreExpr
e
is_hnf_like CoreExpr
_ = Bool
False
app_is_value :: CoreExpr -> Int -> Bool
app_is_value :: CoreExpr -> Int -> Bool
app_is_value (Var Id
f) Int
nva = CheapAppFun
id_app_is_value Id
f Int
nva
app_is_value (Tick CoreTickish
_ CoreExpr
f) Int
nva = CoreExpr -> Int -> Bool
app_is_value CoreExpr
f Int
nva
app_is_value (Cast CoreExpr
f Coercion
_) Int
nva = CoreExpr -> Int -> Bool
app_is_value CoreExpr
f Int
nva
app_is_value (App CoreExpr
f CoreExpr
a) Int
nva
| CoreExpr -> Bool
forall b. Expr b -> Bool
isValArg CoreExpr
a = CoreExpr -> Int -> Bool
app_is_value CoreExpr
f (Int
nva Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
| Bool
otherwise = CoreExpr -> Int -> Bool
app_is_value CoreExpr
f Int
nva
app_is_value CoreExpr
_ Int
_ = Bool
False
id_app_is_value :: CheapAppFun
id_app_is_value Id
id Int
n_val_args
= Id -> Bool
is_con Id
id
Bool -> Bool -> Bool
|| Id -> Int
idArity Id
id Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n_val_args
Bool -> Bool -> Bool
|| Id
id Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
absentErrorIdKey
exprIsTopLevelBindable :: CoreExpr -> Type -> Bool
exprIsTopLevelBindable :: CoreExpr -> Type -> Bool
exprIsTopLevelBindable CoreExpr
expr Type
ty
= Bool -> Bool
not (Type -> Bool
mightBeUnliftedType Type
ty)
Bool -> Bool -> Bool
|| CoreExpr -> Bool
exprIsTickedString CoreExpr
expr
exprIsTickedString :: CoreExpr -> Bool
exprIsTickedString :: CoreExpr -> Bool
exprIsTickedString = 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
= ASSERT( univ_tvs `equalLength` inst_tys )
([Id]
ex_bndrs, [Id]
arg_ids)
where
univ_tvs :: [Id]
univ_tvs = DataCon -> [Id]
dataConUnivTyVars DataCon
con
ex_tvs :: [Id]
ex_tvs = DataCon -> [Id]
dataConExTyCoVars DataCon
con
arg_tys :: [Scaled Type]
arg_tys = DataCon -> [Scaled Type]
dataConRepArgTys DataCon
con
arg_strs :: [StrictnessMark]
arg_strs = DataCon -> [StrictnessMark]
dataConRepStrictness DataCon
con
n_ex :: Int
n_ex = [Id] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
ex_tvs
([Unique]
ex_uniqs, [Unique]
id_uniqs) = Int -> [Unique] -> ([Unique], [Unique])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n_ex [Unique]
uniqs
([FastString]
ex_fss, [FastString]
id_fss) = Int -> [FastString] -> ([FastString], [FastString])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n_ex [FastString]
fss
univ_subst :: 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) (HasCallStack => 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
in_scope CoreExpr
e1 CoreExpr
e2
= RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go (InScopeSet -> RnEnv2
mkRnEnv2 InScopeSet
in_scope) CoreExpr
e1 CoreExpr
e2
where
go :: RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go RnEnv2
env (Var 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
= Bool
True
go RnEnv2
_ (Lit Literal
lit1) (Lit Literal
lit2) = Literal
lit1 Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== Literal
lit2
go RnEnv2
env (Type Type
t1) (Type Type
t2) = RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env Type
t1 Type
t2
go RnEnv2
env (Coercion Coercion
co1) (Coercion Coercion
co2) = RnEnv2 -> Coercion -> Coercion -> Bool
eqCoercionX RnEnv2
env Coercion
co1 Coercion
co2
go RnEnv2
env (Cast CoreExpr
e1 Coercion
co1) (Cast CoreExpr
e2 Coercion
co2) = RnEnv2 -> Coercion -> Coercion -> Bool
eqCoercionX RnEnv2
env Coercion
co1 Coercion
co2 Bool -> Bool -> Bool
&& RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go RnEnv2
env CoreExpr
e1 CoreExpr
e2
go RnEnv2
env (App CoreExpr
f1 CoreExpr
a1) (App CoreExpr
f2 CoreExpr
a2) = RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go RnEnv2
env CoreExpr
f1 CoreExpr
f2 Bool -> Bool -> Bool
&& RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go RnEnv2
env CoreExpr
a1 CoreExpr
a2
go RnEnv2
env (Tick CoreTickish
n1 CoreExpr
e1) (Tick CoreTickish
n2 CoreExpr
e2) = RnEnv2 -> CoreTickish -> CoreTickish -> Bool
eqTickish RnEnv2
env CoreTickish
n1 CoreTickish
n2 Bool -> Bool -> Bool
&& RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go RnEnv2
env CoreExpr
e1 CoreExpr
e2
go RnEnv2
env (Lam 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 -> Bool -> Bool
&& RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go (RnEnv2 -> Id -> Id -> RnEnv2
rnBndr2 RnEnv2
env Id
b1 Id
b2) CoreExpr
e1 CoreExpr
e2
go RnEnv2
env (Let (NonRec Id
v1 CoreExpr
r1) CoreExpr
e1) (Let (NonRec Id
v2 CoreExpr
r2) CoreExpr
e2)
= RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go RnEnv2
env CoreExpr
r1 CoreExpr
r2
Bool -> Bool -> Bool
&& RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go (RnEnv2 -> Id -> Id -> RnEnv2
rnBndr2 RnEnv2
env Id
v1 Id
v2) CoreExpr
e1 CoreExpr
e2
go RnEnv2
env (Let (Rec [(Id, CoreExpr)]
ps1) CoreExpr
e1) (Let (Rec [(Id, CoreExpr)]
ps2) CoreExpr
e2)
= [(Id, CoreExpr)] -> [(Id, CoreExpr)] -> Bool
forall a b. [a] -> [b] -> Bool
equalLength [(Id, CoreExpr)]
ps1 [(Id, CoreExpr)]
ps2
Bool -> Bool -> Bool
&& (CoreExpr -> CoreExpr -> Bool) -> [CoreExpr] -> [CoreExpr] -> Bool
forall a b. (a -> b -> Bool) -> [a] -> [b] -> Bool
all2 (RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go RnEnv2
env') [CoreExpr]
rs1 [CoreExpr]
rs2 Bool -> Bool -> Bool
&& RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go RnEnv2
env' CoreExpr
e1 CoreExpr
e2
where
([Id]
bs1,[CoreExpr]
rs1) = [(Id, CoreExpr)] -> ([Id], [CoreExpr])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Id, CoreExpr)]
ps1
([Id]
bs2,[CoreExpr]
rs2) = [(Id, CoreExpr)] -> ([Id], [CoreExpr])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Id, CoreExpr)]
ps2
env' :: RnEnv2
env' = RnEnv2 -> [Id] -> [Id] -> RnEnv2
rnBndrs2 RnEnv2
env [Id]
bs1 [Id]
bs2
go RnEnv2
env (Case CoreExpr
e1 Id
b1 Type
t1 [Alt Id]
a1) (Case CoreExpr
e2 Id
b2 Type
t2 [Alt Id]
a2)
| [Alt Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Alt Id]
a1
= [Alt Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Alt Id]
a2 Bool -> Bool -> Bool
&& RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go RnEnv2
env CoreExpr
e1 CoreExpr
e2 Bool -> Bool -> Bool
&& RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env Type
t1 Type
t2
| Bool
otherwise
= RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go RnEnv2
env CoreExpr
e1 CoreExpr
e2 Bool -> Bool -> Bool
&& (Alt Id -> Alt Id -> Bool) -> [Alt Id] -> [Alt Id] -> Bool
forall a b. (a -> b -> Bool) -> [a] -> [b] -> Bool
all2 (RnEnv2 -> Alt Id -> Alt Id -> Bool
go_alt (RnEnv2 -> Id -> Id -> RnEnv2
rnBndr2 RnEnv2
env Id
b1 Id
b2)) [Alt Id]
a1 [Alt Id]
a2
go RnEnv2
_ CoreExpr
_ CoreExpr
_ = Bool
False
go_alt :: RnEnv2 -> Alt Id -> Alt Id -> Bool
go_alt RnEnv2
env (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 Bool -> Bool -> Bool
&& RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go (RnEnv2 -> [Id] -> [Id] -> RnEnv2
rnBndrs2 RnEnv2
env [Id]
bs1 [Id]
bs2) CoreExpr
e1 CoreExpr
e2
eqTickish :: RnEnv2 -> CoreTickish -> CoreTickish -> Bool
eqTickish :: RnEnv2 -> CoreTickish -> CoreTickish -> Bool
eqTickish RnEnv2
env (Breakpoint XBreakpoint 'TickishPassCore
lext Int
lid [XTickishId 'TickishPassCore]
lids) (Breakpoint XBreakpoint 'TickishPassCore
rext Int
rid [XTickishId 'TickishPassCore]
rids)
= Int
lid Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
rid Bool -> Bool -> Bool
&&
(Id -> Id) -> [Id] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (RnEnv2 -> Id -> Id
rnOccL RnEnv2
env) [Id]
[XTickishId 'TickishPassCore]
lids [Id] -> [Id] -> Bool
forall a. Eq a => a -> a -> Bool
== (Id -> Id) -> [Id] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (RnEnv2 -> Id -> Id
rnOccR RnEnv2
env) [Id]
[XTickishId 'TickishPassCore]
rids Bool -> Bool -> Bool
&&
NoExtField
XBreakpoint 'TickishPassCore
lext NoExtField -> NoExtField -> Bool
forall a. Eq a => a -> a -> Bool
== NoExtField
XBreakpoint 'TickishPassCore
rext
eqTickish RnEnv2
_ CoreTickish
l CoreTickish
r = CoreTickish
l CoreTickish -> CoreTickish -> Bool
forall a. Eq a => a -> a -> Bool
== CoreTickish
r
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]]
diffBinds :: Bool -> RnEnv2 -> [(Var, CoreExpr)] -> [(Var, CoreExpr)]
-> ([SDoc], RnEnv2)
diffBinds :: Bool
-> RnEnv2
-> [(Id, CoreExpr)]
-> [(Id, CoreExpr)]
-> ([SDoc], RnEnv2)
diffBinds Bool
top RnEnv2
env [(Id, CoreExpr)]
binds1 = Int
-> RnEnv2
-> [(Id, CoreExpr)]
-> [(Id, CoreExpr)]
-> ([SDoc], RnEnv2)
go ([(Id, CoreExpr)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Id, CoreExpr)]
binds1) RnEnv2
env [(Id, CoreExpr)]
binds1
where go :: Int
-> RnEnv2
-> [(Id, CoreExpr)]
-> [(Id, CoreExpr)]
-> ([SDoc], RnEnv2)
go Int
_ RnEnv2
env [] []
= ([], RnEnv2
env)
go Int
fuel RnEnv2
env [(Id, CoreExpr)]
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)
| Int
fuel Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
= if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ RnEnv2
env RnEnv2 -> Id -> Bool
`inRnEnvL` (Id, CoreExpr) -> Id
forall a b. (a, b) -> a
fst ([(Id, CoreExpr)] -> (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 Int
-> RnEnv2
-> [(Id, CoreExpr)]
-> [(Id, CoreExpr)]
-> ([SDoc], RnEnv2)
go ([(Id, CoreExpr)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Id, CoreExpr)]
binds1) RnEnv2
env' [(Id, CoreExpr)]
binds1 [(Id, CoreExpr)]
binds2
else (RnEnv2 -> [(Id, CoreExpr)] -> [(Id, CoreExpr)] -> [SDoc]
warn RnEnv2
env [(Id, CoreExpr)]
binds1 [(Id, CoreExpr)]
binds2, RnEnv2
env)
go Int
fuel RnEnv2
env ((Id
bndr1,CoreExpr
expr1):[(Id, CoreExpr)]
binds1) [(Id, CoreExpr)]
binds2
| let matchExpr :: (Id, CoreExpr) -> Bool
matchExpr (Id
bndr,CoreExpr
expr) =
(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
= Int
-> RnEnv2
-> [(Id, CoreExpr)]
-> [(Id, CoreExpr)]
-> ([SDoc], RnEnv2)
go ([(Id, CoreExpr)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Id, CoreExpr)]
binds1) (RnEnv2 -> Id -> Id -> RnEnv2
rnBndr2 RnEnv2
env Id
bndr1 Id
bndr2)
[(Id, CoreExpr)]
binds1 ([(Id, CoreExpr)]
binds2l [(Id, CoreExpr)] -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. [a] -> [a] -> [a]
++ [(Id, CoreExpr)]
binds2r)
| Bool
otherwise
= Int
-> RnEnv2
-> [(Id, CoreExpr)]
-> [(Id, CoreExpr)]
-> ([SDoc], RnEnv2)
go (Int
fuelInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) RnEnv2
env ([(Id, CoreExpr)]
binds1[(Id, CoreExpr)] -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. [a] -> [a] -> [a]
++[(Id
bndr1,CoreExpr
expr1)]) [(Id, CoreExpr)]
binds2
go Int
_ 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:" (Int -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. Int -> [a] -> [a]
drop Int
l [(Id, CoreExpr)]
binds1') [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++
String -> [(Id, CoreExpr)] -> [SDoc]
forall b. OutputableBndr b => String -> [(b, Expr b)] -> [SDoc]
unmatched String
"unmatched right-hand:" (Int -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. Int -> [a] -> [a]
drop Int
l [(Id, CoreExpr)]
binds2')
where binds1' :: [(Id, CoreExpr)]
binds1' = ((Id, CoreExpr) -> (Id, CoreExpr) -> Ordering)
-> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Id, CoreExpr) -> Id)
-> (Id, CoreExpr) -> (Id, CoreExpr) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Id, CoreExpr) -> Id
forall a b. (a, b) -> a
fst) [(Id, CoreExpr)]
binds1
binds2' :: [(Id, CoreExpr)]
binds2' = ((Id, CoreExpr) -> (Id, CoreExpr) -> Ordering)
-> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Id, CoreExpr) -> Id)
-> (Id, CoreExpr) -> (Id, CoreExpr) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Id, CoreExpr) -> Id
forall a b. (a, b) -> a
fst) [(Id, CoreExpr)]
binds2
l :: Int
l = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min ([(Id, CoreExpr)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Id, CoreExpr)]
binds1') ([(Id, CoreExpr)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Id, CoreExpr)]
binds2')
unmatched :: String -> [(b, Expr b)] -> [SDoc]
unmatched String
_ [] = []
unmatched String
txt [(b, Expr b)]
bs = [String -> SDoc
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
| Bool
otherwise
= RnEnv2 -> Id -> Id -> [SDoc]
diffIdInfo RnEnv2
env Id
bndr1 Id
bndr2
diffIdInfo :: RnEnv2 -> Var -> Var -> [SDoc]
diffIdInfo :: RnEnv2 -> Id -> Id -> [SDoc]
diffIdInfo RnEnv2
env Id
bndr1 Id
bndr2
| IdInfo -> Int
arityInfo IdInfo
info1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== IdInfo -> Int
arityInfo IdInfo
info2
Bool -> Bool -> Bool
&& IdInfo -> CafInfo
cafInfo IdInfo
info1 CafInfo -> CafInfo -> Bool
forall a. Eq a => a -> a -> Bool
== IdInfo -> CafInfo
cafInfo IdInfo
info2
Bool -> Bool -> Bool
&& IdInfo -> OneShotInfo
oneShotInfo IdInfo
info1 OneShotInfo -> OneShotInfo -> Bool
forall a. Eq a => a -> a -> Bool
== IdInfo -> OneShotInfo
oneShotInfo IdInfo
info2
Bool -> Bool -> Bool
&& IdInfo -> InlinePragma
inlinePragInfo IdInfo
info1 InlinePragma -> InlinePragma -> Bool
forall a. Eq a => a -> a -> Bool
== IdInfo -> InlinePragma
inlinePragInfo IdInfo
info2
Bool -> Bool -> Bool
&& IdInfo -> OccInfo
occInfo IdInfo
info1 OccInfo -> OccInfo -> Bool
forall a. Eq a => a -> a -> Bool
== IdInfo -> OccInfo
occInfo IdInfo
info2
Bool -> Bool -> Bool
&& IdInfo -> Demand
demandInfo IdInfo
info1 Demand -> Demand -> Bool
forall a. Eq a => a -> a -> Bool
== IdInfo -> Demand
demandInfo IdInfo
info2
Bool -> Bool -> Bool
&& IdInfo -> Int
callArityInfo IdInfo
info1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== IdInfo -> Int
callArityInfo IdInfo
info2
Bool -> Bool -> Bool
&& IdInfo -> LevityInfo
levityInfo IdInfo
info1 LevityInfo -> LevityInfo -> Bool
forall a. Eq a => a -> a -> Bool
== IdInfo -> LevityInfo
levityInfo 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
unfoldingInfo IdInfo
info1) (IdInfo -> Unfolding
unfoldingInfo 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
$$ Int -> SDoc -> SDoc
nest Int
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 -> Maybe CoreExpr
tryEtaReduce :: [Id] -> CoreExpr -> Maybe CoreExpr
tryEtaReduce [Id]
bndrs CoreExpr
body
= [Id] -> CoreExpr -> Coercion -> Maybe CoreExpr
go ([Id] -> [Id]
forall a. [a] -> [a]
reverse [Id]
bndrs) CoreExpr
body (Type -> Coercion
mkRepReflCo (CoreExpr -> Type
exprType CoreExpr
body))
where
incoming_arity :: Int
incoming_arity = (Id -> Bool) -> [Id] -> Int
forall a. (a -> Bool) -> [a] -> Int
count Id -> Bool
isId [Id]
bndrs
go :: [Var]
-> CoreExpr
-> Coercion
-> Maybe CoreExpr
go :: [Id] -> CoreExpr -> Coercion -> Maybe CoreExpr
go [] CoreExpr
fun Coercion
co
| 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
, Bool -> Bool
not ((Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Id -> VarSet -> Bool
`elemVarSet` VarSet
used_vars) [Id]
bndrs)
= CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (CoreExpr -> Coercion -> CoreExpr
mkCast CoreExpr
fun Coercion
co)
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 (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]
_ CoreExpr
_ 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
ok_fun_id 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
ok_fun_id :: Id -> Bool
ok_fun_id Id
fun = Id -> Int
fun_arity Id
fun Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
incoming_arity
fun_arity :: Id -> Int
fun_arity Id
fun
| Id -> Bool
isLocalId Id
fun
, OccInfo -> Bool
isStrongLoopBreaker (Id -> OccInfo
idOccInfo Id
fun) = Int
0
| Int
arity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = Int
arity
| Unfolding -> Bool
isEvaldUnfolding (Id -> Unfolding
idUnfolding Id
fun) = Int
1
| Bool
otherwise = Int
0
where
arity :: Int
arity = Id -> Int
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
zapLamBndrs :: FullArgCount -> [Var] -> [Var]
zapLamBndrs :: Int -> [Id] -> [Id]
zapLamBndrs Int
arg_count [Id]
bndrs
| Bool
no_need_to_zap = [Id]
bndrs
| Bool
otherwise = Int -> [Id] -> [Id]
zap_em Int
arg_count [Id]
bndrs
where
no_need_to_zap :: Bool
no_need_to_zap = (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Id -> Bool
isOneShotBndr (Int -> [Id] -> [Id]
forall a. Int -> [a] -> [a]
drop Int
arg_count [Id]
bndrs)
zap_em :: FullArgCount -> [Var] -> [Var]
zap_em :: Int -> [Id] -> [Id]
zap_em Int
0 [Id]
bs = [Id]
bs
zap_em Int
_ [] = []
zap_em Int
n (Id
b:[Id]
bs) | Id -> Bool
isTyVar Id
b = Id
b Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: Int -> [Id] -> [Id]
zap_em (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [Id]
bs
| Bool
otherwise = Id -> Id
zapLamIdInfo Id
b Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: Int -> [Id] -> [Id]
zap_em (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [Id]
bs
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
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 :: (IdInfo -> SDoc) -> CoreProgram -> SDoc
dumpIdInfoOfProgram :: (IdInfo -> SDoc) -> [Bind Id] -> SDoc
dumpIdInfoOfProgram 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 = 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
isUnsafeEqualityProof :: CoreExpr -> Bool
isUnsafeEqualityProof :: CoreExpr -> Bool
isUnsafeEqualityProof CoreExpr
e
| Var Id
v `App` Type Type
_ `App` Type Type
_ `App` Type Type
_ <- CoreExpr
e
= Id -> Name
idName Id
v Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
unsafeEqualityProofName
| Bool
otherwise
= Bool
False