{-# LANGUAGE CPP #-}
module SimplUtils (
mkLam, mkCase, prepareAlts, tryEtaExpandRhs,
preInlineUnconditionally, postInlineUnconditionally,
activeUnfolding, activeRule,
getUnfoldingInRuleMatch,
simplEnvForGHCi, updModeForStableUnfoldings, updModeForRules,
SimplCont(..), DupFlag(..), StaticEnv,
isSimplified, contIsStop,
contIsDupable, contResultType, contHoleType,
contIsTrivial, contArgs,
countArgs,
mkBoringStop, mkRhsStop, mkLazyArgStop, contIsRhsOrArg,
interestingCallContext,
ArgInfo(..), ArgSpec(..), mkArgInfo,
addValArgTo, addCastTo, addTyArgTo,
argInfoExpr, argInfoAppArgs, pushSimplifiedArgs,
abstractFloats,
isExitJoinId
) where
#include "GhclibHsVersions.h"
import GhcPrelude
import SimplEnv
import CoreMonad ( SimplMode(..), Tick(..) )
import DynFlags
import CoreSyn
import qualified CoreSubst
import PprCore
import CoreFVs
import CoreUtils
import CoreArity
import CoreUnfold
import Name
import Id
import IdInfo
import Var
import Demand
import SimplMonad
import Type hiding( substTy )
import Coercion hiding( substCo )
import DataCon ( dataConWorkId, isNullaryRepDataCon )
import VarSet
import BasicTypes
import Util
import OrdList ( isNilOL )
import MonadUtils
import Outputable
import Pair
import PrelRules
import FastString ( fsLit )
import Control.Monad ( when )
import Data.List ( sortBy )
data SimplCont
= Stop
OutType
CallCtxt
| CastIt
OutCoercion
SimplCont
| ApplyToVal
{ SimplCont -> DupFlag
sc_dup :: DupFlag
, SimplCont -> InExpr
sc_arg :: InExpr
, SimplCont -> StaticEnv
sc_env :: StaticEnv
, SimplCont -> SimplCont
sc_cont :: SimplCont }
| ApplyToTy
{ SimplCont -> OutType
sc_arg_ty :: OutType
, SimplCont -> OutType
sc_hole_ty :: OutType
, sc_cont :: SimplCont }
| Select
{ sc_dup :: DupFlag
, SimplCont -> InId
sc_bndr :: InId
, SimplCont -> [InAlt]
sc_alts :: [InAlt]
, sc_env :: StaticEnv
, sc_cont :: SimplCont }
| StrictBind
{ sc_dup :: DupFlag
, sc_bndr :: InId
, SimplCont -> [InId]
sc_bndrs :: [InBndr]
, SimplCont -> InExpr
sc_body :: InExpr
, sc_env :: StaticEnv
, sc_cont :: SimplCont }
| StrictArg
{ sc_dup :: DupFlag
, SimplCont -> ArgInfo
sc_fun :: ArgInfo
, SimplCont -> CallCtxt
sc_cci :: CallCtxt
, sc_cont :: SimplCont }
| TickIt
(Tickish Id)
SimplCont
type StaticEnv = SimplEnv
data DupFlag = NoDup
| Simplified
| OkToDup
isSimplified :: DupFlag -> Bool
isSimplified :: DupFlag -> Bool
isSimplified DupFlag
NoDup = Bool
False
isSimplified DupFlag
_ = Bool
True
perhapsSubstTy :: DupFlag -> StaticEnv -> Type -> Type
perhapsSubstTy :: DupFlag -> StaticEnv -> OutType -> OutType
perhapsSubstTy DupFlag
dup StaticEnv
env OutType
ty
| DupFlag -> Bool
isSimplified DupFlag
dup = OutType
ty
| Bool
otherwise = StaticEnv -> OutType -> OutType
substTy StaticEnv
env OutType
ty
instance Outputable DupFlag where
ppr :: DupFlag -> SDoc
ppr DupFlag
OkToDup = String -> SDoc
text String
"ok"
ppr DupFlag
NoDup = String -> SDoc
text String
"nodup"
ppr DupFlag
Simplified = String -> SDoc
text String
"simpl"
instance Outputable SimplCont where
ppr :: SimplCont -> SDoc
ppr (Stop OutType
ty CallCtxt
interesting) = String -> SDoc
text String
"Stop" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
brackets (CallCtxt -> SDoc
forall a. Outputable a => a -> SDoc
ppr CallCtxt
interesting) SDoc -> SDoc -> SDoc
<+> OutType -> SDoc
forall a. Outputable a => a -> SDoc
ppr OutType
ty
ppr (CastIt OutCoercion
co SimplCont
cont ) = (String -> SDoc
text String
"CastIt" SDoc -> SDoc -> SDoc
<+> OutCoercion -> SDoc
pprOptCo OutCoercion
co) SDoc -> SDoc -> SDoc
$$ SimplCont -> SDoc
forall a. Outputable a => a -> SDoc
ppr SimplCont
cont
ppr (TickIt Tickish InId
t SimplCont
cont) = (String -> SDoc
text String
"TickIt" SDoc -> SDoc -> SDoc
<+> Tickish InId -> SDoc
forall a. Outputable a => a -> SDoc
ppr Tickish InId
t) SDoc -> SDoc -> SDoc
$$ SimplCont -> SDoc
forall a. Outputable a => a -> SDoc
ppr SimplCont
cont
ppr (ApplyToTy { sc_arg_ty :: SimplCont -> OutType
sc_arg_ty = OutType
ty, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont })
= (String -> SDoc
text String
"ApplyToTy" SDoc -> SDoc -> SDoc
<+> OutType -> SDoc
pprParendType OutType
ty) SDoc -> SDoc -> SDoc
$$ SimplCont -> SDoc
forall a. Outputable a => a -> SDoc
ppr SimplCont
cont
ppr (ApplyToVal { sc_arg :: SimplCont -> InExpr
sc_arg = InExpr
arg, sc_dup :: SimplCont -> DupFlag
sc_dup = DupFlag
dup, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont })
= (String -> SDoc
text String
"ApplyToVal" SDoc -> SDoc -> SDoc
<+> DupFlag -> SDoc
forall a. Outputable a => a -> SDoc
ppr DupFlag
dup SDoc -> SDoc -> SDoc
<+> InExpr -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprParendExpr InExpr
arg)
SDoc -> SDoc -> SDoc
$$ SimplCont -> SDoc
forall a. Outputable a => a -> SDoc
ppr SimplCont
cont
ppr (StrictBind { sc_bndr :: SimplCont -> InId
sc_bndr = InId
b, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont })
= (String -> SDoc
text String
"StrictBind" SDoc -> SDoc -> SDoc
<+> InId -> SDoc
forall a. Outputable a => a -> SDoc
ppr InId
b) SDoc -> SDoc -> SDoc
$$ SimplCont -> SDoc
forall a. Outputable a => a -> SDoc
ppr SimplCont
cont
ppr (StrictArg { sc_fun :: SimplCont -> ArgInfo
sc_fun = ArgInfo
ai, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont })
= (String -> SDoc
text String
"StrictArg" SDoc -> SDoc -> SDoc
<+> InId -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ArgInfo -> InId
ai_fun ArgInfo
ai)) SDoc -> SDoc -> SDoc
$$ SimplCont -> SDoc
forall a. Outputable a => a -> SDoc
ppr SimplCont
cont
ppr (Select { sc_dup :: SimplCont -> DupFlag
sc_dup = DupFlag
dup, sc_bndr :: SimplCont -> InId
sc_bndr = InId
bndr, sc_alts :: SimplCont -> [InAlt]
sc_alts = [InAlt]
alts, sc_env :: SimplCont -> StaticEnv
sc_env = StaticEnv
se, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont })
= (String -> SDoc
text String
"Select" SDoc -> SDoc -> SDoc
<+> DupFlag -> SDoc
forall a. Outputable a => a -> SDoc
ppr DupFlag
dup SDoc -> SDoc -> SDoc
<+> InId -> SDoc
forall a. Outputable a => a -> SDoc
ppr InId
bndr) SDoc -> SDoc -> SDoc
$$
SDoc -> SDoc
whenPprDebug (Int -> SDoc -> SDoc
nest Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat [TvSubstEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr (StaticEnv -> TvSubstEnv
seTvSubst StaticEnv
se), [InAlt] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [InAlt]
alts]) SDoc -> SDoc -> SDoc
$$ SimplCont -> SDoc
forall a. Outputable a => a -> SDoc
ppr SimplCont
cont
data ArgInfo
= ArgInfo {
ArgInfo -> InId
ai_fun :: OutId,
ArgInfo -> [ArgSpec]
ai_args :: [ArgSpec],
ArgInfo -> OutType
ai_type :: OutType,
ArgInfo -> FunRules
ai_rules :: FunRules,
ArgInfo -> Bool
ai_encl :: Bool,
ArgInfo -> [Bool]
ai_strs :: [Bool],
ArgInfo -> [Int]
ai_discs :: [Int]
}
data ArgSpec
= ValArg OutExpr
| TyArg { ArgSpec -> OutType
as_arg_ty :: OutType
, ArgSpec -> OutType
as_hole_ty :: OutType }
| CastBy OutCoercion
instance Outputable ArgSpec where
ppr :: ArgSpec -> SDoc
ppr (ValArg InExpr
e) = String -> SDoc
text String
"ValArg" SDoc -> SDoc -> SDoc
<+> InExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr InExpr
e
ppr (TyArg { as_arg_ty :: ArgSpec -> OutType
as_arg_ty = OutType
ty }) = String -> SDoc
text String
"TyArg" SDoc -> SDoc -> SDoc
<+> OutType -> SDoc
forall a. Outputable a => a -> SDoc
ppr OutType
ty
ppr (CastBy OutCoercion
c) = String -> SDoc
text String
"CastBy" SDoc -> SDoc -> SDoc
<+> OutCoercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr OutCoercion
c
addValArgTo :: ArgInfo -> OutExpr -> ArgInfo
addValArgTo :: ArgInfo -> InExpr -> ArgInfo
addValArgTo ArgInfo
ai InExpr
arg = ArgInfo
ai { ai_args :: [ArgSpec]
ai_args = InExpr -> ArgSpec
ValArg InExpr
arg ArgSpec -> [ArgSpec] -> [ArgSpec]
forall a. a -> [a] -> [a]
: ArgInfo -> [ArgSpec]
ai_args ArgInfo
ai
, ai_type :: OutType
ai_type = OutType -> InExpr -> OutType
applyTypeToArg (ArgInfo -> OutType
ai_type ArgInfo
ai) InExpr
arg
, ai_rules :: FunRules
ai_rules = FunRules -> FunRules
decRules (ArgInfo -> FunRules
ai_rules ArgInfo
ai) }
addTyArgTo :: ArgInfo -> OutType -> ArgInfo
addTyArgTo :: ArgInfo -> OutType -> ArgInfo
addTyArgTo ArgInfo
ai OutType
arg_ty = ArgInfo
ai { ai_args :: [ArgSpec]
ai_args = ArgSpec
arg_spec ArgSpec -> [ArgSpec] -> [ArgSpec]
forall a. a -> [a] -> [a]
: ArgInfo -> [ArgSpec]
ai_args ArgInfo
ai
, ai_type :: OutType
ai_type = HasDebugCallStack => OutType -> OutType -> OutType
OutType -> OutType -> OutType
piResultTy OutType
poly_fun_ty OutType
arg_ty
, ai_rules :: FunRules
ai_rules = FunRules -> FunRules
decRules (ArgInfo -> FunRules
ai_rules ArgInfo
ai) }
where
poly_fun_ty :: OutType
poly_fun_ty = ArgInfo -> OutType
ai_type ArgInfo
ai
arg_spec :: ArgSpec
arg_spec = TyArg :: OutType -> OutType -> ArgSpec
TyArg { as_arg_ty :: OutType
as_arg_ty = OutType
arg_ty, as_hole_ty :: OutType
as_hole_ty = OutType
poly_fun_ty }
addCastTo :: ArgInfo -> OutCoercion -> ArgInfo
addCastTo :: ArgInfo -> OutCoercion -> ArgInfo
addCastTo ArgInfo
ai OutCoercion
co = ArgInfo
ai { ai_args :: [ArgSpec]
ai_args = OutCoercion -> ArgSpec
CastBy OutCoercion
co ArgSpec -> [ArgSpec] -> [ArgSpec]
forall a. a -> [a] -> [a]
: ArgInfo -> [ArgSpec]
ai_args ArgInfo
ai
, ai_type :: OutType
ai_type = Pair OutType -> OutType
forall a. Pair a -> a
pSnd (OutCoercion -> Pair OutType
coercionKind OutCoercion
co) }
argInfoAppArgs :: [ArgSpec] -> [OutExpr]
argInfoAppArgs :: [ArgSpec] -> [InExpr]
argInfoAppArgs [] = []
argInfoAppArgs (CastBy {} : [ArgSpec]
_) = []
argInfoAppArgs (ValArg InExpr
e : [ArgSpec]
as) = InExpr
e InExpr -> [InExpr] -> [InExpr]
forall a. a -> [a] -> [a]
: [ArgSpec] -> [InExpr]
argInfoAppArgs [ArgSpec]
as
argInfoAppArgs (TyArg { as_arg_ty :: ArgSpec -> OutType
as_arg_ty = OutType
ty } : [ArgSpec]
as) = OutType -> InExpr
forall b. OutType -> Expr b
Type OutType
ty InExpr -> [InExpr] -> [InExpr]
forall a. a -> [a] -> [a]
: [ArgSpec] -> [InExpr]
argInfoAppArgs [ArgSpec]
as
pushSimplifiedArgs :: SimplEnv -> [ArgSpec] -> SimplCont -> SimplCont
pushSimplifiedArgs :: StaticEnv -> [ArgSpec] -> SimplCont -> SimplCont
pushSimplifiedArgs StaticEnv
_env [] SimplCont
k = SimplCont
k
pushSimplifiedArgs StaticEnv
env (ArgSpec
arg : [ArgSpec]
args) SimplCont
k
= case ArgSpec
arg of
TyArg { as_arg_ty :: ArgSpec -> OutType
as_arg_ty = OutType
arg_ty, as_hole_ty :: ArgSpec -> OutType
as_hole_ty = OutType
hole_ty }
-> ApplyToTy :: OutType -> OutType -> SimplCont -> SimplCont
ApplyToTy { sc_arg_ty :: OutType
sc_arg_ty = OutType
arg_ty, sc_hole_ty :: OutType
sc_hole_ty = OutType
hole_ty, sc_cont :: SimplCont
sc_cont = SimplCont
rest }
ValArg InExpr
e -> ApplyToVal :: DupFlag -> InExpr -> StaticEnv -> SimplCont -> SimplCont
ApplyToVal { sc_arg :: InExpr
sc_arg = InExpr
e, sc_env :: StaticEnv
sc_env = StaticEnv
env, sc_dup :: DupFlag
sc_dup = DupFlag
Simplified, sc_cont :: SimplCont
sc_cont = SimplCont
rest }
CastBy OutCoercion
c -> OutCoercion -> SimplCont -> SimplCont
CastIt OutCoercion
c SimplCont
rest
where
rest :: SimplCont
rest = StaticEnv -> [ArgSpec] -> SimplCont -> SimplCont
pushSimplifiedArgs StaticEnv
env [ArgSpec]
args SimplCont
k
argInfoExpr :: OutId -> [ArgSpec] -> OutExpr
argInfoExpr :: InId -> [ArgSpec] -> InExpr
argInfoExpr InId
fun [ArgSpec]
rev_args
= [ArgSpec] -> InExpr
go [ArgSpec]
rev_args
where
go :: [ArgSpec] -> InExpr
go [] = InId -> InExpr
forall b. InId -> Expr b
Var InId
fun
go (ValArg InExpr
a : [ArgSpec]
as) = [ArgSpec] -> InExpr
go [ArgSpec]
as InExpr -> InExpr -> InExpr
forall b. Expr b -> Expr b -> Expr b
`App` InExpr
a
go (TyArg { as_arg_ty :: ArgSpec -> OutType
as_arg_ty = OutType
ty } : [ArgSpec]
as) = [ArgSpec] -> InExpr
go [ArgSpec]
as InExpr -> InExpr -> InExpr
forall b. Expr b -> Expr b -> Expr b
`App` OutType -> InExpr
forall b. OutType -> Expr b
Type OutType
ty
go (CastBy OutCoercion
co : [ArgSpec]
as) = InExpr -> OutCoercion -> InExpr
mkCast ([ArgSpec] -> InExpr
go [ArgSpec]
as) OutCoercion
co
type FunRules = Maybe (Int, [CoreRule])
decRules :: FunRules -> FunRules
decRules :: FunRules -> FunRules
decRules (Just (Int
n, [CoreRule]
rules)) = (Int, [CoreRule]) -> FunRules
forall a. a -> Maybe a
Just (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1, [CoreRule]
rules)
decRules FunRules
Nothing = FunRules
forall a. Maybe a
Nothing
mkFunRules :: [CoreRule] -> FunRules
mkFunRules :: [CoreRule] -> FunRules
mkFunRules [] = FunRules
forall a. Maybe a
Nothing
mkFunRules [CoreRule]
rs = (Int, [CoreRule]) -> FunRules
forall a. a -> Maybe a
Just (Int
n_required, [CoreRule]
rs)
where
n_required :: Int
n_required = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ((CoreRule -> Int) -> [CoreRule] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map CoreRule -> Int
ruleArity [CoreRule]
rs)
mkBoringStop :: OutType -> SimplCont
mkBoringStop :: OutType -> SimplCont
mkBoringStop OutType
ty = OutType -> CallCtxt -> SimplCont
Stop OutType
ty CallCtxt
BoringCtxt
mkRhsStop :: OutType -> SimplCont
mkRhsStop :: OutType -> SimplCont
mkRhsStop OutType
ty = OutType -> CallCtxt -> SimplCont
Stop OutType
ty CallCtxt
RhsCtxt
mkLazyArgStop :: OutType -> CallCtxt -> SimplCont
mkLazyArgStop :: OutType -> CallCtxt -> SimplCont
mkLazyArgStop OutType
ty CallCtxt
cci = OutType -> CallCtxt -> SimplCont
Stop OutType
ty CallCtxt
cci
contIsRhsOrArg :: SimplCont -> Bool
contIsRhsOrArg :: SimplCont -> Bool
contIsRhsOrArg (Stop {}) = Bool
True
contIsRhsOrArg (StrictBind {}) = Bool
True
contIsRhsOrArg (StrictArg {}) = Bool
True
contIsRhsOrArg SimplCont
_ = Bool
False
contIsRhs :: SimplCont -> Bool
contIsRhs :: SimplCont -> Bool
contIsRhs (Stop OutType
_ CallCtxt
RhsCtxt) = Bool
True
contIsRhs SimplCont
_ = Bool
False
contIsStop :: SimplCont -> Bool
contIsStop :: SimplCont -> Bool
contIsStop (Stop {}) = Bool
True
contIsStop SimplCont
_ = Bool
False
contIsDupable :: SimplCont -> Bool
contIsDupable :: SimplCont -> Bool
contIsDupable (Stop {}) = Bool
True
contIsDupable (ApplyToTy { sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
k }) = SimplCont -> Bool
contIsDupable SimplCont
k
contIsDupable (ApplyToVal { sc_dup :: SimplCont -> DupFlag
sc_dup = DupFlag
OkToDup }) = Bool
True
contIsDupable (Select { sc_dup :: SimplCont -> DupFlag
sc_dup = DupFlag
OkToDup }) = Bool
True
contIsDupable (StrictArg { sc_dup :: SimplCont -> DupFlag
sc_dup = DupFlag
OkToDup }) = Bool
True
contIsDupable (CastIt OutCoercion
_ SimplCont
k) = SimplCont -> Bool
contIsDupable SimplCont
k
contIsDupable SimplCont
_ = Bool
False
contIsTrivial :: SimplCont -> Bool
contIsTrivial :: SimplCont -> Bool
contIsTrivial (Stop {}) = Bool
True
contIsTrivial (ApplyToTy { sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
k }) = SimplCont -> Bool
contIsTrivial SimplCont
k
contIsTrivial (ApplyToVal { sc_arg :: SimplCont -> InExpr
sc_arg = Coercion OutCoercion
_, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
k }) = SimplCont -> Bool
contIsTrivial SimplCont
k
contIsTrivial (CastIt OutCoercion
_ SimplCont
k) = SimplCont -> Bool
contIsTrivial SimplCont
k
contIsTrivial SimplCont
_ = Bool
False
contResultType :: SimplCont -> OutType
contResultType :: SimplCont -> OutType
contResultType (Stop OutType
ty CallCtxt
_) = OutType
ty
contResultType (CastIt OutCoercion
_ SimplCont
k) = SimplCont -> OutType
contResultType SimplCont
k
contResultType (StrictBind { sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
k }) = SimplCont -> OutType
contResultType SimplCont
k
contResultType (StrictArg { sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
k }) = SimplCont -> OutType
contResultType SimplCont
k
contResultType (Select { sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
k }) = SimplCont -> OutType
contResultType SimplCont
k
contResultType (ApplyToTy { sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
k }) = SimplCont -> OutType
contResultType SimplCont
k
contResultType (ApplyToVal { sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
k }) = SimplCont -> OutType
contResultType SimplCont
k
contResultType (TickIt Tickish InId
_ SimplCont
k) = SimplCont -> OutType
contResultType SimplCont
k
contHoleType :: SimplCont -> OutType
contHoleType :: SimplCont -> OutType
contHoleType (Stop OutType
ty CallCtxt
_) = OutType
ty
contHoleType (TickIt Tickish InId
_ SimplCont
k) = SimplCont -> OutType
contHoleType SimplCont
k
contHoleType (CastIt OutCoercion
co SimplCont
_) = Pair OutType -> OutType
forall a. Pair a -> a
pFst (OutCoercion -> Pair OutType
coercionKind OutCoercion
co)
contHoleType (StrictBind { sc_bndr :: SimplCont -> InId
sc_bndr = InId
b, sc_dup :: SimplCont -> DupFlag
sc_dup = DupFlag
dup, sc_env :: SimplCont -> StaticEnv
sc_env = StaticEnv
se })
= DupFlag -> StaticEnv -> OutType -> OutType
perhapsSubstTy DupFlag
dup StaticEnv
se (InId -> OutType
idType InId
b)
contHoleType (StrictArg { sc_fun :: SimplCont -> ArgInfo
sc_fun = ArgInfo
ai }) = OutType -> OutType
funArgTy (ArgInfo -> OutType
ai_type ArgInfo
ai)
contHoleType (ApplyToTy { sc_hole_ty :: SimplCont -> OutType
sc_hole_ty = OutType
ty }) = OutType
ty
contHoleType (ApplyToVal { sc_arg :: SimplCont -> InExpr
sc_arg = InExpr
e, sc_env :: SimplCont -> StaticEnv
sc_env = StaticEnv
se, sc_dup :: SimplCont -> DupFlag
sc_dup = DupFlag
dup, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
k })
= OutType -> OutType -> OutType
mkFunTy (DupFlag -> StaticEnv -> OutType -> OutType
perhapsSubstTy DupFlag
dup StaticEnv
se (InExpr -> OutType
exprType InExpr
e))
(SimplCont -> OutType
contHoleType SimplCont
k)
contHoleType (Select { sc_dup :: SimplCont -> DupFlag
sc_dup = DupFlag
d, sc_bndr :: SimplCont -> InId
sc_bndr = InId
b, sc_env :: SimplCont -> StaticEnv
sc_env = StaticEnv
se })
= DupFlag -> StaticEnv -> OutType -> OutType
perhapsSubstTy DupFlag
d StaticEnv
se (InId -> OutType
idType InId
b)
countArgs :: SimplCont -> Int
countArgs :: SimplCont -> Int
countArgs (ApplyToTy { sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont }) = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ SimplCont -> Int
countArgs SimplCont
cont
countArgs (ApplyToVal { sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont }) = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ SimplCont -> Int
countArgs SimplCont
cont
countArgs SimplCont
_ = Int
0
contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont)
contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont)
contArgs SimplCont
cont
| SimplCont -> Bool
lone SimplCont
cont = (Bool
True, [], SimplCont
cont)
| Bool
otherwise = [ArgSummary] -> SimplCont -> (Bool, [ArgSummary], SimplCont)
go [] SimplCont
cont
where
lone :: SimplCont -> Bool
lone (ApplyToTy {}) = Bool
False
lone (ApplyToVal {}) = Bool
False
lone (CastIt {}) = Bool
False
lone SimplCont
_ = Bool
True
go :: [ArgSummary] -> SimplCont -> (Bool, [ArgSummary], SimplCont)
go [ArgSummary]
args (ApplyToVal { sc_arg :: SimplCont -> InExpr
sc_arg = InExpr
arg, sc_env :: SimplCont -> StaticEnv
sc_env = StaticEnv
se, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
k })
= [ArgSummary] -> SimplCont -> (Bool, [ArgSummary], SimplCont)
go (InExpr -> StaticEnv -> ArgSummary
is_interesting InExpr
arg StaticEnv
se ArgSummary -> [ArgSummary] -> [ArgSummary]
forall a. a -> [a] -> [a]
: [ArgSummary]
args) SimplCont
k
go [ArgSummary]
args (ApplyToTy { sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
k }) = [ArgSummary] -> SimplCont -> (Bool, [ArgSummary], SimplCont)
go [ArgSummary]
args SimplCont
k
go [ArgSummary]
args (CastIt OutCoercion
_ SimplCont
k) = [ArgSummary] -> SimplCont -> (Bool, [ArgSummary], SimplCont)
go [ArgSummary]
args SimplCont
k
go [ArgSummary]
args SimplCont
k = (Bool
False, [ArgSummary] -> [ArgSummary]
forall a. [a] -> [a]
reverse [ArgSummary]
args, SimplCont
k)
is_interesting :: InExpr -> StaticEnv -> ArgSummary
is_interesting InExpr
arg StaticEnv
se = StaticEnv -> InExpr -> ArgSummary
interestingArg StaticEnv
se InExpr
arg
mkArgInfo :: SimplEnv
-> Id
-> [CoreRule]
-> Int
-> SimplCont
-> ArgInfo
mkArgInfo :: StaticEnv -> InId -> [CoreRule] -> Int -> SimplCont -> ArgInfo
mkArgInfo StaticEnv
env InId
fun [CoreRule]
rules Int
n_val_args SimplCont
call_cont
| Int
n_val_args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< InId -> Int
idArity InId
fun
= ArgInfo :: InId
-> [ArgSpec]
-> OutType
-> FunRules
-> Bool
-> [Bool]
-> [Int]
-> ArgInfo
ArgInfo { ai_fun :: InId
ai_fun = InId
fun, ai_args :: [ArgSpec]
ai_args = [], ai_type :: OutType
ai_type = OutType
fun_ty
, ai_rules :: FunRules
ai_rules = FunRules
fun_rules
, ai_encl :: Bool
ai_encl = Bool
False
, ai_strs :: [Bool]
ai_strs = [Bool]
vanilla_stricts
, ai_discs :: [Int]
ai_discs = [Int]
vanilla_discounts }
| Bool
otherwise
= ArgInfo :: InId
-> [ArgSpec]
-> OutType
-> FunRules
-> Bool
-> [Bool]
-> [Int]
-> ArgInfo
ArgInfo { ai_fun :: InId
ai_fun = InId
fun, ai_args :: [ArgSpec]
ai_args = [], ai_type :: OutType
ai_type = OutType
fun_ty
, ai_rules :: FunRules
ai_rules = FunRules
fun_rules
, ai_encl :: Bool
ai_encl = [CoreRule] -> SimplCont -> Bool
interestingArgContext [CoreRule]
rules SimplCont
call_cont
, ai_strs :: [Bool]
ai_strs = [Bool]
arg_stricts
, ai_discs :: [Int]
ai_discs = [Int]
arg_discounts }
where
fun_ty :: OutType
fun_ty = InId -> OutType
idType InId
fun
fun_rules :: FunRules
fun_rules = [CoreRule] -> FunRules
mkFunRules [CoreRule]
rules
vanilla_discounts, arg_discounts :: [Int]
vanilla_discounts :: [Int]
vanilla_discounts = Int -> [Int]
forall a. a -> [a]
repeat Int
0
arg_discounts :: [Int]
arg_discounts = case InId -> Unfolding
idUnfolding InId
fun of
CoreUnfolding {uf_guidance :: Unfolding -> UnfoldingGuidance
uf_guidance = UnfIfGoodArgs {ug_args :: UnfoldingGuidance -> [Int]
ug_args = [Int]
discounts}}
-> [Int]
discounts [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int]
vanilla_discounts
Unfolding
_ -> [Int]
vanilla_discounts
vanilla_stricts, arg_stricts :: [Bool]
vanilla_stricts :: [Bool]
vanilla_stricts = Bool -> [Bool]
forall a. a -> [a]
repeat Bool
False
arg_stricts :: [Bool]
arg_stricts
| Bool -> Bool
not (SimplMode -> Bool
sm_inline (StaticEnv -> SimplMode
seMode StaticEnv
env))
= [Bool]
vanilla_stricts
| Bool
otherwise
= OutType -> [Bool] -> [Bool]
add_type_str OutType
fun_ty ([Bool] -> [Bool]) -> [Bool] -> [Bool]
forall a b. (a -> b) -> a -> b
$
case StrictSig -> ([Demand], DmdResult)
splitStrictSig (InId -> StrictSig
idStrictness InId
fun) of
([Demand]
demands, DmdResult
result_info)
| Bool -> Bool
not ([Demand]
demands [Demand] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthExceeds` Int
n_val_args)
->
if DmdResult -> Bool
isBotRes DmdResult
result_info then
(Demand -> Bool) -> [Demand] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map Demand -> Bool
forall s u. JointDmd (Str s) (Use u) -> Bool
isStrictDmd [Demand]
demands
else
(Demand -> Bool) -> [Demand] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map Demand -> Bool
forall s u. JointDmd (Str s) (Use u) -> Bool
isStrictDmd [Demand]
demands [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ [Bool]
vanilla_stricts
| Bool
otherwise
-> WARN( True, text "More demands than arity" <+> ppr fun <+> ppr (idArity fun)
<+> ppr n_val_args <+> ppr demands )
[Bool]
vanilla_stricts
add_type_str :: Type -> [Bool] -> [Bool]
add_type_str :: OutType -> [Bool] -> [Bool]
add_type_str OutType
_ [] = []
add_type_str OutType
fun_ty all_strs :: [Bool]
all_strs@(Bool
str:[Bool]
strs)
| Just (OutType
arg_ty, OutType
fun_ty') <- OutType -> Maybe (OutType, OutType)
splitFunTy_maybe OutType
fun_ty
= (Bool
str Bool -> Bool -> Bool
|| Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== HasDebugCallStack => OutType -> Maybe Bool
OutType -> Maybe Bool
isLiftedType_maybe OutType
arg_ty)
Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: OutType -> [Bool] -> [Bool]
add_type_str OutType
fun_ty' [Bool]
strs
| Just (InId
_, OutType
fun_ty') <- OutType -> Maybe (InId, OutType)
splitForAllTy_maybe OutType
fun_ty
= OutType -> [Bool] -> [Bool]
add_type_str OutType
fun_ty' [Bool]
all_strs
| Bool
otherwise
= [Bool]
all_strs
interestingCallContext :: SimplEnv -> SimplCont -> CallCtxt
interestingCallContext :: StaticEnv -> SimplCont -> CallCtxt
interestingCallContext StaticEnv
env SimplCont
cont
= SimplCont -> CallCtxt
interesting SimplCont
cont
where
interesting :: SimplCont -> CallCtxt
interesting (Select {})
| SimplMode -> Bool
sm_case_case (StaticEnv -> SimplMode
getMode StaticEnv
env) = CallCtxt
CaseCtxt
| Bool
otherwise = CallCtxt
BoringCtxt
interesting (ApplyToVal {}) = CallCtxt
ValAppCtxt
interesting (StrictArg { sc_cci :: SimplCont -> CallCtxt
sc_cci = CallCtxt
cci }) = CallCtxt
cci
interesting (StrictBind {}) = CallCtxt
BoringCtxt
interesting (Stop OutType
_ CallCtxt
cci) = CallCtxt
cci
interesting (TickIt Tickish InId
_ SimplCont
k) = SimplCont -> CallCtxt
interesting SimplCont
k
interesting (ApplyToTy { sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
k }) = SimplCont -> CallCtxt
interesting SimplCont
k
interesting (CastIt OutCoercion
_ SimplCont
k) = SimplCont -> CallCtxt
interesting SimplCont
k
interestingArgContext :: [CoreRule] -> SimplCont -> Bool
interestingArgContext :: [CoreRule] -> SimplCont -> Bool
interestingArgContext [CoreRule]
rules SimplCont
call_cont
= [CoreRule] -> Bool
forall a. [a] -> Bool
notNull [CoreRule]
rules Bool -> Bool -> Bool
|| Bool
enclosing_fn_has_rules
where
enclosing_fn_has_rules :: Bool
enclosing_fn_has_rules = SimplCont -> Bool
go SimplCont
call_cont
go :: SimplCont -> Bool
go (Select {}) = Bool
False
go (ApplyToVal {}) = Bool
False
go (ApplyToTy {}) = Bool
False
go (StrictArg { sc_cci :: SimplCont -> CallCtxt
sc_cci = CallCtxt
cci }) = CallCtxt -> Bool
interesting CallCtxt
cci
go (StrictBind {}) = Bool
False
go (CastIt OutCoercion
_ SimplCont
c) = SimplCont -> Bool
go SimplCont
c
go (Stop OutType
_ CallCtxt
cci) = CallCtxt -> Bool
interesting CallCtxt
cci
go (TickIt Tickish InId
_ SimplCont
c) = SimplCont -> Bool
go SimplCont
c
interesting :: CallCtxt -> Bool
interesting CallCtxt
RuleArgCtxt = Bool
True
interesting CallCtxt
_ = Bool
False
interestingArg :: SimplEnv -> CoreExpr -> ArgSummary
interestingArg :: StaticEnv -> InExpr -> ArgSummary
interestingArg StaticEnv
env InExpr
e = StaticEnv -> Int -> InExpr -> ArgSummary
go StaticEnv
env Int
0 InExpr
e
where
go :: StaticEnv -> Int -> InExpr -> ArgSummary
go StaticEnv
env Int
n (Var InId
v)
= case StaticEnv -> InId -> SimplSR
substId StaticEnv
env InId
v of
DoneId InId
v' -> Int -> InId -> ArgSummary
go_var Int
n InId
v'
DoneEx InExpr
e Maybe Int
_ -> StaticEnv -> Int -> InExpr -> ArgSummary
go (StaticEnv -> StaticEnv
zapSubstEnv StaticEnv
env) Int
n InExpr
e
ContEx TvSubstEnv
tvs CvSubstEnv
cvs SimplIdSubst
ids InExpr
e -> StaticEnv -> Int -> InExpr -> ArgSummary
go (StaticEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> StaticEnv
setSubstEnv StaticEnv
env TvSubstEnv
tvs CvSubstEnv
cvs SimplIdSubst
ids) Int
n InExpr
e
go StaticEnv
_ Int
_ (Lit {}) = ArgSummary
ValueArg
go StaticEnv
_ Int
_ (Type OutType
_) = ArgSummary
TrivArg
go StaticEnv
_ Int
_ (Coercion OutCoercion
_) = ArgSummary
TrivArg
go StaticEnv
env Int
n (App InExpr
fn (Type OutType
_)) = StaticEnv -> Int -> InExpr -> ArgSummary
go StaticEnv
env Int
n InExpr
fn
go StaticEnv
env Int
n (App InExpr
fn InExpr
_) = StaticEnv -> Int -> InExpr -> ArgSummary
go StaticEnv
env (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) InExpr
fn
go StaticEnv
env Int
n (Tick Tickish InId
_ InExpr
a) = StaticEnv -> Int -> InExpr -> ArgSummary
go StaticEnv
env Int
n InExpr
a
go StaticEnv
env Int
n (Cast InExpr
e OutCoercion
_) = StaticEnv -> Int -> InExpr -> ArgSummary
go StaticEnv
env Int
n InExpr
e
go StaticEnv
env Int
n (Lam InId
v InExpr
e)
| InId -> Bool
isTyVar InId
v = StaticEnv -> Int -> InExpr -> ArgSummary
go StaticEnv
env Int
n InExpr
e
| Int
nInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
0 = ArgSummary
NonTrivArg
| Bool
otherwise = ArgSummary
ValueArg
go StaticEnv
_ Int
_ (Case {}) = ArgSummary
NonTrivArg
go StaticEnv
env Int
n (Let Bind InId
b InExpr
e) = case StaticEnv -> Int -> InExpr -> ArgSummary
go StaticEnv
env' Int
n InExpr
e of
ArgSummary
ValueArg -> ArgSummary
ValueArg
ArgSummary
_ -> ArgSummary
NonTrivArg
where
env' :: StaticEnv
env' = StaticEnv
env StaticEnv -> [InId] -> StaticEnv
`addNewInScopeIds` Bind InId -> [InId]
forall b. Bind b -> [b]
bindersOf Bind InId
b
go_var :: Int -> InId -> ArgSummary
go_var Int
n InId
v
| InId -> Bool
isConLikeId InId
v = ArgSummary
ValueArg
| InId -> Int
idArity InId
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n = ArgSummary
ValueArg
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = ArgSummary
NonTrivArg
| Bool
conlike_unfolding = ArgSummary
ValueArg
| Bool
otherwise = ArgSummary
TrivArg
where
conlike_unfolding :: Bool
conlike_unfolding = Unfolding -> Bool
isConLikeUnfolding (InId -> Unfolding
idUnfolding InId
v)
simplEnvForGHCi :: DynFlags -> SimplEnv
simplEnvForGHCi :: DynFlags -> StaticEnv
simplEnvForGHCi DynFlags
dflags
= SimplMode -> StaticEnv
mkSimplEnv (SimplMode -> StaticEnv) -> SimplMode -> StaticEnv
forall a b. (a -> b) -> a -> b
$ SimplMode :: [String]
-> CompilerPhase
-> DynFlags
-> Bool
-> Bool
-> Bool
-> Bool
-> SimplMode
SimplMode { sm_names :: [String]
sm_names = [String
"GHCi"]
, sm_phase :: CompilerPhase
sm_phase = CompilerPhase
InitialPhase
, sm_dflags :: DynFlags
sm_dflags = DynFlags
dflags
, sm_rules :: Bool
sm_rules = Bool
rules_on
, sm_inline :: Bool
sm_inline = Bool
False
, sm_eta_expand :: Bool
sm_eta_expand = Bool
eta_expand_on
, sm_case_case :: Bool
sm_case_case = Bool
True }
where
rules_on :: Bool
rules_on = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_EnableRewriteRules DynFlags
dflags
eta_expand_on :: Bool
eta_expand_on = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DoLambdaEtaExpansion DynFlags
dflags
updModeForStableUnfoldings :: Activation -> SimplMode -> SimplMode
updModeForStableUnfoldings :: Activation -> SimplMode -> SimplMode
updModeForStableUnfoldings Activation
inline_rule_act SimplMode
current_mode
= SimplMode
current_mode { sm_phase :: CompilerPhase
sm_phase = Activation -> CompilerPhase
phaseFromActivation Activation
inline_rule_act
, sm_inline :: Bool
sm_inline = Bool
True
, sm_eta_expand :: Bool
sm_eta_expand = Bool
False }
where
phaseFromActivation :: Activation -> CompilerPhase
phaseFromActivation (ActiveAfter SourceText
_ Int
n) = Int -> CompilerPhase
Phase Int
n
phaseFromActivation Activation
_ = CompilerPhase
InitialPhase
updModeForRules :: SimplMode -> SimplMode
updModeForRules :: SimplMode -> SimplMode
updModeForRules SimplMode
current_mode
= SimplMode
current_mode { sm_phase :: CompilerPhase
sm_phase = CompilerPhase
InitialPhase
, sm_inline :: Bool
sm_inline = Bool
False
, sm_rules :: Bool
sm_rules = Bool
False
, sm_eta_expand :: Bool
sm_eta_expand = Bool
False }
activeUnfolding :: SimplMode -> Id -> Bool
activeUnfolding :: SimplMode -> InId -> Bool
activeUnfolding SimplMode
mode InId
id
| Unfolding -> Bool
isCompulsoryUnfolding (InId -> Unfolding
realIdUnfolding InId
id)
= Bool
True
| Bool
otherwise
= CompilerPhase -> Activation -> Bool
isActive (SimplMode -> CompilerPhase
sm_phase SimplMode
mode) (InId -> Activation
idInlineActivation InId
id)
Bool -> Bool -> Bool
&& SimplMode -> Bool
sm_inline SimplMode
mode
getUnfoldingInRuleMatch :: SimplEnv -> InScopeEnv
getUnfoldingInRuleMatch :: StaticEnv -> InScopeEnv
getUnfoldingInRuleMatch StaticEnv
env
= (InScopeSet
in_scope, InId -> Unfolding
id_unf)
where
in_scope :: InScopeSet
in_scope = StaticEnv -> InScopeSet
seInScope StaticEnv
env
mode :: SimplMode
mode = StaticEnv -> SimplMode
getMode StaticEnv
env
id_unf :: InId -> Unfolding
id_unf InId
id | InId -> Bool
unf_is_active InId
id = InId -> Unfolding
idUnfolding InId
id
| Bool
otherwise = Unfolding
NoUnfolding
unf_is_active :: InId -> Bool
unf_is_active InId
id
| Bool -> Bool
not (SimplMode -> Bool
sm_rules SimplMode
mode) =
Unfolding -> Bool
isStableUnfolding (InId -> Unfolding
realIdUnfolding InId
id)
| Bool
otherwise = CompilerPhase -> Activation -> Bool
isActive (SimplMode -> CompilerPhase
sm_phase SimplMode
mode) (InId -> Activation
idInlineActivation InId
id)
activeRule :: SimplMode -> Activation -> Bool
activeRule :: SimplMode -> Activation -> Bool
activeRule SimplMode
mode
| Bool -> Bool
not (SimplMode -> Bool
sm_rules SimplMode
mode) = \Activation
_ -> Bool
False
| Bool
otherwise = CompilerPhase -> Activation -> Bool
isActive (SimplMode -> CompilerPhase
sm_phase SimplMode
mode)
preInlineUnconditionally
:: SimplEnv -> TopLevelFlag -> InId
-> InExpr -> StaticEnv
-> Maybe SimplEnv
preInlineUnconditionally :: StaticEnv
-> TopLevelFlag -> InId -> InExpr -> StaticEnv -> Maybe StaticEnv
preInlineUnconditionally StaticEnv
env TopLevelFlag
top_lvl InId
bndr InExpr
rhs StaticEnv
rhs_env
| Bool -> Bool
not Bool
pre_inline_unconditionally = Maybe StaticEnv
forall a. Maybe a
Nothing
| Bool -> Bool
not Bool
active = Maybe StaticEnv
forall a. Maybe a
Nothing
| TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl Bool -> Bool -> Bool
&& InId -> Bool
isBottomingId InId
bndr = Maybe StaticEnv
forall a. Maybe a
Nothing
| InId -> Bool
isCoVar InId
bndr = Maybe StaticEnv
forall a. Maybe a
Nothing
| InId -> Bool
isExitJoinId InId
bndr = Maybe StaticEnv
forall a. Maybe a
Nothing
| Bool -> Bool
not (OccInfo -> Bool
one_occ (InId -> OccInfo
idOccInfo InId
bndr)) = Maybe StaticEnv
forall a. Maybe a
Nothing
| Bool -> Bool
not (Unfolding -> Bool
isStableUnfolding Unfolding
unf) = StaticEnv -> Maybe StaticEnv
forall a. a -> Maybe a
Just (InExpr -> StaticEnv
extend_subst_with InExpr
rhs)
| InlinePragma -> Bool
isInlinablePragma InlinePragma
inline_prag
, Just InExpr
inl <- Unfolding -> Maybe InExpr
maybeUnfoldingTemplate Unfolding
unf = StaticEnv -> Maybe StaticEnv
forall a. a -> Maybe a
Just (InExpr -> StaticEnv
extend_subst_with InExpr
inl)
| Bool
otherwise = Maybe StaticEnv
forall a. Maybe a
Nothing
where
unf :: Unfolding
unf = InId -> Unfolding
idUnfolding InId
bndr
extend_subst_with :: InExpr -> StaticEnv
extend_subst_with InExpr
inl_rhs = StaticEnv -> InId -> SimplSR -> StaticEnv
extendIdSubst StaticEnv
env InId
bndr (StaticEnv -> InExpr -> SimplSR
mkContEx StaticEnv
rhs_env InExpr
inl_rhs)
one_occ :: OccInfo -> Bool
one_occ OccInfo
IAmDead = Bool
True
one_occ (OneOcc { occ_one_br :: OccInfo -> Bool
occ_one_br = Bool
True
, occ_in_lam :: OccInfo -> Bool
occ_in_lam = Bool
in_lam
, occ_int_cxt :: OccInfo -> Bool
occ_int_cxt = Bool
int_cxt })
| Bool -> Bool
not Bool
in_lam = TopLevelFlag -> Bool
isNotTopLevel TopLevelFlag
top_lvl Bool -> Bool -> Bool
|| Bool
early_phase
| Bool
otherwise = Bool
int_cxt Bool -> Bool -> Bool
&& InExpr -> Bool
canInlineInLam InExpr
rhs
one_occ OccInfo
_ = Bool
False
pre_inline_unconditionally :: Bool
pre_inline_unconditionally = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SimplPreInlining (StaticEnv -> DynFlags
seDynFlags StaticEnv
env)
mode :: SimplMode
mode = StaticEnv -> SimplMode
getMode StaticEnv
env
active :: Bool
active = CompilerPhase -> Activation -> Bool
isActive (SimplMode -> CompilerPhase
sm_phase SimplMode
mode) (InlinePragma -> Activation
inlinePragmaActivation InlinePragma
inline_prag)
inline_prag :: InlinePragma
inline_prag = InId -> InlinePragma
idInlinePragma InId
bndr
canInlineInLam :: InExpr -> Bool
canInlineInLam (Lit Literal
_) = Bool
True
canInlineInLam (Lam InId
b InExpr
e) = InId -> Bool
isRuntimeVar InId
b Bool -> Bool -> Bool
|| InExpr -> Bool
canInlineInLam InExpr
e
canInlineInLam (Tick Tickish InId
t InExpr
e) = Bool -> Bool
not (Tickish InId -> Bool
forall id. Tickish id -> Bool
tickishIsCode Tickish InId
t) Bool -> Bool -> Bool
&& InExpr -> Bool
canInlineInLam InExpr
e
canInlineInLam InExpr
_ = Bool
False
early_phase :: Bool
early_phase = case SimplMode -> CompilerPhase
sm_phase SimplMode
mode of
Phase Int
0 -> Bool
False
CompilerPhase
_ -> Bool
True
postInlineUnconditionally
:: SimplEnv -> TopLevelFlag
-> OutId
-> OccInfo
-> OutExpr
-> Bool
postInlineUnconditionally :: StaticEnv -> TopLevelFlag -> InId -> OccInfo -> InExpr -> Bool
postInlineUnconditionally StaticEnv
env TopLevelFlag
top_lvl InId
bndr OccInfo
occ_info InExpr
rhs
| Bool -> Bool
not Bool
active = Bool
False
| OccInfo -> Bool
isWeakLoopBreaker OccInfo
occ_info = Bool
False
| Unfolding -> Bool
isStableUnfolding Unfolding
unfolding = Bool
False
| TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl = Bool
False
| InExpr -> Bool
exprIsTrivial InExpr
rhs = Bool
True
| Bool
otherwise
= case OccInfo
occ_info of
OneOcc { occ_in_lam :: OccInfo -> Bool
occ_in_lam = Bool
in_lam, occ_int_cxt :: OccInfo -> Bool
occ_int_cxt = Bool
int_cxt }
-> DynFlags -> Unfolding -> Bool
smallEnoughToInline DynFlags
dflags Unfolding
unfolding
Bool -> Bool -> Bool
&& (Bool -> Bool
not Bool
in_lam Bool -> Bool -> Bool
||
(Unfolding -> Bool
isCheapUnfolding Unfolding
unfolding Bool -> Bool -> Bool
&& Bool
int_cxt))
OccInfo
IAmDead -> Bool
True
OccInfo
_ -> Bool
False
where
unfolding :: Unfolding
unfolding = InId -> Unfolding
idUnfolding InId
bndr
dflags :: DynFlags
dflags = StaticEnv -> DynFlags
seDynFlags StaticEnv
env
active :: Bool
active = CompilerPhase -> Activation -> Bool
isActive (SimplMode -> CompilerPhase
sm_phase (StaticEnv -> SimplMode
getMode StaticEnv
env)) (InId -> Activation
idInlineActivation InId
bndr)
mkLam :: SimplEnv -> [OutBndr] -> OutExpr -> SimplCont -> SimplM OutExpr
mkLam :: StaticEnv -> [InId] -> InExpr -> SimplCont -> SimplM InExpr
mkLam StaticEnv
_env [] InExpr
body SimplCont
_cont
= InExpr -> SimplM InExpr
forall (m :: * -> *) a. Monad m => a -> m a
return InExpr
body
mkLam StaticEnv
env [InId]
bndrs InExpr
body SimplCont
cont
= do { DynFlags
dflags <- SimplM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; DynFlags -> [InId] -> InExpr -> SimplM InExpr
mkLam' DynFlags
dflags [InId]
bndrs InExpr
body }
where
mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr
mkLam' :: DynFlags -> [InId] -> InExpr -> SimplM InExpr
mkLam' DynFlags
dflags [InId]
bndrs (Cast InExpr
body OutCoercion
co)
| Bool -> Bool
not ((InId -> Bool) -> [InId] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any InId -> Bool
bad [InId]
bndrs)
= do { InExpr
lam <- DynFlags -> [InId] -> InExpr -> SimplM InExpr
mkLam' DynFlags
dflags [InId]
bndrs InExpr
body
; InExpr -> SimplM InExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (InExpr -> OutCoercion -> InExpr
mkCast InExpr
lam (Role -> [InId] -> OutCoercion -> OutCoercion
mkPiCos Role
Representational [InId]
bndrs OutCoercion
co)) }
where
co_vars :: TyCoVarSet
co_vars = OutCoercion -> TyCoVarSet
tyCoVarsOfCo OutCoercion
co
bad :: InId -> Bool
bad InId
bndr = InId -> Bool
isCoVar InId
bndr Bool -> Bool -> Bool
&& InId
bndr InId -> TyCoVarSet -> Bool
`elemVarSet` TyCoVarSet
co_vars
mkLam' DynFlags
dflags [InId]
bndrs body :: InExpr
body@(Lam {})
= DynFlags -> [InId] -> InExpr -> SimplM InExpr
mkLam' DynFlags
dflags ([InId]
bndrs [InId] -> [InId] -> [InId]
forall a. [a] -> [a] -> [a]
++ [InId]
bndrs1) InExpr
body1
where
([InId]
bndrs1, InExpr
body1) = InExpr -> ([InId], InExpr)
forall b. Expr b -> ([b], Expr b)
collectBinders InExpr
body
mkLam' DynFlags
dflags [InId]
bndrs (Tick Tickish InId
t InExpr
expr)
| Tickish InId -> Bool
forall id. Tickish id -> Bool
tickishFloatable Tickish InId
t
= Tickish InId -> InExpr -> InExpr
mkTick Tickish InId
t (InExpr -> InExpr) -> SimplM InExpr -> SimplM InExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DynFlags -> [InId] -> InExpr -> SimplM InExpr
mkLam' DynFlags
dflags [InId]
bndrs InExpr
expr
mkLam' DynFlags
dflags [InId]
bndrs InExpr
body
| GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DoEtaReduction DynFlags
dflags
, Just InExpr
etad_lam <- [InId] -> InExpr -> Maybe InExpr
tryEtaReduce [InId]
bndrs InExpr
body
= do { Tick -> SimplM ()
tick (InId -> Tick
EtaReduction ([InId] -> InId
forall a. [a] -> a
head [InId]
bndrs))
; InExpr -> SimplM InExpr
forall (m :: * -> *) a. Monad m => a -> m a
return InExpr
etad_lam }
| Bool -> Bool
not (SimplCont -> Bool
contIsRhs SimplCont
cont)
, SimplMode -> Bool
sm_eta_expand (StaticEnv -> SimplMode
getMode StaticEnv
env)
, (InId -> Bool) -> [InId] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any InId -> Bool
isRuntimeVar [InId]
bndrs
, let body_arity :: Int
body_arity = DynFlags -> InExpr -> Int
exprEtaExpandArity DynFlags
dflags InExpr
body
, Int
body_arity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
= do { Tick -> SimplM ()
tick (InId -> Tick
EtaExpansion ([InId] -> InId
forall a. [a] -> a
head [InId]
bndrs))
; let res :: InExpr
res = [InId] -> InExpr -> InExpr
forall b. [b] -> Expr b -> Expr b
mkLams [InId]
bndrs (Int -> InExpr -> InExpr
etaExpand Int
body_arity InExpr
body)
; String -> SDoc -> SimplM ()
traceSmpl String
"eta expand" ([SDoc] -> SDoc
vcat [String -> SDoc
text String
"before" SDoc -> SDoc -> SDoc
<+> InExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([InId] -> InExpr -> InExpr
forall b. [b] -> Expr b -> Expr b
mkLams [InId]
bndrs InExpr
body)
, String -> SDoc
text String
"after" SDoc -> SDoc -> SDoc
<+> InExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr InExpr
res])
; InExpr -> SimplM InExpr
forall (m :: * -> *) a. Monad m => a -> m a
return InExpr
res }
| Bool
otherwise
= InExpr -> SimplM InExpr
forall (m :: * -> *) a. Monad m => a -> m a
return ([InId] -> InExpr -> InExpr
forall b. [b] -> Expr b -> Expr b
mkLams [InId]
bndrs InExpr
body)
tryEtaExpandRhs :: SimplMode -> OutId -> OutExpr
-> SimplM (Arity, Bool, OutExpr)
tryEtaExpandRhs :: SimplMode -> InId -> InExpr -> SimplM (Int, Bool, InExpr)
tryEtaExpandRhs SimplMode
mode InId
bndr InExpr
rhs
| Just Int
join_arity <- InId -> Maybe Int
isJoinId_maybe InId
bndr
= do { let ([InId]
join_bndrs, InExpr
join_body) = Int -> InExpr -> ([InId], InExpr)
forall b. Int -> Expr b -> ([b], Expr b)
collectNBinders Int
join_arity InExpr
rhs
; (Int, Bool, InExpr) -> SimplM (Int, Bool, InExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return ((InId -> Bool) -> [InId] -> Int
forall a. (a -> Bool) -> [a] -> Int
count InId -> Bool
isId [InId]
join_bndrs, InExpr -> Bool
exprIsBottom InExpr
join_body, InExpr
rhs) }
| Bool
otherwise
= do { (Int
new_arity, Bool
is_bot, InExpr
new_rhs) <- SimplM (Int, Bool, InExpr)
try_expand
; WARN( new_arity < old_id_arity,
(text "Arity decrease:" <+> (ppr bndr <+> ppr old_id_arity
<+> ppr old_arity <+> ppr new_arity) $$ ppr new_rhs) )
(Int, Bool, InExpr) -> SimplM (Int, Bool, InExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
new_arity, Bool
is_bot, InExpr
new_rhs) }
where
try_expand :: SimplM (Int, Bool, InExpr)
try_expand
| InExpr -> Bool
exprIsTrivial InExpr
rhs
= (Int, Bool, InExpr) -> SimplM (Int, Bool, InExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (InExpr -> Int
exprArity InExpr
rhs, Bool
False, InExpr
rhs)
| SimplMode -> Bool
sm_eta_expand SimplMode
mode
, Int
new_arity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
old_arity
= do { Tick -> SimplM ()
tick (InId -> Tick
EtaExpansion InId
bndr)
; (Int, Bool, InExpr) -> SimplM (Int, Bool, InExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
new_arity, Bool
is_bot, Int -> InExpr -> InExpr
etaExpand Int
new_arity InExpr
rhs) }
| Bool
otherwise
= (Int, Bool, InExpr) -> SimplM (Int, Bool, InExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
old_arity, Bool
is_bot Bool -> Bool -> Bool
&& Int
new_arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
old_arity, InExpr
rhs)
dflags :: DynFlags
dflags = SimplMode -> DynFlags
sm_dflags SimplMode
mode
old_arity :: Int
old_arity = InExpr -> Int
exprArity InExpr
rhs
old_id_arity :: Int
old_id_arity = InId -> Int
idArity InId
bndr
(Int
new_arity1, Bool
is_bot) = DynFlags -> InId -> InExpr -> Int -> (Int, Bool)
findRhsArity DynFlags
dflags InId
bndr InExpr
rhs Int
old_arity
new_arity2 :: Int
new_arity2 = InId -> Int
idCallArity InId
bndr
new_arity :: Int
new_arity = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
new_arity1 Int
new_arity2
abstractFloats :: DynFlags -> TopLevelFlag -> [OutTyVar] -> SimplFloats
-> OutExpr -> SimplM ([OutBind], OutExpr)
abstractFloats :: DynFlags
-> TopLevelFlag
-> [InId]
-> SimplFloats
-> InExpr
-> SimplM ([Bind InId], InExpr)
abstractFloats DynFlags
dflags TopLevelFlag
top_lvl [InId]
main_tvs SimplFloats
floats InExpr
body
= ASSERT( notNull body_floats )
ASSERT( isNilOL (sfJoinFloats floats) )
do { (Subst
subst, [Bind InId]
float_binds) <- (Subst -> Bind InId -> SimplM (Subst, Bind InId))
-> Subst -> [Bind InId] -> SimplM (Subst, [Bind InId])
forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM Subst -> Bind InId -> SimplM (Subst, Bind InId)
abstract Subst
empty_subst [Bind InId]
body_floats
; ([Bind InId], InExpr) -> SimplM ([Bind InId], InExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Bind InId]
float_binds, SDoc -> Subst -> InExpr -> InExpr
CoreSubst.substExpr (String -> SDoc
text String
"abstract_floats1") Subst
subst InExpr
body) }
where
is_top_lvl :: Bool
is_top_lvl = TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl
main_tv_set :: TyCoVarSet
main_tv_set = [InId] -> TyCoVarSet
mkVarSet [InId]
main_tvs
body_floats :: [Bind InId]
body_floats = LetFloats -> [Bind InId]
letFloatBinds (SimplFloats -> LetFloats
sfLetFloats SimplFloats
floats)
empty_subst :: Subst
empty_subst = InScopeSet -> Subst
CoreSubst.mkEmptySubst (SimplFloats -> InScopeSet
sfInScope SimplFloats
floats)
abstract :: CoreSubst.Subst -> OutBind -> SimplM (CoreSubst.Subst, OutBind)
abstract :: Subst -> Bind InId -> SimplM (Subst, Bind InId)
abstract Subst
subst (NonRec InId
id InExpr
rhs)
= do { (InId
poly_id1, InExpr
poly_app) <- [InId] -> InId -> SimplM (InId, InExpr)
mk_poly1 [InId]
tvs_here InId
id
; let (InId
poly_id2, InExpr
poly_rhs) = InId -> [InId] -> InExpr -> (InId, InExpr)
mk_poly2 InId
poly_id1 [InId]
tvs_here InExpr
rhs'
subst' :: Subst
subst' = Subst -> InId -> InExpr -> Subst
CoreSubst.extendIdSubst Subst
subst InId
id InExpr
poly_app
; (Subst, Bind InId) -> SimplM (Subst, Bind InId)
forall (m :: * -> *) a. Monad m => a -> m a
return (Subst
subst', InId -> InExpr -> Bind InId
forall b. b -> Expr b -> Bind b
NonRec InId
poly_id2 InExpr
poly_rhs) }
where
rhs' :: InExpr
rhs' = SDoc -> Subst -> InExpr -> InExpr
CoreSubst.substExpr (String -> SDoc
text String
"abstract_floats2") Subst
subst InExpr
rhs
tvs_here :: [InId]
tvs_here = [InId] -> [InId]
scopedSort ([InId] -> [InId]) -> [InId] -> [InId]
forall a b. (a -> b) -> a -> b
$
(InId -> Bool) -> [InId] -> [InId]
forall a. (a -> Bool) -> [a] -> [a]
filter (InId -> TyCoVarSet -> Bool
`elemVarSet` TyCoVarSet
main_tv_set) ([InId] -> [InId]) -> [InId] -> [InId]
forall a b. (a -> b) -> a -> b
$
[InId] -> [InId]
closeOverKindsList ([InId] -> [InId]) -> [InId] -> [InId]
forall a b. (a -> b) -> a -> b
$
(InId -> Bool) -> InExpr -> [InId]
exprSomeFreeVarsList InId -> Bool
isTyVar InExpr
rhs'
abstract Subst
subst (Rec [(InId, InExpr)]
prs)
= do { ([InId]
poly_ids, [InExpr]
poly_apps) <- (InId -> SimplM (InId, InExpr))
-> [InId] -> SimplM ([InId], [InExpr])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM ([InId] -> InId -> SimplM (InId, InExpr)
mk_poly1 [InId]
tvs_here) [InId]
ids
; let subst' :: Subst
subst' = Subst -> [(InId, InExpr)] -> Subst
CoreSubst.extendSubstList Subst
subst ([InId]
ids [InId] -> [InExpr] -> [(InId, InExpr)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [InExpr]
poly_apps)
poly_pairs :: [(InId, InExpr)]
poly_pairs = [ InId -> [InId] -> InExpr -> (InId, InExpr)
mk_poly2 InId
poly_id [InId]
tvs_here InExpr
rhs'
| (InId
poly_id, InExpr
rhs) <- [InId]
poly_ids [InId] -> [InExpr] -> [(InId, InExpr)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [InExpr]
rhss
, let rhs' :: InExpr
rhs' = SDoc -> Subst -> InExpr -> InExpr
CoreSubst.substExpr (String -> SDoc
text String
"abstract_floats")
Subst
subst' InExpr
rhs ]
; (Subst, Bind InId) -> SimplM (Subst, Bind InId)
forall (m :: * -> *) a. Monad m => a -> m a
return (Subst
subst', [(InId, InExpr)] -> Bind InId
forall b. [(b, Expr b)] -> Bind b
Rec [(InId, InExpr)]
poly_pairs) }
where
([InId]
ids,[InExpr]
rhss) = [(InId, InExpr)] -> ([InId], [InExpr])
forall a b. [(a, b)] -> ([a], [b])
unzip [(InId, InExpr)]
prs
tvs_here :: [InId]
tvs_here = [InId] -> [InId]
scopedSort [InId]
main_tvs
mk_poly1 :: [TyVar] -> Id -> SimplM (Id, CoreExpr)
mk_poly1 :: [InId] -> InId -> SimplM (InId, InExpr)
mk_poly1 [InId]
tvs_here InId
var
= do { Unique
uniq <- SimplM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
; let poly_name :: Name
poly_name = Name -> Unique -> Name
setNameUnique (InId -> Name
idName InId
var) Unique
uniq
poly_ty :: OutType
poly_ty = [InId] -> OutType -> OutType
mkInvForAllTys [InId]
tvs_here (InId -> OutType
idType InId
var)
poly_id :: InId
poly_id = InId -> [InId] -> InId -> InId
transferPolyIdInfo InId
var [InId]
tvs_here (InId -> InId) -> InId -> InId
forall a b. (a -> b) -> a -> b
$
Name -> OutType -> InId
mkLocalIdOrCoVar Name
poly_name OutType
poly_ty
; (InId, InExpr) -> SimplM (InId, InExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (InId
poly_id, InExpr -> [OutType] -> InExpr
forall b. Expr b -> [OutType] -> Expr b
mkTyApps (InId -> InExpr
forall b. InId -> Expr b
Var InId
poly_id) ([InId] -> [OutType]
mkTyVarTys [InId]
tvs_here)) }
mk_poly2 :: Id -> [TyVar] -> CoreExpr -> (Id, CoreExpr)
mk_poly2 :: InId -> [InId] -> InExpr -> (InId, InExpr)
mk_poly2 InId
poly_id [InId]
tvs_here InExpr
rhs
= (InId
poly_id InId -> Unfolding -> InId
`setIdUnfolding` Unfolding
unf, InExpr
poly_rhs)
where
poly_rhs :: InExpr
poly_rhs = [InId] -> InExpr -> InExpr
forall b. [b] -> Expr b -> Expr b
mkLams [InId]
tvs_here InExpr
rhs
unf :: Unfolding
unf = DynFlags -> UnfoldingSource -> Bool -> Bool -> InExpr -> Unfolding
mkUnfolding DynFlags
dflags UnfoldingSource
InlineRhs Bool
is_top_lvl Bool
False InExpr
poly_rhs
prepareAlts :: OutExpr -> OutId -> [InAlt] -> SimplM ([AltCon], [InAlt])
prepareAlts :: InExpr -> InId -> [InAlt] -> SimplM ([AltCon], [InAlt])
prepareAlts InExpr
scrut InId
case_bndr' [InAlt]
alts
| Just (TyCon
tc, [OutType]
tys) <- HasDebugCallStack => OutType -> Maybe (TyCon, [OutType])
OutType -> Maybe (TyCon, [OutType])
splitTyConApp_maybe (InId -> OutType
varType InId
case_bndr')
= do { [Unique]
us <- SimplM [Unique]
forall (m :: * -> *). MonadUnique m => m [Unique]
getUniquesM
; let ([AltCon]
idcs1, [InAlt]
alts1) = TyCon -> [OutType] -> [AltCon] -> [InAlt] -> ([AltCon], [InAlt])
forall a.
TyCon
-> [OutType]
-> [AltCon]
-> [(AltCon, [InId], a)]
-> ([AltCon], [(AltCon, [InId], a)])
filterAlts TyCon
tc [OutType]
tys [AltCon]
imposs_cons [InAlt]
alts
(Bool
yes2, [InAlt]
alts2) = [Unique]
-> TyCon -> [OutType] -> [AltCon] -> [InAlt] -> (Bool, [InAlt])
refineDefaultAlt [Unique]
us TyCon
tc [OutType]
tys [AltCon]
idcs1 [InAlt]
alts1
(Bool
yes3, [AltCon]
idcs3, [InAlt]
alts3) = [AltCon] -> [InAlt] -> (Bool, [AltCon], [InAlt])
combineIdenticalAlts [AltCon]
idcs1 [InAlt]
alts2
; Bool -> SimplM () -> SimplM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
yes2 (SimplM () -> SimplM ()) -> SimplM () -> SimplM ()
forall a b. (a -> b) -> a -> b
$ Tick -> SimplM ()
tick (InId -> Tick
FillInCaseDefault InId
case_bndr')
; Bool -> SimplM () -> SimplM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
yes3 (SimplM () -> SimplM ()) -> SimplM () -> SimplM ()
forall a b. (a -> b) -> a -> b
$ Tick -> SimplM ()
tick (InId -> Tick
AltMerge InId
case_bndr')
; ([AltCon], [InAlt]) -> SimplM ([AltCon], [InAlt])
forall (m :: * -> *) a. Monad m => a -> m a
return ([AltCon]
idcs3, [InAlt]
alts3) }
| Bool
otherwise
= ([AltCon], [InAlt]) -> SimplM ([AltCon], [InAlt])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [InAlt]
alts)
where
imposs_cons :: [AltCon]
imposs_cons = case InExpr
scrut of
Var InId
v -> Unfolding -> [AltCon]
otherCons (InId -> Unfolding
idUnfolding InId
v)
InExpr
_ -> []
mkCase, mkCase1, mkCase2, mkCase3
:: DynFlags
-> OutExpr -> OutId
-> OutType -> [OutAlt]
-> SimplM OutExpr
mkCase :: DynFlags -> InExpr -> InId -> OutType -> [InAlt] -> SimplM InExpr
mkCase DynFlags
dflags InExpr
scrut InId
outer_bndr OutType
alts_ty ((AltCon
DEFAULT, [InId]
_, InExpr
deflt_rhs) : [InAlt]
outer_alts)
| GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_CaseMerge DynFlags
dflags
, ([Tickish InId]
ticks, Case (Var InId
inner_scrut_var) InId
inner_bndr OutType
_ [InAlt]
inner_alts)
<- (Tickish InId -> Bool) -> InExpr -> ([Tickish InId], InExpr)
forall b.
(Tickish InId -> Bool) -> Expr b -> ([Tickish InId], Expr b)
stripTicksTop Tickish InId -> Bool
forall id. Tickish id -> Bool
tickishFloatable InExpr
deflt_rhs
, InId
inner_scrut_var InId -> InId -> Bool
forall a. Eq a => a -> a -> Bool
== InId
outer_bndr
= do { Tick -> SimplM ()
tick (InId -> Tick
CaseMerge InId
outer_bndr)
; let wrap_alt :: (a, t InId, InExpr) -> (a, t InId, InExpr)
wrap_alt (a
con, t InId
args, InExpr
rhs) = ASSERT( outer_bndr `notElem` args )
(a
con, t InId
args, InExpr -> InExpr
wrap_rhs InExpr
rhs)
wrap_rhs :: InExpr -> InExpr
wrap_rhs InExpr
rhs = Bind InId -> InExpr -> InExpr
forall b. Bind b -> Expr b -> Expr b
Let (InId -> InExpr -> Bind InId
forall b. b -> Expr b -> Bind b
NonRec InId
inner_bndr (InId -> InExpr
forall b. InId -> Expr b
Var InId
outer_bndr)) InExpr
rhs
wrapped_alts :: [InAlt]
wrapped_alts | InId -> Bool
isDeadBinder InId
inner_bndr = [InAlt]
inner_alts
| Bool
otherwise = (InAlt -> InAlt) -> [InAlt] -> [InAlt]
forall a b. (a -> b) -> [a] -> [b]
map InAlt -> InAlt
forall (t :: * -> *) a.
Foldable t =>
(a, t InId, InExpr) -> (a, t InId, InExpr)
wrap_alt [InAlt]
inner_alts
merged_alts :: [InAlt]
merged_alts = [InAlt] -> [InAlt] -> [InAlt]
forall a b.
[(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)]
mergeAlts [InAlt]
outer_alts [InAlt]
wrapped_alts
; (InExpr -> InExpr) -> SimplM InExpr -> SimplM InExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Tickish InId] -> InExpr -> InExpr
mkTicks [Tickish InId]
ticks) (SimplM InExpr -> SimplM InExpr) -> SimplM InExpr -> SimplM InExpr
forall a b. (a -> b) -> a -> b
$
DynFlags -> InExpr -> InId -> OutType -> [InAlt] -> SimplM InExpr
mkCase1 DynFlags
dflags InExpr
scrut InId
outer_bndr OutType
alts_ty [InAlt]
merged_alts
}
mkCase DynFlags
dflags InExpr
scrut InId
bndr OutType
alts_ty [InAlt]
alts = DynFlags -> InExpr -> InId -> OutType -> [InAlt] -> SimplM InExpr
mkCase1 DynFlags
dflags InExpr
scrut InId
bndr OutType
alts_ty [InAlt]
alts
mkCase1 :: DynFlags -> InExpr -> InId -> OutType -> [InAlt] -> SimplM InExpr
mkCase1 DynFlags
_dflags InExpr
scrut InId
case_bndr OutType
_ alts :: [InAlt]
alts@((AltCon
_,[InId]
_,InExpr
rhs1) : [InAlt]
_)
| (InAlt -> Bool) -> [InAlt] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all InAlt -> Bool
forall b. (AltCon, [InId], Expr b) -> Bool
identity_alt [InAlt]
alts
= do { Tick -> SimplM ()
tick (InId -> Tick
CaseIdentity InId
case_bndr)
; InExpr -> SimplM InExpr
forall (m :: * -> *) a. Monad m => a -> m a
return ([Tickish InId] -> InExpr -> InExpr
mkTicks [Tickish InId]
ticks (InExpr -> InExpr) -> InExpr -> InExpr
forall a b. (a -> b) -> a -> b
$ InExpr -> InExpr -> InExpr
forall b b. Expr b -> Expr b -> Expr b
re_cast InExpr
scrut InExpr
rhs1) }
where
ticks :: [Tickish InId]
ticks = (InAlt -> [Tickish InId]) -> [InAlt] -> [Tickish InId]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Tickish InId -> Bool) -> InExpr -> [Tickish InId]
forall b. (Tickish InId -> Bool) -> Expr b -> [Tickish InId]
stripTicksT Tickish InId -> Bool
forall id. Tickish id -> Bool
tickishFloatable (InExpr -> [Tickish InId])
-> (InAlt -> InExpr) -> InAlt -> [Tickish InId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InAlt -> InExpr
forall a b c. (a, b, c) -> c
thdOf3) ([InAlt] -> [InAlt]
forall a. [a] -> [a]
tail [InAlt]
alts)
identity_alt :: (AltCon, [InId], Expr b) -> Bool
identity_alt (AltCon
con, [InId]
args, Expr b
rhs) = Expr b -> AltCon -> [InId] -> Bool
forall b. Expr b -> AltCon -> [InId] -> Bool
check_eq Expr b
rhs AltCon
con [InId]
args
check_eq :: Expr b -> AltCon -> [InId] -> Bool
check_eq (Cast Expr b
rhs OutCoercion
co) AltCon
con [InId]
args
= Bool -> Bool
not ((InId -> Bool) -> [InId] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (InId -> TyCoVarSet -> Bool
`elemVarSet` OutCoercion -> TyCoVarSet
tyCoVarsOfCo OutCoercion
co) [InId]
args) Bool -> Bool -> Bool
&& Expr b -> AltCon -> [InId] -> Bool
check_eq Expr b
rhs AltCon
con [InId]
args
check_eq (Tick Tickish InId
t Expr b
e) AltCon
alt [InId]
args
= Tickish InId -> Bool
forall id. Tickish id -> Bool
tickishFloatable Tickish InId
t Bool -> Bool -> Bool
&& Expr b -> AltCon -> [InId] -> Bool
check_eq Expr b
e AltCon
alt [InId]
args
check_eq (Lit Literal
lit) (LitAlt Literal
lit') [InId]
_ = Literal
lit Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== Literal
lit'
check_eq (Var InId
v) AltCon
_ [InId]
_ | InId
v InId -> InId -> Bool
forall a. Eq a => a -> a -> Bool
== InId
case_bndr = Bool
True
check_eq (Var InId
v) (DataAlt DataCon
con) [InId]
args
| [OutType] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [OutType]
arg_tys, [InId] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InId]
args = InId
v InId -> InId -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon -> InId
dataConWorkId DataCon
con
check_eq Expr b
rhs (DataAlt DataCon
con) [InId]
args = (Tickish InId -> Bool) -> Expr b -> Expr b -> Bool
forall b. (Tickish InId -> Bool) -> Expr b -> Expr b -> Bool
cheapEqExpr' Tickish InId -> Bool
forall id. Tickish id -> Bool
tickishFloatable Expr b
rhs (Expr b -> Bool) -> Expr b -> Bool
forall a b. (a -> b) -> a -> b
$
DataCon -> [OutType] -> [InId] -> Expr b
forall b. DataCon -> [OutType] -> [InId] -> Expr b
mkConApp2 DataCon
con [OutType]
arg_tys [InId]
args
check_eq Expr b
_ AltCon
_ [InId]
_ = Bool
False
arg_tys :: [OutType]
arg_tys = OutType -> [OutType]
tyConAppArgs (InId -> OutType
idType InId
case_bndr)
re_cast :: Expr b -> Expr b -> Expr b
re_cast Expr b
scrut (Cast Expr b
rhs OutCoercion
co) = Expr b -> OutCoercion -> Expr b
forall b. Expr b -> OutCoercion -> Expr b
Cast (Expr b -> Expr b -> Expr b
re_cast Expr b
scrut Expr b
rhs) OutCoercion
co
re_cast Expr b
scrut Expr b
_ = Expr b
scrut
mkCase1 DynFlags
dflags InExpr
scrut InId
bndr OutType
alts_ty [InAlt]
alts = DynFlags -> InExpr -> InId -> OutType -> [InAlt] -> SimplM InExpr
mkCase2 DynFlags
dflags InExpr
scrut InId
bndr OutType
alts_ty [InAlt]
alts
mkCase2 :: DynFlags -> InExpr -> InId -> OutType -> [InAlt] -> SimplM InExpr
mkCase2 DynFlags
dflags InExpr
scrut InId
bndr OutType
alts_ty [InAlt]
alts
|
case [InAlt]
alts of
[(AltCon
DEFAULT,[InId]
_,InExpr
_)] -> Bool
False
[InAlt]
_ -> Bool
True
, GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_CaseFolding DynFlags
dflags
, Just (InExpr
scrut', AltCon -> Maybe AltCon
tx_con, InId -> InExpr
mk_orig) <- DynFlags
-> InExpr -> Maybe (InExpr, AltCon -> Maybe AltCon, InId -> InExpr)
caseRules DynFlags
dflags InExpr
scrut
= do { InId
bndr' <- FastString -> OutType -> SimplM InId
newId (String -> FastString
fsLit String
"lwild") (InExpr -> OutType
exprType InExpr
scrut')
; [InAlt]
alts' <- (InAlt -> SimplM (Maybe InAlt)) -> [InAlt] -> SimplM [InAlt]
forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM ((AltCon -> Maybe AltCon)
-> (InId -> InExpr) -> InId -> InAlt -> SimplM (Maybe InAlt)
tx_alt AltCon -> Maybe AltCon
tx_con InId -> InExpr
mk_orig InId
bndr') [InAlt]
alts
; DynFlags -> InExpr -> InId -> OutType -> [InAlt] -> SimplM InExpr
mkCase3 DynFlags
dflags InExpr
scrut' InId
bndr' OutType
alts_ty ([InAlt] -> SimplM InExpr) -> [InAlt] -> SimplM InExpr
forall a b. (a -> b) -> a -> b
$
[InAlt] -> [InAlt]
add_default ([InAlt] -> [InAlt]
re_sort [InAlt]
alts')
}
| Bool
otherwise
= DynFlags -> InExpr -> InId -> OutType -> [InAlt] -> SimplM InExpr
mkCase3 DynFlags
dflags InExpr
scrut InId
bndr OutType
alts_ty [InAlt]
alts
where
tx_alt :: (AltCon -> Maybe AltCon) -> (Id -> CoreExpr) -> Id
-> CoreAlt -> SimplM (Maybe CoreAlt)
tx_alt :: (AltCon -> Maybe AltCon)
-> (InId -> InExpr) -> InId -> InAlt -> SimplM (Maybe InAlt)
tx_alt AltCon -> Maybe AltCon
tx_con InId -> InExpr
mk_orig InId
new_bndr (AltCon
con, [InId]
bs, InExpr
rhs)
= case AltCon -> Maybe AltCon
tx_con AltCon
con of
Maybe AltCon
Nothing -> Maybe InAlt -> SimplM (Maybe InAlt)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe InAlt
forall a. Maybe a
Nothing
Just AltCon
con' -> do { [InId]
bs' <- InId -> AltCon -> SimplM [InId]
forall (m :: * -> *). MonadUnique m => InId -> AltCon -> m [InId]
mk_new_bndrs InId
new_bndr AltCon
con'
; Maybe InAlt -> SimplM (Maybe InAlt)
forall (m :: * -> *) a. Monad m => a -> m a
return (InAlt -> Maybe InAlt
forall a. a -> Maybe a
Just (AltCon
con', [InId]
bs', InExpr
rhs')) }
where
rhs' :: InExpr
rhs' | InId -> Bool
isDeadBinder InId
bndr = InExpr
rhs
| Bool
otherwise = InId -> InExpr -> InExpr -> InExpr
bindNonRec InId
bndr InExpr
orig_val InExpr
rhs
orig_val :: InExpr
orig_val = case AltCon
con of
AltCon
DEFAULT -> InId -> InExpr
mk_orig InId
new_bndr
LitAlt Literal
l -> Literal -> InExpr
forall b. Literal -> Expr b
Lit Literal
l
DataAlt DataCon
dc -> DataCon -> [OutType] -> [InId] -> InExpr
forall b. DataCon -> [OutType] -> [InId] -> Expr b
mkConApp2 DataCon
dc (OutType -> [OutType]
tyConAppArgs (InId -> OutType
idType InId
bndr)) [InId]
bs
mk_new_bndrs :: InId -> AltCon -> m [InId]
mk_new_bndrs InId
new_bndr (DataAlt DataCon
dc)
| Bool -> Bool
not (DataCon -> Bool
isNullaryRepDataCon DataCon
dc)
=
do { [Unique]
us <- m [Unique]
forall (m :: * -> *). MonadUnique m => m [Unique]
getUniquesM
; let ([InId]
ex_tvs, [InId]
arg_ids) = [Unique] -> DataCon -> [OutType] -> ([InId], [InId])
dataConRepInstPat [Unique]
us DataCon
dc
(OutType -> [OutType]
tyConAppArgs (InId -> OutType
idType InId
new_bndr))
; [InId] -> m [InId]
forall (m :: * -> *) a. Monad m => a -> m a
return ([InId]
ex_tvs [InId] -> [InId] -> [InId]
forall a. [a] -> [a] -> [a]
++ [InId]
arg_ids) }
mk_new_bndrs InId
_ AltCon
_ = [InId] -> m [InId]
forall (m :: * -> *) a. Monad m => a -> m a
return []
re_sort :: [CoreAlt] -> [CoreAlt]
re_sort :: [InAlt] -> [InAlt]
re_sort [InAlt]
alts = (InAlt -> InAlt -> Ordering) -> [InAlt] -> [InAlt]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy InAlt -> InAlt -> Ordering
forall a b. (AltCon, a, b) -> (AltCon, a, b) -> Ordering
cmpAlt [InAlt]
alts
add_default :: [CoreAlt] -> [CoreAlt]
add_default :: [InAlt] -> [InAlt]
add_default ((LitAlt {}, [InId]
bs, InExpr
rhs) : [InAlt]
alts) = (AltCon
DEFAULT, [InId]
bs, InExpr
rhs) InAlt -> [InAlt] -> [InAlt]
forall a. a -> [a] -> [a]
: [InAlt]
alts
add_default [InAlt]
alts = [InAlt]
alts
mkCase3 :: DynFlags -> InExpr -> InId -> OutType -> [InAlt] -> SimplM InExpr
mkCase3 DynFlags
_dflags InExpr
scrut InId
bndr OutType
alts_ty [InAlt]
alts
= InExpr -> SimplM InExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (InExpr -> InId -> OutType -> [InAlt] -> InExpr
forall b. Expr b -> b -> OutType -> [Alt b] -> Expr b
Case InExpr
scrut InId
bndr OutType
alts_ty [InAlt]
alts)
isExitJoinId :: Var -> Bool
isExitJoinId :: InId -> Bool
isExitJoinId InId
id = InId -> Bool
isJoinId InId
id Bool -> Bool -> Bool
&& OccInfo -> Bool
isOneOcc (InId -> OccInfo
idOccInfo InId
id) Bool -> Bool -> Bool
&& OccInfo -> Bool
occ_in_lam (InId -> OccInfo
idOccInfo InId
id)