{-# LANGUAGE CPP #-}
module CoreUtils (
mkCast,
mkTick, mkTicks, mkTickNoHNF, tickHNFArgs,
bindNonRec, needsCaseBinding,
mkAltExpr, mkDefaultCase, mkSingleAltCase,
findDefault, addDefault, findAlt, isDefaultAlt,
mergeAlts, trimConArgs,
filterAlts, combineIdenticalAlts, refineDefaultAlt,
exprType, coreAltType, coreAltsType, isExprLevPoly,
exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsBottom,
getIdFromTrivialExpr_maybe,
exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun,
exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprIsWorkFree,
exprIsBig, exprIsConLike,
rhsIsStatic, isCheapApp, isExpandableApp,
exprIsTickedString, exprIsTickedString_maybe,
exprIsTopLevelBindable,
altsAreExhaustive,
cheapEqExpr, cheapEqExpr', eqExpr,
diffExpr, diffBinds,
tryEtaReduce,
exprToType, exprToCoercion_maybe,
applyTypeToArgs, applyTypeToArg,
dataConRepInstPat, dataConRepFSInstPat,
isEmptyTy,
stripTicksTop, stripTicksTopE, stripTicksTopT,
stripTicksE, stripTicksT,
collectMakeStaticArgs,
isJoinBind
) where
#include "HsVersions.h"
import GhcPrelude
import CoreSyn
import PrelNames ( makeStaticName )
import PprCore
import CoreFVs( exprFreeVars )
import Var
import SrcLoc
import VarEnv
import VarSet
import Name
import Literal
import DataCon
import PrimOp
import Id
import IdInfo
import PrelNames( absentErrorIdKey )
import Type
import Predicate
import TyCoRep( TyCoBinder(..), TyBinder )
import Coercion
import TyCon
import Unique
import Outputable
import TysPrim
import DynFlags
import FastString
import Maybes
import ListSetOps ( minusList )
import BasicTypes ( Arity, isConLike )
import GHC.Platform
import Util
import Pair
import Data.ByteString ( ByteString )
import Data.Function ( on )
import Data.List
import Data.Ord ( comparing )
import OrdList
import qualified Data.Set as Set
import UniqSet
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 Tickish Id
_ 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) -> CoreExpr -> Type -> [CoreExpr] -> Type
applyTypeToArgs CoreExpr
e (CoreExpr -> Type
exprType CoreExpr
fun) [CoreExpr]
args
exprType CoreExpr
other = String -> SDoc -> Type -> Type
forall a. String -> SDoc -> a -> a
pprTrace String
"exprType" (CoreExpr -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr CoreExpr
other) Type
alphaTy
coreAltType :: CoreAlt -> Type
coreAltType :: Alt Id -> Type
coreAltType alt :: Alt Id
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 => (AltCon, [a], Expr 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"
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 Tickish Id
_ 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 (Pair Type -> Type
forall a. Pair a -> a
pSnd (Pair Type -> Type) -> Pair Type -> Type
forall a b. (a -> b) -> a -> b
$ Coercion -> Pair Type
coercionKind Coercion
co)
go_app (Tick Tickish Id
_ 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 :: CoreExpr -> Type -> [CoreExpr] -> Type
applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
applyTypeToArgs CoreExpr
e Type
op_ty [CoreExpr]
args
= Type -> [CoreExpr] -> Type
forall b. Type -> [Expr b] -> Type
go Type
op_ty [CoreExpr]
args
where
go :: Type -> [Expr b] -> Type
go Type
op_ty [] = Type
op_ty
go Type
op_ty (Type Type
ty : [Expr b]
args) = Type -> [Type] -> [Expr b] -> Type
go_ty_args Type
op_ty [Type
ty] [Expr b]
args
go Type
op_ty (Coercion Coercion
co : [Expr b]
args) = Type -> [Type] -> [Expr b] -> Type
go_ty_args Type
op_ty [Coercion -> Type
mkCoercionTy Coercion
co] [Expr b]
args
go Type
op_ty (Expr b
_ : [Expr b]
args) | Just (Type
_, Type
res_ty) <- Type -> Maybe (Type, Type)
splitFunTy_maybe Type
op_ty
= Type -> [Expr b] -> Type
go Type
res_ty [Expr b]
args
go Type
_ [Expr b]
_ = String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"applyTypeToArgs" SDoc
panic_msg
go_ty_args :: Type -> [Type] -> [Expr b] -> Type
go_ty_args Type
op_ty [Type]
rev_tys (Type Type
ty : [Expr b]
args)
= Type -> [Type] -> [Expr b] -> Type
go_ty_args Type
op_ty (Type
tyType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
rev_tys) [Expr b]
args
go_ty_args Type
op_ty [Type]
rev_tys (Coercion Coercion
co : [Expr b]
args)
= Type -> [Type] -> [Expr b] -> Type
go_ty_args Type
op_ty (Coercion -> Type
mkCoercionTy Coercion
co Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
rev_tys) [Expr b]
args
go_ty_args Type
op_ty [Type]
rev_tys [Expr b]
args
= Type -> [Expr b] -> Type
go (HasDebugCallStack => Type -> [Type] -> Type
Type -> [Type] -> Type
piResultTys Type
op_ty ([Type] -> [Type]
forall a. [a] -> [a]
reverse [Type]
rev_tys)) [Expr b]
args
panic_msg :: SDoc
panic_msg = [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Expression:" SDoc -> SDoc -> SDoc
<+> CoreExpr -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr CoreExpr
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 ]
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 (Pair Type -> Type
forall a. Pair a -> a
pSnd (Coercion -> Pair Type
coercionKind 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 { Pair from_ty _to_ty = coercionKind co;
Pair _from_ty2 to_ty2 = coercionKind 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 Tickish Id
t CoreExpr
expr) Coercion
co
= Tickish Id -> CoreExpr -> CoreExpr
forall b. Tickish Id -> Expr b -> Expr b
Tick Tickish Id
t (CoreExpr -> Coercion -> CoreExpr
mkCast CoreExpr
expr Coercion
co)
mkCast CoreExpr
expr Coercion
co
= let Pair Type
from_ty Type
_to_ty = Coercion -> Pair Type
coercionKind 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) )
(CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
expr Coercion
co)
mkTick :: Tickish Id -> CoreExpr -> CoreExpr
mkTick :: Tickish Id -> CoreExpr -> CoreExpr
mkTick Tickish Id
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 = Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishCanSplit Tickish Id
t Bool -> Bool -> Bool
&& Tickish Id -> TickishPlacement
forall id. Tickish id -> TickishPlacement
tickishPlace (Tickish Id -> Tickish Id
forall id. Tickish id -> Tickish id
mkNoCount Tickish Id
t) TickishPlacement -> TickishPlacement -> Bool
forall a. Eq a => a -> a -> Bool
/= Tickish Id -> TickishPlacement
forall id. Tickish id -> TickishPlacement
tickishPlace Tickish Id
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 Tickish Id
t2 CoreExpr
e
| ProfNote{} <- Tickish Id
t2, ProfNote{} <- Tickish Id
t -> CoreExpr -> CoreExpr
top (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ Tickish Id -> CoreExpr -> CoreExpr
forall b. Tickish Id -> Expr b -> Expr b
Tick Tickish Id
t (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr
rest CoreExpr
expr
| Tickish Id -> TickishPlacement
forall id. Tickish id -> TickishPlacement
tickishPlace Tickish Id
t2 TickishPlacement -> TickishPlacement -> Bool
forall a. Eq a => a -> a -> Bool
/= Tickish Id -> TickishPlacement
forall id. Tickish id -> TickishPlacement
tickishPlace Tickish Id
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
. Tickish Id -> CoreExpr -> CoreExpr
forall b. Tickish Id -> Expr b -> Expr b
Tick Tickish Id
t2) CoreExpr -> CoreExpr
rest CoreExpr
e
| Tickish Id -> Tickish Id -> Bool
forall b. Eq b => Tickish b -> Tickish b -> Bool
tickishContains Tickish Id
t Tickish Id
t2 -> (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
mkTick' CoreExpr -> CoreExpr
top CoreExpr -> CoreExpr
rest CoreExpr
e
| Tickish Id -> Tickish Id -> Bool
forall b. Eq b => Tickish b -> Tickish b -> Bool
tickishContains Tickish Id
t2 Tickish Id
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
. Tickish Id -> CoreExpr -> CoreExpr
forall b. Tickish Id -> Expr b -> Expr b
Tick Tickish Id
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
|| Tickish Id -> TickishPlacement
forall id. Tickish id -> TickishPlacement
tickishPlace Tickish Id
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
$ Tickish Id -> CoreExpr -> CoreExpr
forall b. Tickish Id -> Expr b -> Expr b
Tick (Tickish Id -> Tickish Id
forall id. Tickish id -> Tickish id
mkNoScope Tickish Id
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
$ Tickish Id -> CoreExpr -> CoreExpr
mkTick (Tickish Id -> Tickish Id
forall id. Tickish id -> Tickish id
mkNoCount Tickish Id
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
&& (Tickish Id -> TickishPlacement
forall id. Tickish id -> TickishPlacement
tickishPlace Tickish Id
tTickishPlacement -> TickishPlacement -> Bool
forall a. Eq a => a -> a -> Bool
==TickishPlacement
PlaceCostCentre Bool -> Bool -> Bool
|| Bool
canSplit)
-> if Tickish Id -> TickishPlacement
forall id. Tickish id -> TickishPlacement
tickishPlace Tickish Id
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
$ Tickish Id -> CoreExpr -> CoreExpr
tickHNFArgs Tickish Id
t CoreExpr
expr
else CoreExpr -> CoreExpr
top (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ Tickish Id -> CoreExpr -> CoreExpr
forall b. Tickish Id -> Expr b -> Expr b
Tick (Tickish Id -> Tickish Id
forall id. Tickish id -> Tickish id
mkNoScope Tickish Id
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
$ Tickish Id -> CoreExpr -> CoreExpr
tickHNFArgs (Tickish Id -> Tickish Id
forall id. Tickish id -> Tickish id
mkNoCount Tickish Id
t) CoreExpr
expr
Var Id
x
| Bool
notFunction Bool -> Bool -> Bool
&& Tickish Id -> TickishPlacement
forall id. Tickish id -> TickishPlacement
tickishPlace Tickish Id
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
$ Tickish Id -> CoreExpr -> CoreExpr
forall b. Tickish Id -> Expr b -> Expr b
Tick (Tickish Id -> Tickish Id
forall id. Tickish id -> Tickish id
mkNoScope Tickish Id
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{}
| Tickish Id -> TickishPlacement
forall id. Tickish id -> TickishPlacement
tickishPlace Tickish Id
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
$ Tickish Id -> CoreExpr -> CoreExpr
forall b. Tickish Id -> Expr b -> Expr b
Tick Tickish Id
t (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr
rest CoreExpr
expr
mkTicks :: [Tickish Id] -> CoreExpr -> CoreExpr
mkTicks :: [Tickish Id] -> CoreExpr -> CoreExpr
mkTicks [Tickish Id]
ticks CoreExpr
expr = (Tickish Id -> CoreExpr -> CoreExpr)
-> CoreExpr -> [Tickish Id] -> CoreExpr
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Tickish Id -> CoreExpr -> CoreExpr
mkTick CoreExpr
expr [Tickish Id]
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 :: Tickish Id -> CoreExpr -> CoreExpr
mkTickNoHNF :: Tickish Id -> CoreExpr -> CoreExpr
mkTickNoHNF Tickish Id
t CoreExpr
e
| CoreExpr -> Bool
exprIsHNF CoreExpr
e = Tickish Id -> CoreExpr -> CoreExpr
tickHNFArgs Tickish Id
t CoreExpr
e
| Bool
otherwise = Tickish Id -> CoreExpr -> CoreExpr
mkTick Tickish Id
t CoreExpr
e
tickHNFArgs :: Tickish Id -> CoreExpr -> CoreExpr
tickHNFArgs :: Tickish Id -> CoreExpr -> CoreExpr
tickHNFArgs Tickish Id
t CoreExpr
e = Tickish Id -> CoreExpr -> CoreExpr
push Tickish Id
t CoreExpr
e
where
push :: Tickish Id -> CoreExpr -> CoreExpr
push Tickish Id
t (App CoreExpr
f (Type Type
u)) = CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (Tickish Id -> CoreExpr -> CoreExpr
push Tickish Id
t CoreExpr
f) (Type -> CoreExpr
forall b. Type -> Expr b
Type Type
u)
push Tickish Id
t (App CoreExpr
f CoreExpr
arg) = CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (Tickish Id -> CoreExpr -> CoreExpr
push Tickish Id
t CoreExpr
f) (Tickish Id -> CoreExpr -> CoreExpr
mkTick Tickish Id
t CoreExpr
arg)
push Tickish Id
_t CoreExpr
e = CoreExpr
e
stripTicksTop :: (Tickish Id -> Bool) -> Expr b -> ([Tickish Id], Expr b)
stripTicksTop :: (Tickish Id -> Bool) -> Expr b -> ([Tickish Id], Expr b)
stripTicksTop Tickish Id -> Bool
p = [Tickish Id] -> Expr b -> ([Tickish Id], Expr b)
forall b. [Tickish Id] -> Expr b -> ([Tickish Id], Expr b)
go []
where go :: [Tickish Id] -> Expr b -> ([Tickish Id], Expr b)
go [Tickish Id]
ts (Tick Tickish Id
t Expr b
e) | Tickish Id -> Bool
p Tickish Id
t = [Tickish Id] -> Expr b -> ([Tickish Id], Expr b)
go (Tickish Id
tTickish Id -> [Tickish Id] -> [Tickish Id]
forall a. a -> [a] -> [a]
:[Tickish Id]
ts) Expr b
e
go [Tickish Id]
ts Expr b
other = ([Tickish Id] -> [Tickish Id]
forall a. [a] -> [a]
reverse [Tickish Id]
ts, Expr b
other)
stripTicksTopE :: (Tickish Id -> Bool) -> Expr b -> Expr b
stripTicksTopE :: (Tickish Id -> Bool) -> Expr b -> Expr b
stripTicksTopE Tickish Id -> Bool
p = Expr b -> Expr b
forall b. Expr b -> Expr b
go
where go :: Expr b -> Expr b
go (Tick Tickish Id
t Expr b
e) | Tickish Id -> Bool
p Tickish Id
t = Expr b -> Expr b
go Expr b
e
go Expr b
other = Expr b
other
stripTicksTopT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id]
stripTicksTopT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id]
stripTicksTopT Tickish Id -> Bool
p = [Tickish Id] -> Expr b -> [Tickish Id]
forall b. [Tickish Id] -> Expr b -> [Tickish Id]
go []
where go :: [Tickish Id] -> Expr b -> [Tickish Id]
go [Tickish Id]
ts (Tick Tickish Id
t Expr b
e) | Tickish Id -> Bool
p Tickish Id
t = [Tickish Id] -> Expr b -> [Tickish Id]
go (Tickish Id
tTickish Id -> [Tickish Id] -> [Tickish Id]
forall a. a -> [a] -> [a]
:[Tickish Id]
ts) Expr b
e
go [Tickish Id]
ts Expr b
_ = [Tickish Id]
ts
stripTicksE :: (Tickish Id -> Bool) -> Expr b -> Expr b
stripTicksE :: (Tickish Id -> Bool) -> Expr b -> Expr b
stripTicksE Tickish Id -> Bool
p Expr b
expr = Expr b -> Expr b
forall b. 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 Tickish Id
t Expr b
e)
| Tickish Id -> Bool
p Tickish Id
t = Expr b -> Expr b
go Expr b
e
| Bool
otherwise = Tickish Id -> Expr b -> Expr b
forall b. Tickish Id -> Expr b -> Expr b
Tick Tickish Id
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 (AltCon
c,[b]
bs,Expr b
e) = (AltCon
c,[b]
bs, Expr b -> Expr b
go Expr b
e)
stripTicksT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id]
stripTicksT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id]
stripTicksT Tickish Id -> Bool
p Expr b
expr = OrdList (Tickish Id) -> [Tickish Id]
forall a. OrdList a -> [a]
fromOL (OrdList (Tickish Id) -> [Tickish Id])
-> OrdList (Tickish Id) -> [Tickish Id]
forall a b. (a -> b) -> a -> b
$ Expr b -> OrdList (Tickish Id)
forall b. Expr b -> OrdList (Tickish Id)
go Expr b
expr
where go :: Expr b -> OrdList (Tickish Id)
go (App Expr b
e Expr b
a) = Expr b -> OrdList (Tickish Id)
go Expr b
e OrdList (Tickish Id)
-> OrdList (Tickish Id) -> OrdList (Tickish Id)
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Expr b -> OrdList (Tickish Id)
go Expr b
a
go (Lam b
_ Expr b
e) = Expr b -> OrdList (Tickish Id)
go Expr b
e
go (Let Bind b
b Expr b
e) = Bind b -> OrdList (Tickish Id)
go_bs Bind b
b OrdList (Tickish Id)
-> OrdList (Tickish Id) -> OrdList (Tickish Id)
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Expr b -> OrdList (Tickish Id)
go Expr b
e
go (Case Expr b
e b
_ Type
_ [Alt b]
as) = Expr b -> OrdList (Tickish Id)
go Expr b
e OrdList (Tickish Id)
-> OrdList (Tickish Id) -> OrdList (Tickish Id)
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [OrdList (Tickish Id)] -> OrdList (Tickish Id)
forall a. [OrdList a] -> OrdList a
concatOL ((Alt b -> OrdList (Tickish Id))
-> [Alt b] -> [OrdList (Tickish Id)]
forall a b. (a -> b) -> [a] -> [b]
map Alt b -> OrdList (Tickish Id)
go_a [Alt b]
as)
go (Cast Expr b
e Coercion
_) = Expr b -> OrdList (Tickish Id)
go Expr b
e
go (Tick Tickish Id
t Expr b
e)
| Tickish Id -> Bool
p Tickish Id
t = Tickish Id
t Tickish Id -> OrdList (Tickish Id) -> OrdList (Tickish Id)
forall a. a -> OrdList a -> OrdList a
`consOL` Expr b -> OrdList (Tickish Id)
go Expr b
e
| Bool
otherwise = Expr b -> OrdList (Tickish Id)
go Expr b
e
go Expr b
_ = OrdList (Tickish Id)
forall a. OrdList a
nilOL
go_bs :: Bind b -> OrdList (Tickish Id)
go_bs (NonRec b
_ Expr b
e) = Expr b -> OrdList (Tickish Id)
go Expr b
e
go_bs (Rec [(b, Expr b)]
bs) = [OrdList (Tickish Id)] -> OrdList (Tickish Id)
forall a. [OrdList a] -> OrdList a
concatOL (((b, Expr b) -> OrdList (Tickish Id))
-> [(b, Expr b)] -> [OrdList (Tickish Id)]
forall a b. (a -> b) -> [a] -> [b]
map (b, Expr b) -> OrdList (Tickish Id)
go_b [(b, Expr b)]
bs)
go_b :: (b, Expr b) -> OrdList (Tickish Id)
go_b (b
_, Expr b
e) = Expr b -> OrdList (Tickish Id)
go Expr b
e
go_a :: Alt b -> OrdList (Tickish Id)
go_a (AltCon
_, [b]
_, Expr b
e) = Expr b -> OrdList (Tickish Id)
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
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
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 :: [(AltCon, [a], b)] -> ([(AltCon, [a], b)], Maybe b)
findDefault :: [(AltCon, [a], b)] -> ([(AltCon, [a], b)], Maybe b)
findDefault ((AltCon
DEFAULT,[a]
args,b
rhs) : [(AltCon, [a], b)]
alts) = ASSERT( null args ) (alts, Just rhs)
findDefault [(AltCon, [a], b)]
alts = ([(AltCon, [a], b)]
alts, Maybe b
forall a. Maybe a
Nothing)
addDefault :: [(AltCon, [a], b)] -> Maybe b -> [(AltCon, [a], b)]
addDefault :: [(AltCon, [a], b)] -> Maybe b -> [(AltCon, [a], b)]
addDefault [(AltCon, [a], b)]
alts Maybe b
Nothing = [(AltCon, [a], b)]
alts
addDefault [(AltCon, [a], b)]
alts (Just b
rhs) = (AltCon
DEFAULT, [], b
rhs) (AltCon, [a], b) -> [(AltCon, [a], b)] -> [(AltCon, [a], b)]
forall a. a -> [a] -> [a]
: [(AltCon, [a], b)]
alts
isDefaultAlt :: (AltCon, a, b) -> Bool
isDefaultAlt :: (AltCon, a, b) -> Bool
isDefaultAlt (AltCon
DEFAULT, a
_, b
_) = Bool
True
isDefaultAlt (AltCon, a, b)
_ = Bool
False
findAlt :: AltCon -> [(AltCon, a, b)] -> Maybe (AltCon, a, b)
findAlt :: AltCon -> [(AltCon, a, b)] -> Maybe (AltCon, a, b)
findAlt AltCon
con [(AltCon, a, b)]
alts
= case [(AltCon, a, b)]
alts of
(deflt :: (AltCon, a, b)
deflt@(AltCon
DEFAULT,a
_,b
_):[(AltCon, a, b)]
alts) -> [(AltCon, a, b)] -> Maybe (AltCon, a, b) -> Maybe (AltCon, a, b)
forall b c.
[(AltCon, b, c)] -> Maybe (AltCon, b, c) -> Maybe (AltCon, b, c)
go [(AltCon, a, b)]
alts ((AltCon, a, b) -> Maybe (AltCon, a, b)
forall a. a -> Maybe a
Just (AltCon, a, b)
deflt)
[(AltCon, a, b)]
_ -> [(AltCon, a, b)] -> Maybe (AltCon, a, b) -> Maybe (AltCon, a, b)
forall b c.
[(AltCon, b, c)] -> Maybe (AltCon, b, c) -> Maybe (AltCon, b, c)
go [(AltCon, a, b)]
alts Maybe (AltCon, a, b)
forall a. Maybe a
Nothing
where
go :: [(AltCon, b, c)] -> Maybe (AltCon, b, c) -> Maybe (AltCon, b, c)
go [] Maybe (AltCon, b, c)
deflt = Maybe (AltCon, b, c)
deflt
go (alt :: (AltCon, b, c)
alt@(AltCon
con1,b
_,c
_) : [(AltCon, b, c)]
alts) Maybe (AltCon, b, c)
deflt
= case AltCon
con AltCon -> AltCon -> Ordering
`cmpAltCon` AltCon
con1 of
Ordering
LT -> Maybe (AltCon, b, c)
deflt
Ordering
EQ -> (AltCon, b, c) -> Maybe (AltCon, b, c)
forall a. a -> Maybe a
Just (AltCon, b, c)
alt
Ordering
GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt
mergeAlts :: [(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)]
mergeAlts :: [(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)]
mergeAlts [] [(AltCon, a, b)]
as2 = [(AltCon, a, b)]
as2
mergeAlts [(AltCon, a, b)]
as1 [] = [(AltCon, a, b)]
as1
mergeAlts ((AltCon, a, b)
a1:[(AltCon, a, b)]
as1) ((AltCon, a, b)
a2:[(AltCon, a, b)]
as2)
= case (AltCon, a, b)
a1 (AltCon, a, b) -> (AltCon, a, b) -> Ordering
forall a b. (AltCon, a, b) -> (AltCon, a, b) -> Ordering
`cmpAlt` (AltCon, a, b)
a2 of
Ordering
LT -> (AltCon, a, b)
a1 (AltCon, a, b) -> [(AltCon, a, b)] -> [(AltCon, a, b)]
forall a. a -> [a] -> [a]
: [(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)]
forall a b.
[(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)]
mergeAlts [(AltCon, a, b)]
as1 ((AltCon, a, b)
a2(AltCon, a, b) -> [(AltCon, a, b)] -> [(AltCon, a, b)]
forall a. a -> [a] -> [a]
:[(AltCon, a, b)]
as2)
Ordering
EQ -> (AltCon, a, b)
a1 (AltCon, a, b) -> [(AltCon, a, b)] -> [(AltCon, a, b)]
forall a. a -> [a] -> [a]
: [(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)]
forall a b.
[(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)]
mergeAlts [(AltCon, a, b)]
as1 [(AltCon, a, b)]
as2
Ordering
GT -> (AltCon, a, b)
a2 (AltCon, a, b) -> [(AltCon, a, b)] -> [(AltCon, a, b)]
forall a. a -> [a] -> [a]
: [(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)]
forall a b.
[(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)]
mergeAlts ((AltCon, a, b)
a1(AltCon, a, b) -> [(AltCon, a, b)] -> [(AltCon, a, b)]
forall a. a -> [a] -> [a]
:[(AltCon, a, b)]
as1) [(AltCon, a, b)]
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]
-> [(AltCon, [Var], a)]
-> ([AltCon], [(AltCon, [Var], a)])
filterAlts :: TyCon
-> [Type]
-> [AltCon]
-> [(AltCon, [Id], a)]
-> ([AltCon], [(AltCon, [Id], a)])
filterAlts TyCon
_tycon [Type]
inst_tys [AltCon]
imposs_cons [(AltCon, [Id], a)]
alts
= ([AltCon]
imposs_deflt_cons, [(AltCon, [Id], a)] -> Maybe a -> [(AltCon, [Id], a)]
forall a b. [(AltCon, [a], b)] -> Maybe b -> [(AltCon, [a], b)]
addDefault [(AltCon, [Id], a)]
trimmed_alts Maybe a
maybe_deflt)
where
([(AltCon, [Id], a)]
alts_wo_default, Maybe a
maybe_deflt) = [(AltCon, [Id], a)] -> ([(AltCon, [Id], a)], Maybe a)
forall a b. [(AltCon, [a], b)] -> ([(AltCon, [a], b)], Maybe b)
findDefault [(AltCon, [Id], a)]
alts
alt_cons :: [AltCon]
alt_cons = [AltCon
con | (AltCon
con,[Id]
_,a
_) <- [(AltCon, [Id], a)]
alts_wo_default]
trimmed_alts :: [(AltCon, [Id], a)]
trimmed_alts = ((AltCon, [Id], a) -> Bool)
-> [(AltCon, [Id], a)] -> [(AltCon, [Id], a)]
forall a. (a -> Bool) -> [a] -> [a]
filterOut ([Type] -> (AltCon, [Id], a) -> Bool
forall a b. [Type] -> (AltCon, a, b) -> Bool
impossible_alt [Type]
inst_tys) [(AltCon, [Id], a)]
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] -> (AltCon, a, b) -> Bool
impossible_alt :: [Type] -> (AltCon, a, b) -> Bool
impossible_alt [Type]
_ (AltCon
con, a
_, 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 (DataAlt DataCon
con, a
_, b
_) = [Type] -> DataCon -> Bool
dataConCannotMatch [Type]
inst_tys DataCon
con
impossible_alt [Type]
_ (AltCon, a, b)
_ = Bool
False
refineDefaultAlt :: [Unique]
-> TyCon
-> [Type]
-> [AltCon]
-> [CoreAlt]
-> (Bool, [CoreAlt])
refineDefaultAlt :: [Unique]
-> TyCon -> [Type] -> [AltCon] -> [Alt Id] -> (Bool, [Alt Id])
refineDefaultAlt [Unique]
us TyCon
tycon [Type]
tys [AltCon]
imposs_deflt_cons [Alt Id]
all_alts
| (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 b.
[(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)]
mergeAlts [Alt Id]
rest_alts [(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] -> DataCon -> [Type] -> ([Id], [Id])
dataConRepInstPat [Unique]
us 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 ((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
forall a. (AltCon, [a], CoreExpr)
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
forall (t :: * -> *) a. Foldable t => (a, t Id, CoreExpr) -> Bool
identical_to_alt1 [Alt Id]
rest_alts
deflt_alt :: (AltCon, [a], CoreExpr)
deflt_alt = (AltCon
DEFAULT, [], [Tickish Id] -> CoreExpr -> CoreExpr
mkTicks ([[Tickish Id]] -> [Tickish Id]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Tickish Id]]
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 Id -> AltCon
forall a b c. (a, b, c) -> a
fstOf3 [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 = (Tickish Id -> Bool) -> Expr b -> Expr b -> Bool
forall b. (Tickish Id -> Bool) -> Expr b -> Expr b -> Bool
cheapEqExpr' Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishFloatable Expr b
e1 Expr b
e2
identical_to_alt1 :: (a, t Id, CoreExpr) -> Bool
identical_to_alt1 (a
_con,t Id
bndrs,CoreExpr
rhs)
= (Id -> Bool) -> t Id -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Id -> Bool
isDeadBinder t Id
bndrs Bool -> Bool -> Bool
&& CoreExpr
rhs CoreExpr -> CoreExpr -> Bool
forall b. Expr b -> Expr b -> Bool
`cheapEqTicked` CoreExpr
rhs1
tickss :: [[Tickish Id]]
tickss = (Alt Id -> [Tickish Id]) -> [Alt Id] -> [[Tickish Id]]
forall a b. (a -> b) -> [a] -> [b]
map ((Tickish Id -> Bool) -> CoreExpr -> [Tickish Id]
forall b. (Tickish Id -> Bool) -> Expr b -> [Tickish Id]
stripTicksT Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishFloatable (CoreExpr -> [Tickish Id])
-> (Alt Id -> CoreExpr) -> Alt Id -> [Tickish Id]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alt Id -> CoreExpr
forall a b c. (a, b, c) -> c
thdOf3) [Alt Id]
elim_rest
combineIdenticalAlts [AltCon]
imposs_cons [Alt Id]
alts
= (Bool
False, [AltCon]
imposs_cons, [Alt Id]
alts)
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 Tickish Id
t CoreExpr
e) = Bool -> Bool
not (Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishIsCode Tickish Id
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 Tickish Id
t CoreExpr
e) | Bool -> Bool
not (Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishIsCode Tickish Id
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
exprIsBottom :: CoreExpr -> Bool
exprIsBottom :: CoreExpr -> Bool
exprIsBottom 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
isBottomingId 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 Tickish Id
_ 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 :: DynFlags -> CoreExpr -> Bool
exprIsDupable :: DynFlags -> CoreExpr -> Bool
exprIsDupable DynFlags
dflags 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 Tickish Id
_ 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) | DynFlags -> Literal -> Bool
litIsDupable DynFlags
dflags 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 | (AltCon
_,[Id]
_,CoreExpr
rhs) <- [Alt Id]
alts ]
go Int
n (Tick Tickish Id
t CoreExpr
e) | Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishCounts Tickish Id
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 Tickish Id
t CoreExpr
e) | Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishCounts Tickish Id
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
isBottomingId 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
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 {} -> Bool
False
IdDetails
_ | Id -> Bool
isBottomingId Id
fn -> Bool
False
| RuleMatchInfo -> Bool
isConLike (Id -> RuleMatchInfo
idRuleMatchInfo 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 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 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 Tickish Id
tickish CoreExpr
e)
| Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishCounts Tickish Id
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 (\(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 (Tickish Id -> Bool) -> CoreExpr -> CoreExpr
forall b. (Tickish Id -> Bool) -> Expr b -> Expr b
stripTicksTopE (Bool -> Bool
not (Bool -> Bool) -> (Tickish Id -> Bool) -> Tickish Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tickish Id -> Bool
forall id. Tickish id -> 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( lit == rubbishLit ) 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
isDivOp 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
| 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
_ Type
ty) CoreExpr
arg
| HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType 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 ((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)
isDivOp :: PrimOp -> Bool
isDivOp :: PrimOp -> Bool
isDivOp PrimOp
IntQuotOp = Bool
True
isDivOp PrimOp
IntRemOp = Bool
True
isDivOp PrimOp
WordQuotOp = Bool
True
isDivOp PrimOp
WordRemOp = Bool
True
isDivOp PrimOp
FloatDivOp = Bool
True
isDivOp PrimOp
DoubleDivOp = Bool
True
isDivOp PrimOp
_ = Bool
False
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 Tickish Id
tickish CoreExpr
e) = Bool -> Bool
not (Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishCounts Tickish Id
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 Tickish Id
_ 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 Tickish Id
t CoreExpr
e)
| Tickish Id -> TickishPlacement
forall id. Tickish id -> TickishPlacement
tickishPlace Tickish Id
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] -> DataCon -> [Type] -> ([TyCoVar], [Id])
dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyCoVar], [Id])
dataConRepInstPat :: [Unique] -> DataCon -> [Type] -> ([Id], [Id])
dataConRepInstPat = [FastString] -> [Unique] -> DataCon -> [Type] -> ([Id], [Id])
dataConInstPat (FastString -> [FastString]
forall a. a -> [a]
repeat ((String -> FastString
fsLit String
"ipv")))
dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([Id], [Id])
dataConRepFSInstPat = [FastString] -> [Unique] -> DataCon -> [Type] -> ([Id], [Id])
dataConInstPat
dataConInstPat :: [FastString]
-> [Unique]
-> DataCon
-> [Type]
-> ([TyCoVar], [Id])
dataConInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([Id], [Id])
dataConInstPat [FastString]
fss [Unique]
uniqs 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 :: [Type]
arg_tys = DataCon -> [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 -> Type -> StrictnessMark -> Id)
-> [Unique] -> [FastString] -> [Type] -> [StrictnessMark] -> [Id]
forall a b c d e.
(a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e]
zipWith4 Unique -> FastString -> Type -> StrictnessMark -> Id
mk_id_var [Unique]
id_uniqs [FastString]
id_fss [Type]
arg_tys [StrictnessMark]
arg_strs
mk_id_var :: Unique -> FastString -> Type -> StrictnessMark -> Id
mk_id_var Unique
uniq FastString
fs Type
ty StrictnessMark
str
= StrictnessMark -> Id -> Id
setCaseBndrEvald StrictnessMark
str (Id -> Id) -> Id -> Id
forall a b. (a -> b) -> a -> b
$
Name -> Type -> Id
mkLocalIdOrCoVar Name
name (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 = (Tickish Id -> Bool) -> Expr b -> Expr b -> Bool
forall b. (Tickish Id -> Bool) -> Expr b -> Expr b -> Bool
cheapEqExpr' (Bool -> Tickish Id -> Bool
forall a b. a -> b -> a
const Bool
False)
cheapEqExpr' :: (Tickish Id -> Bool) -> Expr b -> Expr b -> Bool
cheapEqExpr' :: (Tickish Id -> Bool) -> Expr b -> Expr b -> Bool
cheapEqExpr' Tickish Id -> Bool
ignoreTick = Expr b -> Expr b -> Bool
forall b. Expr b -> Expr b -> Bool
go_s
where go_s :: Expr b -> Expr b -> Bool
go_s = Expr b -> Expr b -> Bool
go (Expr b -> Expr b -> Bool)
-> (Expr b -> Expr b) -> Expr b -> Expr b -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Tickish Id -> Bool) -> Expr b -> Expr b
forall b. (Tickish Id -> Bool) -> Expr b -> Expr b
stripTicksTopE Tickish Id -> Bool
ignoreTick
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_s` Expr b
f2 Bool -> Bool -> Bool
&& Expr b
a1 Expr b -> Expr b -> Bool
`go_s` 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_s` Expr b
e2 Bool -> Bool -> Bool
&& Coercion
t1 Coercion -> Coercion -> Bool
`eqCoercion` Coercion
t2
go (Tick Tickish Id
t1 Expr b
e1) (Tick Tickish Id
t2 Expr b
e2)
= Tickish Id
t1 Tickish Id -> Tickish Id -> Bool
forall a. Eq a => a -> a -> Bool
== Tickish Id
t2 Bool -> Bool -> Bool
&& Expr b
e1 Expr b -> Expr b -> Bool
`go_s` Expr b
e2
go Expr b
_ Expr b
_ = Bool
False
{-# INLINE go #-}
{-# INLINE cheapEqExpr' #-}
exprIsBig :: Expr b -> Bool
exprIsBig :: Expr b -> Bool
exprIsBig (Lit Literal
_) = Bool
False
exprIsBig (Var Id
_) = Bool
False
exprIsBig (Type Type
_) = Bool
False
exprIsBig (Coercion Coercion
_) = Bool
False
exprIsBig (Lam b
_ Expr b
e) = Expr b -> Bool
forall b. Expr b -> Bool
exprIsBig Expr b
e
exprIsBig (App Expr b
f Expr b
a) = Expr b -> Bool
forall b. Expr b -> Bool
exprIsBig Expr b
f Bool -> Bool -> Bool
|| Expr b -> Bool
forall b. Expr b -> Bool
exprIsBig Expr b
a
exprIsBig (Cast Expr b
e Coercion
_) = Expr b -> Bool
forall b. Expr b -> Bool
exprIsBig Expr b
e
exprIsBig (Tick Tickish Id
_ Expr b
e) = Expr b -> Bool
forall b. Expr b -> Bool
exprIsBig Expr b
e
exprIsBig Expr b
_ = Bool
True
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 Tickish Id
n1 CoreExpr
e1) (Tick Tickish Id
n2 CoreExpr
e2) = RnEnv2 -> Tickish Id -> Tickish Id -> Bool
eqTickish RnEnv2
env Tickish Id
n1 Tickish Id
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 (AltCon
c1, [Id]
bs1, CoreExpr
e1) (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 -> Tickish Id -> Tickish Id -> Bool
eqTickish :: RnEnv2 -> Tickish Id -> Tickish Id -> Bool
eqTickish RnEnv2
env (Breakpoint Int
lid [Id]
lids) (Breakpoint Int
rid [Id]
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]
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]
rids
eqTickish RnEnv2
_ Tickish Id
l Tickish Id
r = Tickish Id
l Tickish Id -> Tickish Id -> Bool
forall a. Eq a => a -> a -> Bool
== Tickish Id
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 Tickish Id
n1 CoreExpr
e1) CoreExpr
e2
| Bool -> Bool
not (Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishIsCode Tickish Id
n1) = Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
top RnEnv2
env CoreExpr
e1 CoreExpr
e2
diffExpr Bool
top RnEnv2
env CoreExpr
e1 (Tick Tickish Id
n2 CoreExpr
e2)
| Bool -> Bool
not (Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishIsCode Tickish Id
n2) = Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
top RnEnv2
env CoreExpr
e1 CoreExpr
e2
diffExpr Bool
top RnEnv2
env (Tick Tickish Id
n1 CoreExpr
e1) (Tick Tickish Id
n2 CoreExpr
e2)
| RnEnv2 -> Tickish Id -> Tickish Id -> Bool
eqTickish RnEnv2
env Tickish Id
n1 Tickish Id
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
isBottomingId Id
absent Bool -> Bool -> Bool
&& Id -> Bool
isBottomingId 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]
forall a.
(Eq a, Outputable a) =>
(a, [Id], CoreExpr) -> (a, [Id], CoreExpr) -> [SDoc]
diffAlt [Alt Id]
a1 [Alt Id]
a2)
where env' :: RnEnv2
env' = RnEnv2 -> Id -> Id -> RnEnv2
rnBndr2 RnEnv2
env Id
b1 Id
b2
diffAlt :: (a, [Id], CoreExpr) -> (a, [Id], CoreExpr) -> [SDoc]
diffAlt (a
c1, [Id]
bs1, CoreExpr
e1) (a
c2, [Id]
bs2, CoreExpr
e2)
| a
c1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
c2 = [String -> SDoc
text String
"alt-cons " SDoc -> SDoc -> SDoc
<> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
c1 SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" /= " SDoc -> SDoc -> SDoc
<> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
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
forall b. Expr b -> 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 Tickish Id
t CoreExpr
e) Coercion
co
| Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishFloatable Tickish Id
t
= (CoreExpr -> CoreExpr) -> Maybe CoreExpr -> Maybe CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Tickish Id -> CoreExpr -> CoreExpr
forall b. Tickish Id -> Expr b -> Expr b
Tick Tickish Id
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', [Tickish Id]
ticks) <- Id -> CoreExpr -> Coercion -> Maybe (Coercion, [Tickish Id])
ok_arg Id
b CoreExpr
arg Coercion
co
= (CoreExpr -> CoreExpr) -> Maybe CoreExpr -> Maybe CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CoreExpr -> [Tickish Id] -> CoreExpr)
-> [Tickish Id] -> CoreExpr -> CoreExpr
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Tickish Id -> CoreExpr -> CoreExpr)
-> CoreExpr -> [Tickish Id] -> CoreExpr
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Tickish Id -> CoreExpr -> CoreExpr
mkTick) [Tickish Id]
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 :: Expr b -> Bool
ok_fun (App Expr b
fun (Type {})) = Expr b -> Bool
ok_fun Expr b
fun
ok_fun (Cast Expr b
fun Coercion
_) = Expr b -> Bool
ok_fun Expr b
fun
ok_fun (Tick Tickish Id
_ Expr b
expr) = Expr b -> Bool
ok_fun Expr b
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 Expr b
_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
-> Maybe (Coercion
, [Tickish Var])
ok_arg :: Id -> CoreExpr -> Coercion -> Maybe (Coercion, [Tickish Id])
ok_arg Id
bndr (Type Type
ty) Coercion
co
| 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, [Tickish Id]) -> Maybe (Coercion, [Tickish Id])
forall a. a -> Maybe a
Just ([Id] -> Coercion -> Coercion
mkHomoForAllCos [Id
tv] Coercion
co, [])
ok_arg Id
bndr (Var Id
v) Coercion
co
| Id
bndr Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
v = let reflCo :: Coercion
reflCo = Type -> Coercion
mkRepReflCo (Id -> Type
idType Id
bndr)
in (Coercion, [Tickish Id]) -> Maybe (Coercion, [Tickish Id])
forall a. a -> Maybe a
Just (Role -> Coercion -> Coercion -> Coercion
mkFunCo Role
Representational Coercion
reflCo Coercion
co, [])
ok_arg Id
bndr (Cast CoreExpr
e Coercion
co_arg) Coercion
co
| ([Tickish Id]
ticks, Var Id
v) <- (Tickish Id -> Bool) -> CoreExpr -> ([Tickish Id], CoreExpr)
forall b. (Tickish Id -> Bool) -> Expr b -> ([Tickish Id], Expr b)
stripTicksTop Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishFloatable CoreExpr
e
, Id
bndr Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
v
= (Coercion, [Tickish Id]) -> Maybe (Coercion, [Tickish Id])
forall a. a -> Maybe a
Just (Role -> Coercion -> Coercion -> Coercion
mkFunCo Role
Representational (Coercion -> Coercion
mkSymCo Coercion
co_arg) Coercion
co, [Tickish Id]
ticks)
ok_arg Id
bndr (Tick Tickish Id
t CoreExpr
arg) Coercion
co
| Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishFloatable Tickish Id
t, Just (Coercion
co', [Tickish Id]
ticks) <- Id -> CoreExpr -> Coercion -> Maybe (Coercion, [Tickish Id])
ok_arg Id
bndr CoreExpr
arg Coercion
co
= (Coercion, [Tickish Id]) -> Maybe (Coercion, [Tickish Id])
forall a. a -> Maybe a
Just (Coercion
co', Tickish Id
tTickish Id -> [Tickish Id] -> [Tickish Id]
forall a. a -> [a] -> [a]
:[Tickish Id]
ticks)
ok_arg Id
_ CoreExpr
_ Coercion
_ = Maybe (Coercion, [Tickish Id])
forall a. Maybe a
Nothing
rhsIsStatic
:: Platform
-> (Name -> Bool)
-> (LitNumType -> Integer -> Maybe CoreExpr)
-> CoreExpr -> Bool
rhsIsStatic :: Platform
-> (Name -> Bool)
-> (LitNumType -> Integer -> Maybe CoreExpr)
-> CoreExpr
-> Bool
rhsIsStatic Platform
platform Name -> Bool
is_dynamic_name LitNumType -> Integer -> Maybe CoreExpr
cvt_literal CoreExpr
rhs = Bool -> CoreExpr -> Bool
is_static Bool
False CoreExpr
rhs
where
is_static :: Bool
-> CoreExpr -> Bool
is_static :: Bool -> CoreExpr -> Bool
is_static Bool
False (Lam Id
b CoreExpr
e) = Id -> Bool
isRuntimeVar Id
b Bool -> Bool -> Bool
|| Bool -> CoreExpr -> Bool
is_static Bool
False CoreExpr
e
is_static Bool
in_arg (Tick Tickish Id
n CoreExpr
e) = Bool -> Bool
not (Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishIsCode Tickish Id
n)
Bool -> Bool -> Bool
&& Bool -> CoreExpr -> Bool
is_static Bool
in_arg CoreExpr
e
is_static Bool
in_arg (Cast CoreExpr
e Coercion
_) = Bool -> CoreExpr -> Bool
is_static Bool
in_arg CoreExpr
e
is_static Bool
_ (Coercion {}) = Bool
True
is_static Bool
in_arg (Lit (LitNumber LitNumType
nt Integer
i Type
_)) = case LitNumType -> Integer -> Maybe CoreExpr
cvt_literal LitNumType
nt Integer
i of
Just CoreExpr
e -> Bool -> CoreExpr -> Bool
is_static Bool
in_arg CoreExpr
e
Maybe CoreExpr
Nothing -> Bool
True
is_static Bool
_ (Lit (LitLabel {})) = Bool
False
is_static Bool
_ (Lit Literal
_) = Bool
True
is_static Bool
in_arg CoreExpr
other_expr = CoreExpr -> Int -> Bool
go CoreExpr
other_expr Int
0
where
go :: CoreExpr -> Int -> Bool
go (Var Id
f) Int
n_val_args
| (Platform -> OS
platformOS Platform
platform OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
/= OS
OSMinGW32) Bool -> Bool -> Bool
||
Bool -> Bool
not (Name -> Bool
is_dynamic_name (Id -> Name
idName Id
f))
= CheapAppFun
saturated_data_con Id
f Int
n_val_args
Bool -> Bool -> Bool
|| (Bool
in_arg Bool -> Bool -> Bool
&& Int
n_val_args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0)
go (App CoreExpr
f CoreExpr
a) Int
n_val_args
| CoreExpr -> Bool
forall b. Expr b -> Bool
isTypeArg CoreExpr
a = CoreExpr -> Int -> Bool
go CoreExpr
f Int
n_val_args
| Bool -> Bool
not Bool
in_arg Bool -> Bool -> Bool
&& Bool -> CoreExpr -> Bool
is_static Bool
True CoreExpr
a = CoreExpr -> Int -> Bool
go CoreExpr
f (Int
n_val_args Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
go (Tick Tickish Id
n CoreExpr
f) Int
n_val_args = Bool -> Bool
not (Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishIsCode Tickish Id
n) Bool -> Bool -> Bool
&& CoreExpr -> Int -> Bool
go CoreExpr
f Int
n_val_args
go (Cast CoreExpr
e Coercion
_) Int
n_val_args = CoreExpr -> Int -> Bool
go CoreExpr
e Int
n_val_args
go CoreExpr
_ Int
_ = Bool
False
saturated_data_con :: CheapAppFun
saturated_data_con Id
f Int
n_val_args
= case Id -> Maybe DataCon
isDataConWorkId_maybe Id
f of
Just DataCon
dc -> Int
n_val_args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon -> Int
dataConRepArity DataCon
dc
Maybe DataCon
Nothing -> Bool
False
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], [Tickish Id]
_) <- (Tickish Id -> Bool)
-> CoreExpr -> (CoreExpr, [CoreExpr], [Tickish Id])
forall b.
(Tickish Id -> Bool) -> Expr b -> (Expr b, [Expr b], [Tickish Id])
collectArgsTicks (Bool -> Tickish Id -> 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