{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiWayIf #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates -Wno-incomplete-uni-patterns #-}
module GHC.Core.Opt.Simplify ( simplTopBinds, simplExpr, simplImpRules ) where
import GHC.Prelude
import GHC.Platform
import GHC.Driver.Session
import GHC.Core
import GHC.Core.Opt.Simplify.Monad
import GHC.Core.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst )
import GHC.Core.Opt.Simplify.Env
import GHC.Core.Opt.Simplify.Utils
import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs )
import GHC.Core.Make ( FloatBind, mkImpossibleExpr, castBottomExpr )
import qualified GHC.Core.Make
import GHC.Core.Coercion hiding ( substCo, substCoVar )
import GHC.Core.Reduction
import GHC.Core.Coercion.Opt ( optCoercion )
import GHC.Core.FamInstEnv ( FamInstEnv, topNormaliseType_maybe )
import GHC.Core.DataCon
( DataCon, dataConWorkId, dataConRepStrictness
, dataConRepArgTys, isUnboxedTupleDataCon
, StrictnessMark (..) )
import GHC.Core.Opt.Monad ( Tick(..), SimplMode(..) )
import GHC.Core.Ppr ( pprCoreExpr )
import GHC.Core.Unfold
import GHC.Core.Unfold.Make
import GHC.Core.Utils
import GHC.Core.Opt.Arity ( ArityType(..)
, pushCoTyArg, pushCoValArg
, etaExpandAT )
import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe )
import GHC.Core.FVs ( mkRuleInfo )
import GHC.Core.Rules ( lookupRule, getRules, initRuleOpts )
import GHC.Core.Multiplicity
import GHC.Types.Literal ( litIsLifted )
import GHC.Types.SourceText
import GHC.Types.Id
import GHC.Types.Id.Make ( seqId )
import GHC.Types.Id.Info
import GHC.Types.Name ( mkSystemVarName, isExternalName, getOccFS )
import GHC.Types.Demand
import GHC.Types.Cpr ( mkCprSig, botCpr )
import GHC.Types.Unique ( hasKey )
import GHC.Types.Basic
import GHC.Types.Tickish
import GHC.Types.Var ( isTyCoVar )
import GHC.Builtin.PrimOps ( PrimOp (SeqOp) )
import GHC.Builtin.Types.Prim( realWorldStatePrimTy )
import GHC.Builtin.Names( runRWKey )
import GHC.Data.Maybe ( isNothing, orElse )
import GHC.Data.FastString
import GHC.Unit.Module ( moduleName, pprModuleName )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Trace
import GHC.Utils.Monad ( mapAccumLM, liftIO )
import GHC.Utils.Logger
import GHC.Utils.Misc
import Control.Monad
simplTopBinds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv)
simplTopBinds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv)
simplTopBinds SimplEnv
env0 [InBind]
binds0
= do {
; !SimplEnv
env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} SimplEnv -> [InBndr] -> SimplM SimplEnv
simplRecBndrs SimplEnv
env0 ([InBind] -> [InBndr]
forall b. [Bind b] -> [b]
bindersOfBinds [InBind]
binds0)
; (SimplFloats
floats, SimplEnv
env2) <- {-#SCC "simplTopBinds-simpl_binds" #-} SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv)
simpl_binds SimplEnv
env1 [InBind]
binds0
; Tick -> SimplM ()
freeTick Tick
SimplifierDone
; (SimplFloats, SimplEnv) -> SimplM (SimplFloats, SimplEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplFloats
floats, SimplEnv
env2) }
where
simpl_binds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv)
simpl_binds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv)
simpl_binds SimplEnv
env [] = (SimplFloats, SimplEnv) -> SimplM (SimplFloats, SimplEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplEnv -> SimplFloats
emptyFloats SimplEnv
env, SimplEnv
env)
simpl_binds SimplEnv
env (InBind
bind:[InBind]
binds) = do { (SimplFloats
float, SimplEnv
env1) <- SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv)
simpl_bind SimplEnv
env InBind
bind
; (SimplFloats
floats, SimplEnv
env2) <- SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv)
simpl_binds SimplEnv
env1 [InBind]
binds
; let !floats1 :: SimplFloats
floats1 = SimplFloats
float SimplFloats -> SimplFloats -> SimplFloats
`addFloats` SimplFloats
floats
; (SimplFloats, SimplEnv) -> SimplM (SimplFloats, SimplEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplFloats
floats1, SimplEnv
env2) }
simpl_bind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv)
simpl_bind SimplEnv
env (Rec [(InBndr, Expr InBndr)]
pairs)
= SimplEnv
-> BindContext
-> [(InBndr, Expr InBndr)]
-> SimplM (SimplFloats, SimplEnv)
simplRecBind SimplEnv
env (TopLevelFlag -> RecFlag -> BindContext
BC_Let TopLevelFlag
TopLevel RecFlag
Recursive) [(InBndr, Expr InBndr)]
pairs
simpl_bind SimplEnv
env (NonRec InBndr
b Expr InBndr
r)
= do { let bind_cxt :: BindContext
bind_cxt = TopLevelFlag -> RecFlag -> BindContext
BC_Let TopLevelFlag
TopLevel RecFlag
NonRecursive
; (SimplEnv
env', InBndr
b') <- SimplEnv
-> InBndr -> InBndr -> BindContext -> SimplM (SimplEnv, InBndr)
addBndrRules SimplEnv
env InBndr
b (SimplEnv -> InBndr -> InBndr
lookupRecBndr SimplEnv
env InBndr
b) BindContext
bind_cxt
; SimplEnv
-> BindContext
-> InBndr
-> InBndr
-> Expr InBndr
-> SimplM (SimplFloats, SimplEnv)
simplRecOrTopPair SimplEnv
env' BindContext
bind_cxt InBndr
b InBndr
b' Expr InBndr
r }
simplRecBind :: SimplEnv -> BindContext
-> [(InId, InExpr)]
-> SimplM (SimplFloats, SimplEnv)
simplRecBind :: SimplEnv
-> BindContext
-> [(InBndr, Expr InBndr)]
-> SimplM (SimplFloats, SimplEnv)
simplRecBind SimplEnv
env0 BindContext
bind_cxt [(InBndr, Expr InBndr)]
pairs0
= do { (SimplEnv
env_with_info, [(InBndr, InBndr, Expr InBndr)]
triples) <- (SimplEnv
-> (InBndr, Expr InBndr)
-> SimplM (SimplEnv, (InBndr, InBndr, Expr InBndr)))
-> SimplEnv
-> [(InBndr, Expr InBndr)]
-> SimplM (SimplEnv, [(InBndr, InBndr, Expr InBndr)])
forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM SimplEnv
-> (InBndr, Expr InBndr)
-> SimplM (SimplEnv, (InBndr, InBndr, Expr InBndr))
add_rules SimplEnv
env0 [(InBndr, Expr InBndr)]
pairs0
; (SimplFloats
rec_floats, SimplEnv
env1) <- SimplEnv
-> [(InBndr, InBndr, Expr InBndr)]
-> SimplM (SimplFloats, SimplEnv)
go SimplEnv
env_with_info [(InBndr, InBndr, Expr InBndr)]
triples
; (SimplFloats, SimplEnv) -> SimplM (SimplFloats, SimplEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplFloats -> SimplFloats
mkRecFloats SimplFloats
rec_floats, SimplEnv
env1) }
where
add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr))
add_rules :: SimplEnv
-> (InBndr, Expr InBndr)
-> SimplM (SimplEnv, (InBndr, InBndr, Expr InBndr))
add_rules SimplEnv
env (InBndr
bndr, Expr InBndr
rhs)
= do { (SimplEnv
env', InBndr
bndr') <- SimplEnv
-> InBndr -> InBndr -> BindContext -> SimplM (SimplEnv, InBndr)
addBndrRules SimplEnv
env InBndr
bndr (SimplEnv -> InBndr -> InBndr
lookupRecBndr SimplEnv
env InBndr
bndr) BindContext
bind_cxt
; (SimplEnv, (InBndr, InBndr, Expr InBndr))
-> SimplM (SimplEnv, (InBndr, InBndr, Expr InBndr))
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplEnv
env', (InBndr
bndr, InBndr
bndr', Expr InBndr
rhs)) }
go :: SimplEnv
-> [(InBndr, InBndr, Expr InBndr)]
-> SimplM (SimplFloats, SimplEnv)
go SimplEnv
env [] = (SimplFloats, SimplEnv) -> SimplM (SimplFloats, SimplEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplEnv -> SimplFloats
emptyFloats SimplEnv
env, SimplEnv
env)
go SimplEnv
env ((InBndr
old_bndr, InBndr
new_bndr, Expr InBndr
rhs) : [(InBndr, InBndr, Expr InBndr)]
pairs)
= do { (SimplFloats
float, SimplEnv
env1) <- SimplEnv
-> BindContext
-> InBndr
-> InBndr
-> Expr InBndr
-> SimplM (SimplFloats, SimplEnv)
simplRecOrTopPair SimplEnv
env BindContext
bind_cxt
InBndr
old_bndr InBndr
new_bndr Expr InBndr
rhs
; (SimplFloats
floats, SimplEnv
env2) <- SimplEnv
-> [(InBndr, InBndr, Expr InBndr)]
-> SimplM (SimplFloats, SimplEnv)
go SimplEnv
env1 [(InBndr, InBndr, Expr InBndr)]
pairs
; (SimplFloats, SimplEnv) -> SimplM (SimplFloats, SimplEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplFloats
float SimplFloats -> SimplFloats -> SimplFloats
`addFloats` SimplFloats
floats, SimplEnv
env2) }
simplRecOrTopPair :: SimplEnv
-> BindContext
-> InId -> OutBndr -> InExpr
-> SimplM (SimplFloats, SimplEnv)
simplRecOrTopPair :: SimplEnv
-> BindContext
-> InBndr
-> InBndr
-> Expr InBndr
-> SimplM (SimplFloats, SimplEnv)
simplRecOrTopPair SimplEnv
env BindContext
bind_cxt InBndr
old_bndr InBndr
new_bndr Expr InBndr
rhs
| Just SimplEnv
env' <- SimplEnv
-> TopLevelFlag
-> InBndr
-> Expr InBndr
-> SimplEnv
-> Maybe SimplEnv
preInlineUnconditionally SimplEnv
env (BindContext -> TopLevelFlag
bindContextLevel BindContext
bind_cxt)
InBndr
old_bndr Expr InBndr
rhs SimplEnv
env
= {-#SCC "simplRecOrTopPair-pre-inline-uncond" #-}
SimplEnv
-> String
-> SDoc
-> SimplM (SimplFloats, SimplEnv)
-> SimplM (SimplFloats, SimplEnv)
forall a. SimplEnv -> String -> SDoc -> a -> a
simplTrace SimplEnv
env String
"SimplBindr:inline-uncond" (InBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr InBndr
old_bndr) (SimplM (SimplFloats, SimplEnv) -> SimplM (SimplFloats, SimplEnv))
-> SimplM (SimplFloats, SimplEnv) -> SimplM (SimplFloats, SimplEnv)
forall a b. (a -> b) -> a -> b
$
do { Tick -> SimplM ()
tick (InBndr -> Tick
PreInlineUnconditionally InBndr
old_bndr)
; (SimplFloats, SimplEnv) -> SimplM (SimplFloats, SimplEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return ( SimplEnv -> SimplFloats
emptyFloats SimplEnv
env, SimplEnv
env' ) }
| Bool
otherwise
= case BindContext
bind_cxt of
BC_Join SimplCont
cont -> SimplEnv
-> String
-> SDoc
-> SimplM (SimplFloats, SimplEnv)
-> SimplM (SimplFloats, SimplEnv)
forall a. SimplEnv -> String -> SDoc -> a -> a
simplTrace SimplEnv
env String
"SimplBind:join" (InBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr InBndr
old_bndr) (SimplM (SimplFloats, SimplEnv) -> SimplM (SimplFloats, SimplEnv))
-> SimplM (SimplFloats, SimplEnv) -> SimplM (SimplFloats, SimplEnv)
forall a b. (a -> b) -> a -> b
$
SimplEnv
-> SimplCont
-> InBndr
-> InBndr
-> Expr InBndr
-> SimplEnv
-> SimplM (SimplFloats, SimplEnv)
simplJoinBind SimplEnv
env SimplCont
cont InBndr
old_bndr InBndr
new_bndr Expr InBndr
rhs SimplEnv
env
BC_Let TopLevelFlag
top_lvl RecFlag
is_rec -> SimplEnv
-> String
-> SDoc
-> SimplM (SimplFloats, SimplEnv)
-> SimplM (SimplFloats, SimplEnv)
forall a. SimplEnv -> String -> SDoc -> a -> a
simplTrace SimplEnv
env String
"SimplBind:normal" (InBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr InBndr
old_bndr) (SimplM (SimplFloats, SimplEnv) -> SimplM (SimplFloats, SimplEnv))
-> SimplM (SimplFloats, SimplEnv) -> SimplM (SimplFloats, SimplEnv)
forall a b. (a -> b) -> a -> b
$
SimplEnv
-> TopLevelFlag
-> RecFlag
-> InBndr
-> InBndr
-> Expr InBndr
-> SimplEnv
-> SimplM (SimplFloats, SimplEnv)
simplLazyBind SimplEnv
env TopLevelFlag
top_lvl RecFlag
is_rec InBndr
old_bndr InBndr
new_bndr Expr InBndr
rhs SimplEnv
env
simplTrace :: SimplEnv -> String -> SDoc -> a -> a
simplTrace :: SimplEnv -> String -> SDoc -> a -> a
simplTrace SimplEnv
env String
herald SDoc
doc a
thing_inside
| Bool -> Bool
not (Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_verbose_core2core)
= a
thing_inside
| Bool
otherwise
= Logger -> String -> SDoc -> a -> a
forall a. Logger -> String -> SDoc -> a -> a
logTraceMsg Logger
logger String
herald SDoc
doc a
thing_inside
where
logger :: Logger
logger = SimplEnv -> Logger
seLogger SimplEnv
env
simplLazyBind :: SimplEnv
-> TopLevelFlag -> RecFlag
-> InId -> OutId
-> InExpr -> SimplEnv
-> SimplM (SimplFloats, SimplEnv)
simplLazyBind :: SimplEnv
-> TopLevelFlag
-> RecFlag
-> InBndr
-> InBndr
-> Expr InBndr
-> SimplEnv
-> SimplM (SimplFloats, SimplEnv)
simplLazyBind SimplEnv
env TopLevelFlag
top_lvl RecFlag
is_rec InBndr
bndr InBndr
bndr1 Expr InBndr
rhs SimplEnv
rhs_se
= Bool
-> (Bool
-> SDoc
-> SimplM (SimplFloats, SimplEnv)
-> SimplM (SimplFloats, SimplEnv))
-> Bool
-> SDoc
-> SimplM (SimplFloats, SimplEnv)
-> SimplM (SimplFloats, SimplEnv)
forall a. HasCallStack => Bool -> a -> a
assert (InBndr -> Bool
isId InBndr
bndr )
Bool
-> SDoc
-> SimplM (SimplFloats, SimplEnv)
-> SimplM (SimplFloats, SimplEnv)
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Bool -> Bool
not (InBndr -> Bool
isJoinId InBndr
bndr)) (InBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr InBndr
bndr) (SimplM (SimplFloats, SimplEnv) -> SimplM (SimplFloats, SimplEnv))
-> SimplM (SimplFloats, SimplEnv) -> SimplM (SimplFloats, SimplEnv)
forall a b. (a -> b) -> a -> b
$
do { let !rhs_env :: SimplEnv
rhs_env = SimplEnv
rhs_se SimplEnv -> SimplEnv -> SimplEnv
`setInScopeFromE` SimplEnv
env
([InBndr]
tvs, Expr InBndr
body) = case Expr InBndr -> ([InBndr], [InBndr], Expr InBndr)
collectTyAndValBinders Expr InBndr
rhs of
([InBndr]
tvs, [], Expr InBndr
body)
| Expr InBndr -> Bool
forall b. Expr b -> Bool
surely_not_lam Expr InBndr
body -> ([InBndr]
tvs, Expr InBndr
body)
([InBndr], [InBndr], Expr InBndr)
_ -> ([], Expr InBndr
rhs)
surely_not_lam :: Expr b -> Bool
surely_not_lam (Lam {}) = Bool
False
surely_not_lam (Tick CoreTickish
t Expr b
e)
| Bool -> Bool
not (CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable CoreTickish
t) = Expr b -> Bool
surely_not_lam Expr b
e
surely_not_lam Expr b
_ = Bool
True
; (SimplEnv
body_env, [InBndr]
tvs') <- {-#SCC "simplBinders" #-} SimplEnv -> [InBndr] -> SimplM (SimplEnv, [InBndr])
simplBinders SimplEnv
rhs_env [InBndr]
tvs
; let rhs_cont :: SimplCont
rhs_cont = OutType -> Demand -> SimplCont
mkRhsStop (SimplEnv -> OutType -> OutType
substTy SimplEnv
body_env (HasDebugCallStack => Expr InBndr -> OutType
Expr InBndr -> OutType
exprType Expr InBndr
body)) (InBndr -> Demand
idDemandInfo InBndr
bndr)
; (SimplFloats
body_floats0, Expr InBndr
body0) <- {-#SCC "simplExprF" #-} SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplExprF SimplEnv
body_env Expr InBndr
body SimplCont
rhs_cont
; (SimplFloats
body_floats2, Expr InBndr
body2) <- {-#SCC "prepareBinding" #-}
SimplEnv
-> TopLevelFlag
-> RecFlag
-> Bool
-> InBndr
-> SimplFloats
-> Expr InBndr
-> SimplM (SimplFloats, Expr InBndr)
prepareBinding SimplEnv
env TopLevelFlag
top_lvl RecFlag
is_rec
Bool
False
InBndr
bndr1 SimplFloats
body_floats0 Expr InBndr
body0
; (SimplFloats
rhs_floats, Expr InBndr
body3)
<- if SimplFloats -> Bool
isEmptyFloats SimplFloats
body_floats2 Bool -> Bool -> Bool
|| [InBndr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InBndr]
tvs then
{-#SCC "simplLazyBind-simple-floating" #-}
(SimplFloats, Expr InBndr) -> SimplM (SimplFloats, Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplFloats
body_floats2, Expr InBndr
body2)
else
{-#SCC "simplLazyBind-type-abstraction-first" #-}
do { ([InBind]
poly_binds, Expr InBndr
body3) <- UnfoldingOpts
-> TopLevelFlag
-> [InBndr]
-> SimplFloats
-> Expr InBndr
-> SimplM ([InBind], Expr InBndr)
abstractFloats (SimplEnv -> UnfoldingOpts
seUnfoldingOpts SimplEnv
env) TopLevelFlag
top_lvl
[InBndr]
tvs' SimplFloats
body_floats2 Expr InBndr
body2
; let floats :: SimplFloats
floats = (SimplFloats -> InBind -> SimplFloats)
-> SimplFloats -> [InBind] -> SimplFloats
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' SimplFloats -> InBind -> SimplFloats
extendFloats (SimplEnv -> SimplFloats
emptyFloats SimplEnv
env) [InBind]
poly_binds
; (SimplFloats, Expr InBndr) -> SimplM (SimplFloats, Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplFloats
floats, Expr InBndr
body3) }
; let env' :: SimplEnv
env' = SimplEnv
env SimplEnv -> SimplFloats -> SimplEnv
`setInScopeFromF` SimplFloats
rhs_floats
; Expr InBndr
rhs' <- SimplEnv
-> [InBndr] -> Expr InBndr -> SimplCont -> SimplM (Expr InBndr)
mkLam SimplEnv
env' [InBndr]
tvs' Expr InBndr
body3 SimplCont
rhs_cont
; (SimplFloats
bind_float, SimplEnv
env2) <- SimplEnv
-> BindContext
-> InBndr
-> InBndr
-> Expr InBndr
-> SimplM (SimplFloats, SimplEnv)
completeBind SimplEnv
env' (TopLevelFlag -> RecFlag -> BindContext
BC_Let TopLevelFlag
top_lvl RecFlag
is_rec) InBndr
bndr InBndr
bndr1 Expr InBndr
rhs'
; (SimplFloats, SimplEnv) -> SimplM (SimplFloats, SimplEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplFloats
rhs_floats SimplFloats -> SimplFloats -> SimplFloats
`addFloats` SimplFloats
bind_float, SimplEnv
env2) }
simplJoinBind :: SimplEnv
-> SimplCont
-> InId -> OutId
-> InExpr -> SimplEnv
-> SimplM (SimplFloats, SimplEnv)
simplJoinBind :: SimplEnv
-> SimplCont
-> InBndr
-> InBndr
-> Expr InBndr
-> SimplEnv
-> SimplM (SimplFloats, SimplEnv)
simplJoinBind SimplEnv
env SimplCont
cont InBndr
old_bndr InBndr
new_bndr Expr InBndr
rhs SimplEnv
rhs_se
= do { let rhs_env :: SimplEnv
rhs_env = SimplEnv
rhs_se SimplEnv -> SimplEnv -> SimplEnv
`setInScopeFromE` SimplEnv
env
; Expr InBndr
rhs' <- SimplEnv
-> InBndr -> Expr InBndr -> SimplCont -> SimplM (Expr InBndr)
simplJoinRhs SimplEnv
rhs_env InBndr
old_bndr Expr InBndr
rhs SimplCont
cont
; SimplEnv
-> BindContext
-> InBndr
-> InBndr
-> Expr InBndr
-> SimplM (SimplFloats, SimplEnv)
completeBind SimplEnv
env (SimplCont -> BindContext
BC_Join SimplCont
cont) InBndr
old_bndr InBndr
new_bndr Expr InBndr
rhs' }
simplNonRecX :: SimplEnv
-> InId
-> OutExpr
-> SimplM (SimplFloats, SimplEnv)
simplNonRecX :: SimplEnv -> InBndr -> Expr InBndr -> SimplM (SimplFloats, SimplEnv)
simplNonRecX SimplEnv
env InBndr
bndr Expr InBndr
new_rhs
| Bool -> SDoc -> Bool -> Bool
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Bool -> Bool
not (InBndr -> Bool
isJoinId InBndr
bndr)) (InBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr InBndr
bndr) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
InBndr -> Bool
isDeadBinder InBndr
bndr
= (SimplFloats, SimplEnv) -> SimplM (SimplFloats, SimplEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplEnv -> SimplFloats
emptyFloats SimplEnv
env, SimplEnv
env)
| Coercion Coercion
co <- Expr InBndr
new_rhs
= (SimplFloats, SimplEnv) -> SimplM (SimplFloats, SimplEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplEnv -> SimplFloats
emptyFloats SimplEnv
env, SimplEnv -> InBndr -> Coercion -> SimplEnv
extendCvSubst SimplEnv
env InBndr
bndr Coercion
co)
| Expr InBndr -> Bool
exprIsTrivial Expr InBndr
new_rhs
= (SimplFloats, SimplEnv) -> SimplM (SimplFloats, SimplEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplEnv -> SimplFloats
emptyFloats SimplEnv
env
, SimplEnv -> InBndr -> SimplSR -> SimplEnv
extendIdSubst SimplEnv
env InBndr
bndr (Expr InBndr -> Maybe JoinArity -> SimplSR
DoneEx Expr InBndr
new_rhs Maybe JoinArity
forall a. Maybe a
Nothing))
| Bool
otherwise
= do { (SimplEnv
env1, InBndr
new_bndr) <- SimplEnv -> InBndr -> SimplM (SimplEnv, InBndr)
simplBinder SimplEnv
env InBndr
bndr
; let is_strict :: Bool
is_strict = InBndr -> Bool
isStrictId InBndr
new_bndr
; (SimplFloats
rhs_floats, Expr InBndr
rhs1) <- SimplEnv
-> TopLevelFlag
-> RecFlag
-> Bool
-> InBndr
-> SimplFloats
-> Expr InBndr
-> SimplM (SimplFloats, Expr InBndr)
prepareBinding SimplEnv
env TopLevelFlag
NotTopLevel RecFlag
NonRecursive Bool
is_strict
InBndr
new_bndr (SimplEnv -> SimplFloats
emptyFloats SimplEnv
env) Expr InBndr
new_rhs
; (SimplFloats
bind_float, SimplEnv
env2) <- SimplEnv
-> BindContext
-> InBndr
-> InBndr
-> Expr InBndr
-> SimplM (SimplFloats, SimplEnv)
completeBind (SimplEnv
env1 SimplEnv -> SimplFloats -> SimplEnv
`setInScopeFromF` SimplFloats
rhs_floats)
(TopLevelFlag -> RecFlag -> BindContext
BC_Let TopLevelFlag
NotTopLevel RecFlag
NonRecursive)
InBndr
bndr InBndr
new_bndr Expr InBndr
rhs1
; (SimplFloats, SimplEnv) -> SimplM (SimplFloats, SimplEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplFloats
rhs_floats SimplFloats -> SimplFloats -> SimplFloats
`addFloats` SimplFloats
bind_float, SimplEnv
env2) }
tryCastWorkerWrapper :: SimplEnv -> BindContext
-> InId -> OccInfo
-> OutId -> OutExpr
-> SimplM (SimplFloats, SimplEnv)
tryCastWorkerWrapper :: SimplEnv
-> BindContext
-> InBndr
-> OccInfo
-> InBndr
-> Expr InBndr
-> SimplM (SimplFloats, SimplEnv)
tryCastWorkerWrapper SimplEnv
env BindContext
bind_cxt InBndr
old_bndr OccInfo
occ_info InBndr
bndr (Cast Expr InBndr
rhs Coercion
co)
| BC_Let TopLevelFlag
top_lvl RecFlag
is_rec <- BindContext
bind_cxt
, Bool -> Bool
not (InBndr -> Bool
isDFunId InBndr
bndr)
, Bool -> Bool
not (Expr InBndr -> Bool
exprIsTrivial Expr InBndr
rhs)
, Bool -> Bool
not (IdInfo -> Bool
hasInlineUnfolding IdInfo
info)
, OutType -> Bool
isConcrete (HasDebugCallStack => OutType -> OutType
OutType -> OutType
typeKind OutType
rhs_ty)
, Bool -> Bool
not (InlinePragma -> Bool
isOpaquePragma (InBndr -> InlinePragma
idInlinePragma InBndr
old_bndr))
= do { Unique
uniq <- SimplM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
; let work_name :: Name
work_name = Unique -> FastString -> Name
mkSystemVarName Unique
uniq FastString
occ_fs
work_id :: InBndr
work_id = HasDebugCallStack => Name -> OutType -> OutType -> IdInfo -> InBndr
Name -> OutType -> OutType -> IdInfo -> InBndr
mkLocalIdWithInfo Name
work_name OutType
Many OutType
rhs_ty IdInfo
worker_info
is_strict :: Bool
is_strict = InBndr -> Bool
isStrictId InBndr
bndr
; (SimplFloats
rhs_floats, Expr InBndr
work_rhs) <- SimplEnv
-> TopLevelFlag
-> RecFlag
-> Bool
-> InBndr
-> SimplFloats
-> Expr InBndr
-> SimplM (SimplFloats, Expr InBndr)
prepareBinding SimplEnv
env TopLevelFlag
top_lvl RecFlag
is_rec Bool
is_strict
InBndr
work_id (SimplEnv -> SimplFloats
emptyFloats SimplEnv
env) Expr InBndr
rhs
; Unfolding
work_unf <- TopLevelFlag -> InBndr -> Expr InBndr -> SimplM Unfolding
mk_worker_unfolding TopLevelFlag
top_lvl InBndr
work_id Expr InBndr
work_rhs
; let work_id_w_unf :: InBndr
work_id_w_unf = InBndr
work_id InBndr -> Unfolding -> InBndr
`setIdUnfolding` Unfolding
work_unf
floats :: SimplFloats
floats = SimplFloats
rhs_floats SimplFloats -> LetFloats -> SimplFloats
`addLetFloats`
HasDebugCallStack => InBind -> LetFloats
InBind -> LetFloats
unitLetFloat (InBndr -> Expr InBndr -> InBind
forall b. b -> Expr b -> Bind b
NonRec InBndr
work_id_w_unf Expr InBndr
work_rhs)
triv_rhs :: Expr InBndr
triv_rhs = Expr InBndr -> Coercion -> Expr InBndr
forall b. Expr b -> Coercion -> Expr b
Cast (InBndr -> Expr InBndr
forall b. InBndr -> Expr b
Var InBndr
work_id_w_unf) Coercion
co
; if SimplEnv -> BindContext -> InBndr -> OccInfo -> Expr InBndr -> Bool
postInlineUnconditionally SimplEnv
env BindContext
bind_cxt InBndr
bndr OccInfo
occ_info Expr InBndr
triv_rhs
then do { Tick -> SimplM ()
tick (InBndr -> Tick
PostInlineUnconditionally InBndr
bndr)
; (SimplFloats, SimplEnv) -> SimplM (SimplFloats, SimplEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return ( SimplFloats
floats
, SimplEnv -> InBndr -> SimplSR -> SimplEnv
extendIdSubst (SimplEnv -> SimplFloats -> SimplEnv
setInScopeFromF SimplEnv
env SimplFloats
floats) InBndr
old_bndr (SimplSR -> SimplEnv) -> SimplSR -> SimplEnv
forall a b. (a -> b) -> a -> b
$
Expr InBndr -> Maybe JoinArity -> SimplSR
DoneEx Expr InBndr
triv_rhs Maybe JoinArity
forall a. Maybe a
Nothing ) }
else do { Unfolding
wrap_unf <- UnfoldingOpts
-> TopLevelFlag
-> UnfoldingSource
-> InBndr
-> Expr InBndr
-> SimplM Unfolding
mkLetUnfolding (SimplMode -> UnfoldingOpts
sm_uf_opts SimplMode
mode) TopLevelFlag
top_lvl UnfoldingSource
InlineRhs InBndr
bndr Expr InBndr
triv_rhs
; let bndr' :: InBndr
bndr' = InBndr
bndr InBndr -> InlinePragma -> InBndr
`setInlinePragma` InlinePragma -> InlinePragma
mkCastWrapperInlinePrag (InBndr -> InlinePragma
idInlinePragma InBndr
bndr)
InBndr -> Unfolding -> InBndr
`setIdUnfolding` Unfolding
wrap_unf
floats' :: SimplFloats
floats' = SimplFloats
floats SimplFloats -> InBind -> SimplFloats
`extendFloats` InBndr -> Expr InBndr -> InBind
forall b. b -> Expr b -> Bind b
NonRec InBndr
bndr' Expr InBndr
triv_rhs
; (SimplFloats, SimplEnv) -> SimplM (SimplFloats, SimplEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return ( SimplFloats
floats', SimplEnv -> SimplFloats -> SimplEnv
setInScopeFromF SimplEnv
env SimplFloats
floats' ) } }
where
mode :: SimplMode
mode = SimplEnv -> SimplMode
getMode SimplEnv
env
occ_fs :: FastString
occ_fs = InBndr -> FastString
forall a. NamedThing a => a -> FastString
getOccFS InBndr
bndr
rhs_ty :: OutType
rhs_ty = Coercion -> OutType
coercionLKind Coercion
co
info :: IdInfo
info = HasDebugCallStack => InBndr -> IdInfo
InBndr -> IdInfo
idInfo InBndr
bndr
worker_info :: IdInfo
worker_info = IdInfo
vanillaIdInfo IdInfo -> DmdSig -> IdInfo
`setDmdSigInfo` IdInfo -> DmdSig
dmdSigInfo IdInfo
info
IdInfo -> CprSig -> IdInfo
`setCprSigInfo` IdInfo -> CprSig
cprSigInfo IdInfo
info
IdInfo -> Demand -> IdInfo
`setDemandInfo` IdInfo -> Demand
demandInfo IdInfo
info
IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` IdInfo -> InlinePragma
inlinePragInfo IdInfo
info
IdInfo -> JoinArity -> IdInfo
`setArityInfo` IdInfo -> JoinArity
arityInfo IdInfo
info
mk_worker_unfolding :: TopLevelFlag -> InBndr -> Expr InBndr -> SimplM Unfolding
mk_worker_unfolding TopLevelFlag
top_lvl InBndr
work_id Expr InBndr
work_rhs
= case IdInfo -> Unfolding
realUnfoldingInfo IdInfo
info of
unf :: Unfolding
unf@(CoreUnfolding { uf_tmpl :: Unfolding -> Expr InBndr
uf_tmpl = Expr InBndr
unf_rhs, uf_src :: Unfolding -> UnfoldingSource
uf_src = UnfoldingSource
src })
| UnfoldingSource -> Bool
isStableSource UnfoldingSource
src -> Unfolding -> SimplM Unfolding
forall (m :: * -> *) a. Monad m => a -> m a
return (Unfolding
unf { uf_tmpl :: Expr InBndr
uf_tmpl = Expr InBndr -> Coercion -> Expr InBndr
mkCast Expr InBndr
unf_rhs (Coercion -> Coercion
mkSymCo Coercion
co) })
Unfolding
_ -> UnfoldingOpts
-> TopLevelFlag
-> UnfoldingSource
-> InBndr
-> Expr InBndr
-> SimplM Unfolding
mkLetUnfolding (SimplMode -> UnfoldingOpts
sm_uf_opts SimplMode
mode) TopLevelFlag
top_lvl UnfoldingSource
InlineRhs InBndr
work_id Expr InBndr
work_rhs
tryCastWorkerWrapper SimplEnv
env BindContext
_ InBndr
_ OccInfo
_ InBndr
bndr Expr InBndr
rhs
= (SimplFloats, SimplEnv) -> SimplM (SimplFloats, SimplEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplEnv -> InBind -> (SimplFloats, SimplEnv)
mkFloatBind SimplEnv
env (InBndr -> Expr InBndr -> InBind
forall b. b -> Expr b -> Bind b
NonRec InBndr
bndr Expr InBndr
rhs))
mkCastWrapperInlinePrag :: InlinePragma -> InlinePragma
mkCastWrapperInlinePrag :: InlinePragma -> InlinePragma
mkCastWrapperInlinePrag (InlinePragma { inl_act :: InlinePragma -> Activation
inl_act = Activation
act, inl_rule :: InlinePragma -> RuleMatchInfo
inl_rule = RuleMatchInfo
rule_info })
= InlinePragma :: SourceText
-> InlineSpec
-> Maybe JoinArity
-> Activation
-> RuleMatchInfo
-> InlinePragma
InlinePragma { inl_src :: SourceText
inl_src = String -> SourceText
SourceText String
"{-# INLINE"
, inl_inline :: InlineSpec
inl_inline = InlineSpec
NoUserInlinePrag
, inl_sat :: Maybe JoinArity
inl_sat = Maybe JoinArity
forall a. Maybe a
Nothing
, inl_act :: Activation
inl_act = Activation
wrap_act
, inl_rule :: RuleMatchInfo
inl_rule = RuleMatchInfo
rule_info }
where
wrap_act :: Activation
wrap_act | Activation -> Bool
isNeverActive Activation
act = Activation
activateDuringFinal
| Bool
otherwise = Activation
act
prepareBinding :: SimplEnv -> TopLevelFlag -> RecFlag -> Bool
-> Id
-> SimplFloats -> OutExpr
-> SimplM (SimplFloats, OutExpr)
prepareBinding :: SimplEnv
-> TopLevelFlag
-> RecFlag
-> Bool
-> InBndr
-> SimplFloats
-> Expr InBndr
-> SimplM (SimplFloats, Expr InBndr)
prepareBinding SimplEnv
env TopLevelFlag
top_lvl RecFlag
is_rec Bool
strict_bind InBndr
bndr SimplFloats
rhs_floats Expr InBndr
rhs
= do {
let (SimplFloats
rhs_floats1, Expr InBndr
rhs1) = SimplFloats -> Expr InBndr -> (SimplFloats, Expr InBndr)
wrapJoinFloatsX SimplFloats
rhs_floats Expr InBndr
rhs
; let rhs_env :: SimplEnv
rhs_env = SimplEnv
env SimplEnv -> SimplFloats -> SimplEnv
`setInScopeFromF` SimplFloats
rhs_floats1
; (LetFloats
anf_floats, Expr InBndr
rhs2) <- HasDebugCallStack =>
SimplEnv
-> TopLevelFlag
-> FastString
-> Expr InBndr
-> SimplM (LetFloats, Expr InBndr)
SimplEnv
-> TopLevelFlag
-> FastString
-> Expr InBndr
-> SimplM (LetFloats, Expr InBndr)
prepareRhs SimplEnv
rhs_env TopLevelFlag
top_lvl (InBndr -> FastString
forall a. NamedThing a => a -> FastString
getOccFS InBndr
bndr) Expr InBndr
rhs1
; let all_floats :: SimplFloats
all_floats = SimplFloats
rhs_floats1 SimplFloats -> LetFloats -> SimplFloats
`addLetFloats` LetFloats
anf_floats
; if TopLevelFlag
-> RecFlag -> Bool -> SimplFloats -> Expr InBndr -> Bool
doFloatFromRhs TopLevelFlag
top_lvl RecFlag
is_rec Bool
strict_bind SimplFloats
all_floats Expr InBndr
rhs2
then
do { Tick -> SimplM ()
tick Tick
LetFloatFromLet
; (SimplFloats, Expr InBndr) -> SimplM (SimplFloats, Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplFloats
all_floats, Expr InBndr
rhs2) }
else
(SimplFloats, Expr InBndr) -> SimplM (SimplFloats, Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplEnv -> SimplFloats
emptyFloats SimplEnv
env, SimplFloats -> Expr InBndr -> Expr InBndr
wrapFloats SimplFloats
rhs_floats1 Expr InBndr
rhs1) }
prepareRhs :: HasDebugCallStack
=> SimplEnv -> TopLevelFlag
-> FastString
-> OutExpr
-> SimplM (LetFloats, OutExpr)
prepareRhs :: SimplEnv
-> TopLevelFlag
-> FastString
-> Expr InBndr
-> SimplM (LetFloats, Expr InBndr)
prepareRhs SimplEnv
env TopLevelFlag
top_lvl FastString
occ Expr InBndr
rhs0
= do { (Bool
_is_exp, LetFloats
floats, Expr InBndr
rhs1) <- JoinArity -> Expr InBndr -> SimplM (Bool, LetFloats, Expr InBndr)
go JoinArity
0 Expr InBndr
rhs0
; (LetFloats, Expr InBndr) -> SimplM (LetFloats, Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (LetFloats
floats, Expr InBndr
rhs1) }
where
go :: Int -> OutExpr -> SimplM (Bool, LetFloats, OutExpr)
go :: JoinArity -> Expr InBndr -> SimplM (Bool, LetFloats, Expr InBndr)
go JoinArity
n_val_args (Cast Expr InBndr
rhs Coercion
co)
= do { (Bool
is_exp, LetFloats
floats, Expr InBndr
rhs') <- JoinArity -> Expr InBndr -> SimplM (Bool, LetFloats, Expr InBndr)
go JoinArity
n_val_args Expr InBndr
rhs
; (Bool, LetFloats, Expr InBndr)
-> SimplM (Bool, LetFloats, Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
is_exp, LetFloats
floats, Expr InBndr -> Coercion -> Expr InBndr
forall b. Expr b -> Coercion -> Expr b
Cast Expr InBndr
rhs' Coercion
co) }
go JoinArity
n_val_args (App Expr InBndr
fun (Type OutType
ty))
= do { (Bool
is_exp, LetFloats
floats, Expr InBndr
rhs') <- JoinArity -> Expr InBndr -> SimplM (Bool, LetFloats, Expr InBndr)
go JoinArity
n_val_args Expr InBndr
fun
; (Bool, LetFloats, Expr InBndr)
-> SimplM (Bool, LetFloats, Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
is_exp, LetFloats
floats, Expr InBndr -> Expr InBndr -> Expr InBndr
forall b. Expr b -> Expr b -> Expr b
App Expr InBndr
rhs' (OutType -> Expr InBndr
forall b. OutType -> Expr b
Type OutType
ty)) }
go JoinArity
n_val_args (App Expr InBndr
fun Expr InBndr
arg)
= do { (Bool
is_exp, LetFloats
floats1, Expr InBndr
fun') <- JoinArity -> Expr InBndr -> SimplM (Bool, LetFloats, Expr InBndr)
go (JoinArity
n_val_argsJoinArity -> JoinArity -> JoinArity
forall a. Num a => a -> a -> a
+JoinArity
1) Expr InBndr
fun
; if Bool
is_exp
then do { (LetFloats
floats2, Expr InBndr
arg') <- HasDebugCallStack =>
SimplEnv
-> TopLevelFlag
-> Demand
-> FastString
-> Expr InBndr
-> SimplM (LetFloats, Expr InBndr)
SimplEnv
-> TopLevelFlag
-> Demand
-> FastString
-> Expr InBndr
-> SimplM (LetFloats, Expr InBndr)
makeTrivial SimplEnv
env TopLevelFlag
top_lvl Demand
topDmd FastString
occ Expr InBndr
arg
; (Bool, LetFloats, Expr InBndr)
-> SimplM (Bool, LetFloats, Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, LetFloats
floats1 LetFloats -> LetFloats -> LetFloats
`addLetFlts` LetFloats
floats2, Expr InBndr -> Expr InBndr -> Expr InBndr
forall b. Expr b -> Expr b -> Expr b
App Expr InBndr
fun' Expr InBndr
arg') }
else (Bool, LetFloats, Expr InBndr)
-> SimplM (Bool, LetFloats, Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, LetFloats
emptyLetFloats, Expr InBndr -> Expr InBndr -> Expr InBndr
forall b. Expr b -> Expr b -> Expr b
App Expr InBndr
fun Expr InBndr
arg)
}
go JoinArity
n_val_args (Var InBndr
fun)
= (Bool, LetFloats, Expr InBndr)
-> SimplM (Bool, LetFloats, Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
is_exp, LetFloats
emptyLetFloats, InBndr -> Expr InBndr
forall b. InBndr -> Expr b
Var InBndr
fun)
where
is_exp :: Bool
is_exp = CheapAppFun
isExpandableApp InBndr
fun JoinArity
n_val_args
go JoinArity
n_val_args (Tick CoreTickish
t Expr InBndr
rhs)
| CoreTickish -> TickishScoping
forall (pass :: TickishPass). GenTickish pass -> TickishScoping
tickishScoped CoreTickish
t TickishScoping -> TickishScoping -> Bool
forall a. Eq a => a -> a -> Bool
== TickishScoping
NoScope
= do { (Bool
is_exp, LetFloats
floats, Expr InBndr
rhs') <- JoinArity -> Expr InBndr -> SimplM (Bool, LetFloats, Expr InBndr)
go JoinArity
n_val_args Expr InBndr
rhs
; (Bool, LetFloats, Expr InBndr)
-> SimplM (Bool, LetFloats, Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
is_exp, LetFloats
floats, CoreTickish -> Expr InBndr -> Expr InBndr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t Expr InBndr
rhs') }
| (Bool -> Bool
not (CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishCounts CoreTickish
t) Bool -> Bool -> Bool
|| CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishCanSplit CoreTickish
t)
= do { (Bool
is_exp, LetFloats
floats, Expr InBndr
rhs') <- JoinArity -> Expr InBndr -> SimplM (Bool, LetFloats, Expr InBndr)
go JoinArity
n_val_args Expr InBndr
rhs
; let tickIt :: (InBndr, Expr InBndr) -> (InBndr, Expr InBndr)
tickIt (InBndr
id, Expr InBndr
expr) = (InBndr
id, CoreTickish -> Expr InBndr -> Expr InBndr
mkTick (CoreTickish -> CoreTickish
forall (pass :: TickishPass). GenTickish pass -> GenTickish pass
mkNoCount CoreTickish
t) Expr InBndr
expr)
floats' :: LetFloats
floats' = LetFloats
-> ((InBndr, Expr InBndr) -> (InBndr, Expr InBndr)) -> LetFloats
mapLetFloats LetFloats
floats (InBndr, Expr InBndr) -> (InBndr, Expr InBndr)
tickIt
; (Bool, LetFloats, Expr InBndr)
-> SimplM (Bool, LetFloats, Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
is_exp, LetFloats
floats', CoreTickish -> Expr InBndr -> Expr InBndr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t Expr InBndr
rhs') }
go JoinArity
_ Expr InBndr
other
= (Bool, LetFloats, Expr InBndr)
-> SimplM (Bool, LetFloats, Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, LetFloats
emptyLetFloats, Expr InBndr
other)
makeTrivialArg :: HasDebugCallStack => SimplEnv -> ArgSpec -> SimplM (LetFloats, ArgSpec)
makeTrivialArg :: SimplEnv -> ArgSpec -> SimplM (LetFloats, ArgSpec)
makeTrivialArg SimplEnv
env arg :: ArgSpec
arg@(ValArg { as_arg :: ArgSpec -> Expr InBndr
as_arg = Expr InBndr
e, as_dmd :: ArgSpec -> Demand
as_dmd = Demand
dmd })
= do { (LetFloats
floats, Expr InBndr
e') <- HasDebugCallStack =>
SimplEnv
-> TopLevelFlag
-> Demand
-> FastString
-> Expr InBndr
-> SimplM (LetFloats, Expr InBndr)
SimplEnv
-> TopLevelFlag
-> Demand
-> FastString
-> Expr InBndr
-> SimplM (LetFloats, Expr InBndr)
makeTrivial SimplEnv
env TopLevelFlag
NotTopLevel Demand
dmd (String -> FastString
fsLit String
"arg") Expr InBndr
e
; (LetFloats, ArgSpec) -> SimplM (LetFloats, ArgSpec)
forall (m :: * -> *) a. Monad m => a -> m a
return (LetFloats
floats, ArgSpec
arg { as_arg :: Expr InBndr
as_arg = Expr InBndr
e' }) }
makeTrivialArg SimplEnv
_ ArgSpec
arg
= (LetFloats, ArgSpec) -> SimplM (LetFloats, ArgSpec)
forall (m :: * -> *) a. Monad m => a -> m a
return (LetFloats
emptyLetFloats, ArgSpec
arg)
makeTrivial :: HasDebugCallStack
=> SimplEnv -> TopLevelFlag -> Demand
-> FastString
-> OutExpr
-> SimplM (LetFloats, OutExpr)
makeTrivial :: SimplEnv
-> TopLevelFlag
-> Demand
-> FastString
-> Expr InBndr
-> SimplM (LetFloats, Expr InBndr)
makeTrivial SimplEnv
env TopLevelFlag
top_lvl Demand
dmd FastString
occ_fs Expr InBndr
expr
| Expr InBndr -> Bool
exprIsTrivial Expr InBndr
expr
Bool -> Bool -> Bool
|| Bool -> Bool
not (TopLevelFlag -> Expr InBndr -> OutType -> Bool
bindingOk TopLevelFlag
top_lvl Expr InBndr
expr OutType
expr_ty)
= (LetFloats, Expr InBndr) -> SimplM (LetFloats, Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (LetFloats
emptyLetFloats, Expr InBndr
expr)
| Cast Expr InBndr
expr' Coercion
co <- Expr InBndr
expr
= do { (LetFloats
floats, Expr InBndr
triv_expr) <- HasDebugCallStack =>
SimplEnv
-> TopLevelFlag
-> Demand
-> FastString
-> Expr InBndr
-> SimplM (LetFloats, Expr InBndr)
SimplEnv
-> TopLevelFlag
-> Demand
-> FastString
-> Expr InBndr
-> SimplM (LetFloats, Expr InBndr)
makeTrivial SimplEnv
env TopLevelFlag
top_lvl Demand
dmd FastString
occ_fs Expr InBndr
expr'
; (LetFloats, Expr InBndr) -> SimplM (LetFloats, Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (LetFloats
floats, Expr InBndr -> Coercion -> Expr InBndr
forall b. Expr b -> Coercion -> Expr b
Cast Expr InBndr
triv_expr Coercion
co) }
| Bool
otherwise
= do { (LetFloats
floats, InBndr
new_id) <- HasDebugCallStack =>
SimplEnv
-> TopLevelFlag
-> FastString
-> IdInfo
-> Expr InBndr
-> OutType
-> SimplM (LetFloats, InBndr)
SimplEnv
-> TopLevelFlag
-> FastString
-> IdInfo
-> Expr InBndr
-> OutType
-> SimplM (LetFloats, InBndr)
makeTrivialBinding SimplEnv
env TopLevelFlag
top_lvl FastString
occ_fs
IdInfo
id_info Expr InBndr
expr OutType
expr_ty
; (LetFloats, Expr InBndr) -> SimplM (LetFloats, Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (LetFloats
floats, InBndr -> Expr InBndr
forall b. InBndr -> Expr b
Var InBndr
new_id) }
where
id_info :: IdInfo
id_info = IdInfo
vanillaIdInfo IdInfo -> Demand -> IdInfo
`setDemandInfo` Demand
dmd
expr_ty :: OutType
expr_ty = HasDebugCallStack => Expr InBndr -> OutType
Expr InBndr -> OutType
exprType Expr InBndr
expr
makeTrivialBinding :: HasDebugCallStack
=> SimplEnv -> TopLevelFlag
-> FastString
-> IdInfo
-> OutExpr
-> OutType
-> SimplM (LetFloats, OutId)
makeTrivialBinding :: SimplEnv
-> TopLevelFlag
-> FastString
-> IdInfo
-> Expr InBndr
-> OutType
-> SimplM (LetFloats, InBndr)
makeTrivialBinding SimplEnv
env TopLevelFlag
top_lvl FastString
occ_fs IdInfo
info Expr InBndr
expr OutType
expr_ty
= do { (LetFloats
floats, Expr InBndr
expr1) <- HasDebugCallStack =>
SimplEnv
-> TopLevelFlag
-> FastString
-> Expr InBndr
-> SimplM (LetFloats, Expr InBndr)
SimplEnv
-> TopLevelFlag
-> FastString
-> Expr InBndr
-> SimplM (LetFloats, Expr InBndr)
prepareRhs SimplEnv
env TopLevelFlag
top_lvl FastString
occ_fs Expr InBndr
expr
; Unique
uniq <- SimplM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
; let name :: Name
name = Unique -> FastString -> Name
mkSystemVarName Unique
uniq FastString
occ_fs
var :: InBndr
var = HasDebugCallStack => Name -> OutType -> OutType -> IdInfo -> InBndr
Name -> OutType -> OutType -> IdInfo -> InBndr
mkLocalIdWithInfo Name
name OutType
Many OutType
expr_ty IdInfo
info
; (ArityType
arity_type, Expr InBndr
expr2) <- SimplEnv
-> InBndr -> Expr InBndr -> SimplM (ArityType, Expr InBndr)
tryEtaExpandRhs SimplEnv
env InBndr
var Expr InBndr
expr1
; Unfolding
unf <- UnfoldingOpts
-> TopLevelFlag
-> UnfoldingSource
-> InBndr
-> Expr InBndr
-> SimplM Unfolding
mkLetUnfolding (SimplMode -> UnfoldingOpts
sm_uf_opts SimplMode
mode) TopLevelFlag
top_lvl UnfoldingSource
InlineRhs InBndr
var Expr InBndr
expr2
; let final_id :: InBndr
final_id = InBndr -> ArityType -> Unfolding -> InBndr
addLetBndrInfo InBndr
var ArityType
arity_type Unfolding
unf
bind :: InBind
bind = InBndr -> Expr InBndr -> InBind
forall b. b -> Expr b -> Bind b
NonRec InBndr
final_id Expr InBndr
expr2
; (LetFloats, InBndr) -> SimplM (LetFloats, InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return ( LetFloats
floats LetFloats -> LetFloats -> LetFloats
`addLetFlts` HasDebugCallStack => InBind -> LetFloats
InBind -> LetFloats
unitLetFloat InBind
bind, InBndr
final_id ) }
where
mode :: SimplMode
mode = SimplEnv -> SimplMode
getMode SimplEnv
env
bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool
bindingOk :: TopLevelFlag -> Expr InBndr -> OutType -> Bool
bindingOk TopLevelFlag
top_lvl Expr InBndr
expr OutType
expr_ty
| TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl = Expr InBndr -> OutType -> Bool
exprIsTopLevelBindable Expr InBndr
expr OutType
expr_ty
| Bool
otherwise = Bool
True
completeBind :: SimplEnv
-> BindContext
-> InId
-> OutId
-> OutExpr
-> SimplM (SimplFloats, SimplEnv)
completeBind :: SimplEnv
-> BindContext
-> InBndr
-> InBndr
-> Expr InBndr
-> SimplM (SimplFloats, SimplEnv)
completeBind SimplEnv
env BindContext
bind_cxt InBndr
old_bndr InBndr
new_bndr Expr InBndr
new_rhs
| InBndr -> Bool
isCoVar InBndr
old_bndr
= case Expr InBndr
new_rhs of
Coercion Coercion
co -> (SimplFloats, SimplEnv) -> SimplM (SimplFloats, SimplEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplEnv -> SimplFloats
emptyFloats SimplEnv
env, SimplEnv -> InBndr -> Coercion -> SimplEnv
extendCvSubst SimplEnv
env InBndr
old_bndr Coercion
co)
Expr InBndr
_ -> (SimplFloats, SimplEnv) -> SimplM (SimplFloats, SimplEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplEnv -> InBind -> (SimplFloats, SimplEnv)
mkFloatBind SimplEnv
env (InBndr -> Expr InBndr -> InBind
forall b. b -> Expr b -> Bind b
NonRec InBndr
new_bndr Expr InBndr
new_rhs))
| Bool
otherwise
= Bool
-> SimplM (SimplFloats, SimplEnv) -> SimplM (SimplFloats, SimplEnv)
forall a. HasCallStack => Bool -> a -> a
assert (InBndr -> Bool
isId InBndr
new_bndr) (SimplM (SimplFloats, SimplEnv) -> SimplM (SimplFloats, SimplEnv))
-> SimplM (SimplFloats, SimplEnv) -> SimplM (SimplFloats, SimplEnv)
forall a b. (a -> b) -> a -> b
$
do { let old_info :: IdInfo
old_info = HasDebugCallStack => InBndr -> IdInfo
InBndr -> IdInfo
idInfo InBndr
old_bndr
old_unf :: Unfolding
old_unf = IdInfo -> Unfolding
realUnfoldingInfo IdInfo
old_info
occ_info :: OccInfo
occ_info = IdInfo -> OccInfo
occInfo IdInfo
old_info
; (ArityType
new_arity, Expr InBndr
eta_rhs) <- SimplEnv
-> InBndr -> Expr InBndr -> SimplM (ArityType, Expr InBndr)
tryEtaExpandRhs SimplEnv
env InBndr
new_bndr Expr InBndr
new_rhs
; Unfolding
new_unfolding <- SimplEnv
-> BindContext
-> InBndr
-> Expr InBndr
-> OutType
-> ArityType
-> Unfolding
-> SimplM Unfolding
simplLetUnfolding SimplEnv
env BindContext
bind_cxt InBndr
old_bndr
Expr InBndr
eta_rhs (InBndr -> OutType
idType InBndr
new_bndr) ArityType
new_arity Unfolding
old_unf
; let new_bndr_w_info :: InBndr
new_bndr_w_info = InBndr -> ArityType -> Unfolding -> InBndr
addLetBndrInfo InBndr
new_bndr ArityType
new_arity Unfolding
new_unfolding
; if SimplEnv -> BindContext -> InBndr -> OccInfo -> Expr InBndr -> Bool
postInlineUnconditionally SimplEnv
env BindContext
bind_cxt InBndr
new_bndr_w_info OccInfo
occ_info Expr InBndr
eta_rhs
then
do { Tick -> SimplM ()
tick (InBndr -> Tick
PostInlineUnconditionally InBndr
old_bndr)
; let unf_rhs :: Expr InBndr
unf_rhs = Unfolding -> Maybe (Expr InBndr)
maybeUnfoldingTemplate Unfolding
new_unfolding Maybe (Expr InBndr) -> Expr InBndr -> Expr InBndr
forall a. Maybe a -> a -> a
`orElse` Expr InBndr
eta_rhs
; SimplEnv
-> String
-> SDoc
-> SimplM (SimplFloats, SimplEnv)
-> SimplM (SimplFloats, SimplEnv)
forall a. SimplEnv -> String -> SDoc -> a -> a
simplTrace SimplEnv
env String
"PostInlineUnconditionally" (InBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr InBndr
new_bndr SDoc -> SDoc -> SDoc
<+> Expr InBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr Expr InBndr
unf_rhs) (SimplM (SimplFloats, SimplEnv) -> SimplM (SimplFloats, SimplEnv))
-> SimplM (SimplFloats, SimplEnv) -> SimplM (SimplFloats, SimplEnv)
forall a b. (a -> b) -> a -> b
$
(SimplFloats, SimplEnv) -> SimplM (SimplFloats, SimplEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return ( SimplEnv -> SimplFloats
emptyFloats SimplEnv
env
, SimplEnv -> InBndr -> SimplSR -> SimplEnv
extendIdSubst SimplEnv
env InBndr
old_bndr (SimplSR -> SimplEnv) -> SimplSR -> SimplEnv
forall a b. (a -> b) -> a -> b
$
Expr InBndr -> Maybe JoinArity -> SimplSR
DoneEx Expr InBndr
unf_rhs (InBndr -> Maybe JoinArity
isJoinId_maybe InBndr
new_bndr)) }
else
SimplEnv
-> BindContext
-> InBndr
-> OccInfo
-> InBndr
-> Expr InBndr
-> SimplM (SimplFloats, SimplEnv)
tryCastWorkerWrapper SimplEnv
env BindContext
bind_cxt InBndr
old_bndr OccInfo
occ_info InBndr
new_bndr_w_info Expr InBndr
eta_rhs }
addLetBndrInfo :: OutId -> ArityType -> Unfolding -> OutId
addLetBndrInfo :: InBndr -> ArityType -> Unfolding -> InBndr
addLetBndrInfo InBndr
new_bndr ArityType
new_arity_type Unfolding
new_unf
= InBndr
new_bndr InBndr -> IdInfo -> InBndr
`setIdInfo` IdInfo
info5
where
AT [OneShotInfo]
oss Divergence
div = ArityType
new_arity_type
new_arity :: JoinArity
new_arity = [OneShotInfo] -> JoinArity
forall (t :: * -> *) a. Foldable t => t a -> JoinArity
length [OneShotInfo]
oss
info1 :: IdInfo
info1 = HasDebugCallStack => InBndr -> IdInfo
InBndr -> IdInfo
idInfo InBndr
new_bndr IdInfo -> JoinArity -> IdInfo
`setArityInfo` JoinArity
new_arity
info2 :: IdInfo
info2 = IdInfo
info1 IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` Unfolding
new_unf
info3 :: IdInfo
info3 | Unfolding -> Bool
isEvaldUnfolding Unfolding
new_unf
= IdInfo -> Maybe IdInfo
zapDemandInfo IdInfo
info2 Maybe IdInfo -> IdInfo -> IdInfo
forall a. Maybe a -> a -> a
`orElse` IdInfo
info2
| Bool
otherwise
= IdInfo
info2
info4 :: IdInfo
info4 | Divergence -> Bool
isDeadEndDiv Divergence
div = IdInfo
info3 IdInfo -> DmdSig -> IdInfo
`setDmdSigInfo` DmdSig
bot_sig
IdInfo -> CprSig -> IdInfo
`setCprSigInfo` CprSig
bot_cpr
| Bool
otherwise = IdInfo
info3
bot_sig :: DmdSig
bot_sig = [Demand] -> Divergence -> DmdSig
mkClosedDmdSig (JoinArity -> Demand -> [Demand]
forall a. JoinArity -> a -> [a]
replicate JoinArity
new_arity Demand
topDmd) Divergence
div
bot_cpr :: CprSig
bot_cpr = JoinArity -> Cpr -> CprSig
mkCprSig JoinArity
new_arity Cpr
botCpr
info5 :: IdInfo
info5 = IdInfo -> IdInfo
zapCallArityInfo IdInfo
info4
simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
simplExpr :: SimplEnv -> Expr InBndr -> SimplM (Expr InBndr)
simplExpr !SimplEnv
env (Type OutType
ty)
= do { OutType
ty' <- SimplEnv -> OutType -> SimplM OutType
simplType SimplEnv
env OutType
ty
; Expr InBndr -> SimplM (Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OutType -> Expr InBndr
forall b. OutType -> Expr b
Type OutType
ty') }
simplExpr SimplEnv
env Expr InBndr
expr
= SimplEnv -> Expr InBndr -> SimplCont -> SimplM (Expr InBndr)
simplExprC SimplEnv
env Expr InBndr
expr (OutType -> SimplCont
mkBoringStop OutType
expr_out_ty)
where
expr_out_ty :: OutType
expr_out_ty :: OutType
expr_out_ty = SimplEnv -> OutType -> OutType
substTy SimplEnv
env (HasDebugCallStack => Expr InBndr -> OutType
Expr InBndr -> OutType
exprType Expr InBndr
expr)
simplExprC :: SimplEnv
-> InExpr
-> SimplCont
-> SimplM OutExpr
simplExprC :: SimplEnv -> Expr InBndr -> SimplCont -> SimplM (Expr InBndr)
simplExprC SimplEnv
env Expr InBndr
expr SimplCont
cont
=
do { (SimplFloats
floats, Expr InBndr
expr') <- SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplExprF SimplEnv
env Expr InBndr
expr SimplCont
cont
;
Expr InBndr -> SimplM (Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplFloats -> Expr InBndr -> Expr InBndr
wrapFloats SimplFloats
floats Expr InBndr
expr') }
simplExprF :: SimplEnv
-> InExpr
-> SimplCont
-> SimplM (SimplFloats, OutExpr)
simplExprF :: SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplExprF !SimplEnv
env Expr InBndr
e !SimplCont
cont
=
SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplExprF1 SimplEnv
env Expr InBndr
e SimplCont
cont
simplExprF1 :: SimplEnv -> InExpr -> SimplCont
-> SimplM (SimplFloats, OutExpr)
simplExprF1 :: SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplExprF1 SimplEnv
_ (Type OutType
ty) SimplCont
cont
= String -> SDoc -> SimplM (SimplFloats, Expr InBndr)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"simplExprF: type" (OutType -> SDoc
forall a. Outputable a => a -> SDoc
ppr OutType
ty SDoc -> SDoc -> SDoc
<+> String -> SDoc
textString
"cont: " SDoc -> SDoc -> SDoc
<+> SimplCont -> SDoc
forall a. Outputable a => a -> SDoc
ppr SimplCont
cont)
simplExprF1 SimplEnv
env (Var InBndr
v) SimplCont
cont = {-#SCC "simplIdF" #-} SimplEnv
-> InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplIdF SimplEnv
env InBndr
v SimplCont
cont
simplExprF1 SimplEnv
env (Lit Literal
lit) SimplCont
cont = {-#SCC "rebuild" #-} SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
rebuild SimplEnv
env (Literal -> Expr InBndr
forall b. Literal -> Expr b
Lit Literal
lit) SimplCont
cont
simplExprF1 SimplEnv
env (Tick CoreTickish
t Expr InBndr
expr) SimplCont
cont = {-#SCC "simplTick" #-} SimplEnv
-> CoreTickish
-> Expr InBndr
-> SimplCont
-> SimplM (SimplFloats, Expr InBndr)
simplTick SimplEnv
env CoreTickish
t Expr InBndr
expr SimplCont
cont
simplExprF1 SimplEnv
env (Cast Expr InBndr
body Coercion
co) SimplCont
cont = {-#SCC "simplCast" #-} SimplEnv
-> Expr InBndr
-> Coercion
-> SimplCont
-> SimplM (SimplFloats, Expr InBndr)
simplCast SimplEnv
env Expr InBndr
body Coercion
co SimplCont
cont
simplExprF1 SimplEnv
env (Coercion Coercion
co) SimplCont
cont = {-#SCC "simplCoercionF" #-} SimplEnv
-> Coercion -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplCoercionF SimplEnv
env Coercion
co SimplCont
cont
simplExprF1 SimplEnv
env (App Expr InBndr
fun Expr InBndr
arg) SimplCont
cont
= {-#SCC "simplExprF1-App" #-} case Expr InBndr
arg of
Type OutType
ty -> do {
OutType
arg' <- SimplEnv -> OutType -> SimplM OutType
simplType SimplEnv
env OutType
ty
; let hole' :: OutType
hole' = SimplEnv -> OutType -> OutType
substTy SimplEnv
env (HasDebugCallStack => Expr InBndr -> OutType
Expr InBndr -> OutType
exprType Expr InBndr
fun)
; SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplExprF SimplEnv
env Expr InBndr
fun (SimplCont -> SimplM (SimplFloats, Expr InBndr))
-> SimplCont -> SimplM (SimplFloats, Expr InBndr)
forall a b. (a -> b) -> a -> b
$
ApplyToTy :: OutType -> OutType -> SimplCont -> SimplCont
ApplyToTy { sc_arg_ty :: OutType
sc_arg_ty = OutType
arg'
, sc_hole_ty :: OutType
sc_hole_ty = OutType
hole'
, sc_cont :: SimplCont
sc_cont = SimplCont
cont } }
Expr InBndr
_ ->
SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplExprF SimplEnv
env Expr InBndr
fun (SimplCont -> SimplM (SimplFloats, Expr InBndr))
-> SimplCont -> SimplM (SimplFloats, Expr InBndr)
forall a b. (a -> b) -> a -> b
$
ApplyToVal :: DupFlag
-> OutType -> Expr InBndr -> SimplEnv -> SimplCont -> SimplCont
ApplyToVal { sc_arg :: Expr InBndr
sc_arg = Expr InBndr
arg, sc_env :: SimplEnv
sc_env = SimplEnv
env
, sc_hole_ty :: OutType
sc_hole_ty = SimplEnv -> OutType -> OutType
substTy SimplEnv
env (HasDebugCallStack => Expr InBndr -> OutType
Expr InBndr -> OutType
exprType Expr InBndr
fun)
, sc_dup :: DupFlag
sc_dup = DupFlag
NoDup, sc_cont :: SimplCont
sc_cont = SimplCont
cont }
simplExprF1 SimplEnv
env expr :: Expr InBndr
expr@(Lam {}) SimplCont
cont
= {-#SCC "simplExprF1-Lam" #-}
SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplLam SimplEnv
env (Expr InBndr -> JoinArity -> Expr InBndr
zapLambdaBndrs Expr InBndr
expr JoinArity
n_args) SimplCont
cont
where
n_args :: JoinArity
n_args = SimplCont -> JoinArity
countArgs SimplCont
cont
simplExprF1 SimplEnv
env (Case Expr InBndr
scrut InBndr
bndr OutType
_ [Alt InBndr]
alts) SimplCont
cont
= {-#SCC "simplExprF1-Case" #-}
SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplExprF SimplEnv
env Expr InBndr
scrut (Select :: DupFlag
-> InBndr -> [Alt InBndr] -> SimplEnv -> SimplCont -> SimplCont
Select { sc_dup :: DupFlag
sc_dup = DupFlag
NoDup, sc_bndr :: InBndr
sc_bndr = InBndr
bndr
, sc_alts :: [Alt InBndr]
sc_alts = [Alt InBndr]
alts
, sc_env :: SimplEnv
sc_env = SimplEnv
env, sc_cont :: SimplCont
sc_cont = SimplCont
cont })
simplExprF1 SimplEnv
env (Let (Rec [(InBndr, Expr InBndr)]
pairs) Expr InBndr
body) SimplCont
cont
| Just [(InBndr, Expr InBndr)]
pairs' <- [(InBndr, Expr InBndr)] -> Maybe [(InBndr, Expr InBndr)]
joinPointBindings_maybe [(InBndr, Expr InBndr)]
pairs
= {-#SCC "simplRecJoinPoin" #-} SimplEnv
-> [(InBndr, Expr InBndr)]
-> Expr InBndr
-> SimplCont
-> SimplM (SimplFloats, Expr InBndr)
simplRecJoinPoint SimplEnv
env [(InBndr, Expr InBndr)]
pairs' Expr InBndr
body SimplCont
cont
| Bool
otherwise
= {-#SCC "simplRecE" #-} SimplEnv
-> [(InBndr, Expr InBndr)]
-> Expr InBndr
-> SimplCont
-> SimplM (SimplFloats, Expr InBndr)
simplRecE SimplEnv
env [(InBndr, Expr InBndr)]
pairs Expr InBndr
body SimplCont
cont
simplExprF1 SimplEnv
env (Let (NonRec InBndr
bndr Expr InBndr
rhs) Expr InBndr
body) SimplCont
cont
| Type OutType
ty <- Expr InBndr
rhs
= {-#SCC "simplExprF1-NonRecLet-Type" #-}
Bool
-> SimplM (SimplFloats, Expr InBndr)
-> SimplM (SimplFloats, Expr InBndr)
forall a. HasCallStack => Bool -> a -> a
assert (InBndr -> Bool
isTyVar InBndr
bndr) (SimplM (SimplFloats, Expr InBndr)
-> SimplM (SimplFloats, Expr InBndr))
-> SimplM (SimplFloats, Expr InBndr)
-> SimplM (SimplFloats, Expr InBndr)
forall a b. (a -> b) -> a -> b
$
do { OutType
ty' <- SimplEnv -> OutType -> SimplM OutType
simplType SimplEnv
env OutType
ty
; SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplExprF (SimplEnv -> InBndr -> OutType -> SimplEnv
extendTvSubst SimplEnv
env InBndr
bndr OutType
ty') Expr InBndr
body SimplCont
cont }
| Just (InBndr
bndr', Expr InBndr
rhs') <- InBndr -> Expr InBndr -> Maybe (InBndr, Expr InBndr)
joinPointBinding_maybe InBndr
bndr Expr InBndr
rhs
= {-#SCC "simplNonRecJoinPoint" #-} SimplEnv
-> InBndr
-> Expr InBndr
-> Expr InBndr
-> SimplCont
-> SimplM (SimplFloats, Expr InBndr)
simplNonRecJoinPoint SimplEnv
env InBndr
bndr' Expr InBndr
rhs' Expr InBndr
body SimplCont
cont
| Bool
otherwise
= {-#SCC "simplNonRecE" #-} SimplEnv
-> InBndr
-> (Expr InBndr, SimplEnv)
-> Expr InBndr
-> SimplCont
-> SimplM (SimplFloats, Expr InBndr)
simplNonRecE SimplEnv
env InBndr
bndr (Expr InBndr
rhs, SimplEnv
env) Expr InBndr
body SimplCont
cont
simplJoinRhs :: SimplEnv -> InId -> InExpr -> SimplCont
-> SimplM OutExpr
simplJoinRhs :: SimplEnv
-> InBndr -> Expr InBndr -> SimplCont -> SimplM (Expr InBndr)
simplJoinRhs SimplEnv
env InBndr
bndr Expr InBndr
expr SimplCont
cont
| Just JoinArity
arity <- InBndr -> Maybe JoinArity
isJoinId_maybe InBndr
bndr
= do { let ([InBndr]
join_bndrs, Expr InBndr
join_body) = JoinArity -> Expr InBndr -> ([InBndr], Expr InBndr)
forall b. JoinArity -> Expr b -> ([b], Expr b)
collectNBinders JoinArity
arity Expr InBndr
expr
mult :: OutType
mult = SimplCont -> OutType
contHoleScaling SimplCont
cont
; (SimplEnv
env', [InBndr]
join_bndrs') <- SimplEnv -> [InBndr] -> SimplM (SimplEnv, [InBndr])
simplLamBndrs SimplEnv
env ((InBndr -> InBndr) -> [InBndr] -> [InBndr]
forall a b. (a -> b) -> [a] -> [b]
map (OutType -> InBndr -> InBndr
scaleVarBy OutType
mult) [InBndr]
join_bndrs)
; Expr InBndr
join_body' <- SimplEnv -> Expr InBndr -> SimplCont -> SimplM (Expr InBndr)
simplExprC SimplEnv
env' Expr InBndr
join_body SimplCont
cont
; Expr InBndr -> SimplM (Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr InBndr -> SimplM (Expr InBndr))
-> Expr InBndr -> SimplM (Expr InBndr)
forall a b. (a -> b) -> a -> b
$ [InBndr] -> Expr InBndr -> Expr InBndr
forall b. [b] -> Expr b -> Expr b
mkLams [InBndr]
join_bndrs' Expr InBndr
join_body' }
| Bool
otherwise
= String -> SDoc -> SimplM (Expr InBndr)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"simplJoinRhs" (InBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr InBndr
bndr)
simplType :: SimplEnv -> InType -> SimplM OutType
simplType :: SimplEnv -> OutType -> SimplM OutType
simplType SimplEnv
env OutType
ty
=
OutType -> ()
seqType OutType
new_ty () -> SimplM OutType -> SimplM OutType
`seq` OutType -> SimplM OutType
forall (m :: * -> *) a. Monad m => a -> m a
return OutType
new_ty
where
new_ty :: OutType
new_ty = SimplEnv -> OutType -> OutType
substTy SimplEnv
env OutType
ty
simplCoercionF :: SimplEnv -> InCoercion -> SimplCont
-> SimplM (SimplFloats, OutExpr)
simplCoercionF :: SimplEnv
-> Coercion -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplCoercionF SimplEnv
env Coercion
co SimplCont
cont
= do { Coercion
co' <- SimplEnv -> Coercion -> SimplM Coercion
simplCoercion SimplEnv
env Coercion
co
; SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
rebuild SimplEnv
env (Coercion -> Expr InBndr
forall b. Coercion -> Expr b
Coercion Coercion
co') SimplCont
cont }
simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion
simplCoercion :: SimplEnv -> Coercion -> SimplM Coercion
simplCoercion SimplEnv
env Coercion
co
= do { OptCoercionOpts
opts <- SimplM OptCoercionOpts
getOptCoercionOpts
; let opt_co :: Coercion
opt_co = OptCoercionOpts -> TCvSubst -> Coercion -> Coercion
optCoercion OptCoercionOpts
opts (SimplEnv -> TCvSubst
getTCvSubst SimplEnv
env) Coercion
co
; Coercion -> ()
seqCo Coercion
opt_co () -> SimplM Coercion -> SimplM Coercion
`seq` Coercion -> SimplM Coercion
forall (m :: * -> *) a. Monad m => a -> m a
return Coercion
opt_co }
simplTick :: SimplEnv -> CoreTickish -> InExpr -> SimplCont
-> SimplM (SimplFloats, OutExpr)
simplTick :: SimplEnv
-> CoreTickish
-> Expr InBndr
-> SimplCont
-> SimplM (SimplFloats, Expr InBndr)
simplTick SimplEnv
env CoreTickish
tickish Expr InBndr
expr SimplCont
cont
| CoreTickish
tickish CoreTickish -> TickishScoping -> Bool
forall (pass :: TickishPass).
GenTickish pass -> TickishScoping -> Bool
`tickishScopesLike` TickishScoping
SoftScope
= do { (SimplFloats
floats, Expr InBndr
expr') <- SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplExprF SimplEnv
env Expr InBndr
expr SimplCont
cont
; (SimplFloats, Expr InBndr) -> SimplM (SimplFloats, Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplFloats
floats, CoreTickish -> Expr InBndr -> Expr InBndr
mkTick CoreTickish
tickish Expr InBndr
expr')
}
| Select {} <- SimplCont
cont, Just Expr InBndr
expr' <- Maybe (Expr InBndr)
push_tick_inside
= SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplExprF SimplEnv
env Expr InBndr
expr' SimplCont
cont
| Bool
otherwise
= SimplM (SimplFloats, Expr InBndr)
no_floating_past_tick
where
push_tick_inside :: Maybe (Expr InBndr)
push_tick_inside =
case Expr InBndr
expr0 of
Case Expr InBndr
scrut InBndr
bndr OutType
ty [Alt InBndr]
alts
-> Expr InBndr -> Maybe (Expr InBndr)
forall a. a -> Maybe a
Just (Expr InBndr -> Maybe (Expr InBndr))
-> Expr InBndr -> Maybe (Expr InBndr)
forall a b. (a -> b) -> a -> b
$ Expr InBndr -> InBndr -> OutType -> [Alt InBndr] -> Expr InBndr
forall b. Expr b -> b -> OutType -> [Alt b] -> Expr b
Case (Expr InBndr -> Expr InBndr
tickScrut Expr InBndr
scrut) InBndr
bndr OutType
ty ((Alt InBndr -> Alt InBndr) -> [Alt InBndr] -> [Alt InBndr]
forall a b. (a -> b) -> [a] -> [b]
map Alt InBndr -> Alt InBndr
tickAlt [Alt InBndr]
alts)
Expr InBndr
_other -> Maybe (Expr InBndr)
forall a. Maybe a
Nothing
where ([CoreTickish]
ticks, Expr InBndr
expr0) = (CoreTickish -> Bool)
-> Expr InBndr -> ([CoreTickish], Expr InBndr)
forall b.
(CoreTickish -> Bool) -> Expr b -> ([CoreTickish], Expr b)
stripTicksTop CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
movable (CoreTickish -> Expr InBndr -> Expr InBndr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
tickish Expr InBndr
expr)
movable :: GenTickish pass -> Bool
movable GenTickish pass
t = Bool -> Bool
not (GenTickish pass -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishCounts GenTickish pass
t) Bool -> Bool -> Bool
||
GenTickish pass
t GenTickish pass -> TickishScoping -> Bool
forall (pass :: TickishPass).
GenTickish pass -> TickishScoping -> Bool
`tickishScopesLike` TickishScoping
NoScope Bool -> Bool -> Bool
||
GenTickish pass -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishCanSplit GenTickish pass
t
tickScrut :: Expr InBndr -> Expr InBndr
tickScrut Expr InBndr
e = (CoreTickish -> Expr InBndr -> Expr InBndr)
-> Expr InBndr -> [CoreTickish] -> Expr InBndr
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CoreTickish -> Expr InBndr -> Expr InBndr
mkTick Expr InBndr
e [CoreTickish]
ticks
tickAlt :: Alt InBndr -> Alt InBndr
tickAlt (Alt AltCon
c [InBndr]
bs Expr InBndr
e) = AltCon -> [InBndr] -> Expr InBndr -> Alt InBndr
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
c [InBndr]
bs ((CoreTickish -> Expr InBndr -> Expr InBndr)
-> Expr InBndr -> [CoreTickish] -> Expr InBndr
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CoreTickish -> Expr InBndr -> Expr InBndr
mkTick Expr InBndr
e [CoreTickish]
ts_scope)
ts_scope :: [CoreTickish]
ts_scope = (CoreTickish -> CoreTickish) -> [CoreTickish] -> [CoreTickish]
forall a b. (a -> b) -> [a] -> [b]
map CoreTickish -> CoreTickish
forall (pass :: TickishPass). GenTickish pass -> GenTickish pass
mkNoCount ([CoreTickish] -> [CoreTickish]) -> [CoreTickish] -> [CoreTickish]
forall a b. (a -> b) -> a -> b
$
(CoreTickish -> Bool) -> [CoreTickish] -> [CoreTickish]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (CoreTickish -> Bool) -> CoreTickish -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CoreTickish -> TickishScoping -> Bool
forall (pass :: TickishPass).
GenTickish pass -> TickishScoping -> Bool
`tickishScopesLike` TickishScoping
NoScope)) [CoreTickish]
ticks
no_floating_past_tick :: SimplM (SimplFloats, Expr InBndr)
no_floating_past_tick =
do { let (SimplCont
inc,SimplCont
outc) = SimplCont -> (SimplCont, SimplCont)
splitCont SimplCont
cont
; (SimplFloats
floats, Expr InBndr
expr1) <- SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplExprF SimplEnv
env Expr InBndr
expr SimplCont
inc
; let expr2 :: Expr InBndr
expr2 = SimplFloats -> Expr InBndr -> Expr InBndr
wrapFloats SimplFloats
floats Expr InBndr
expr1
tickish' :: CoreTickish
tickish' = SimplEnv -> CoreTickish -> CoreTickish
forall (pass :: TickishPass).
(XTickishId pass ~ InBndr) =>
SimplEnv -> GenTickish pass -> GenTickish pass
simplTickish SimplEnv
env CoreTickish
tickish
; SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
rebuild SimplEnv
env (CoreTickish -> Expr InBndr -> Expr InBndr
mkTick CoreTickish
tickish' Expr InBndr
expr2) SimplCont
outc
}
simplTickish :: SimplEnv -> GenTickish pass -> GenTickish pass
simplTickish SimplEnv
env GenTickish pass
tickish
| Breakpoint XBreakpoint pass
ext JoinArity
n [XTickishId pass]
ids <- GenTickish pass
tickish
= XBreakpoint pass
-> JoinArity -> [XTickishId pass] -> GenTickish pass
forall (pass :: TickishPass).
XBreakpoint pass
-> JoinArity -> [XTickishId pass] -> GenTickish pass
Breakpoint XBreakpoint pass
ext JoinArity
n ((InBndr -> InBndr) -> [InBndr] -> [InBndr]
forall a b. (a -> b) -> [a] -> [b]
map (SimplSR -> InBndr
getDoneId (SimplSR -> InBndr) -> (InBndr -> SimplSR) -> InBndr -> InBndr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimplEnv -> InBndr -> SimplSR
substId SimplEnv
env) [XTickishId pass]
[InBndr]
ids)
| Bool
otherwise = GenTickish pass
tickish
splitCont :: SimplCont -> (SimplCont, SimplCont)
splitCont :: SimplCont -> (SimplCont, SimplCont)
splitCont cont :: SimplCont
cont@(ApplyToTy { sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
tail }) = (SimplCont
cont { sc_cont :: SimplCont
sc_cont = SimplCont
inc }, SimplCont
outc)
where (SimplCont
inc,SimplCont
outc) = SimplCont -> (SimplCont, SimplCont)
splitCont SimplCont
tail
splitCont (CastIt Coercion
co SimplCont
c) = (Coercion -> SimplCont -> SimplCont
CastIt Coercion
co SimplCont
inc, SimplCont
outc)
where (SimplCont
inc,SimplCont
outc) = SimplCont -> (SimplCont, SimplCont)
splitCont SimplCont
c
splitCont SimplCont
other = (OutType -> SimplCont
mkBoringStop (SimplCont -> OutType
contHoleType SimplCont
other), SimplCont
other)
getDoneId :: SimplSR -> InBndr
getDoneId (DoneId InBndr
id) = InBndr
id
getDoneId (DoneEx Expr InBndr
e Maybe JoinArity
_) = HasDebugCallStack => Expr InBndr -> InBndr
Expr InBndr -> InBndr
getIdFromTrivialExpr Expr InBndr
e
getDoneId SimplSR
other = String -> SDoc -> InBndr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getDoneId" (SimplSR -> SDoc
forall a. Outputable a => a -> SDoc
ppr SimplSR
other)
rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr)
rebuild :: SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
rebuild SimplEnv
env Expr InBndr
expr SimplCont
cont
= case SimplCont
cont of
Stop {} -> (SimplFloats, Expr InBndr) -> SimplM (SimplFloats, Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplEnv -> SimplFloats
emptyFloats SimplEnv
env, Expr InBndr
expr)
TickIt CoreTickish
t SimplCont
cont -> SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
rebuild SimplEnv
env (CoreTickish -> Expr InBndr -> Expr InBndr
mkTick CoreTickish
t Expr InBndr
expr) SimplCont
cont
CastIt Coercion
co SimplCont
cont -> SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
rebuild SimplEnv
env (Expr InBndr -> Coercion -> Expr InBndr
mkCast Expr InBndr
expr Coercion
co) SimplCont
cont
Select { sc_bndr :: SimplCont -> InBndr
sc_bndr = InBndr
bndr, sc_alts :: SimplCont -> [Alt InBndr]
sc_alts = [Alt InBndr]
alts, sc_env :: SimplCont -> SimplEnv
sc_env = SimplEnv
se, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont }
-> SimplEnv
-> Expr InBndr
-> InBndr
-> [Alt InBndr]
-> SimplCont
-> SimplM (SimplFloats, Expr InBndr)
rebuildCase (SimplEnv
se SimplEnv -> SimplEnv -> SimplEnv
`setInScopeFromE` SimplEnv
env) Expr InBndr
expr InBndr
bndr [Alt InBndr]
alts SimplCont
cont
StrictArg { sc_fun :: SimplCont -> ArgInfo
sc_fun = ArgInfo
fun, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont, sc_fun_ty :: SimplCont -> OutType
sc_fun_ty = OutType
fun_ty }
-> SimplEnv
-> ArgInfo -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
rebuildCall SimplEnv
env (ArgInfo -> Expr InBndr -> OutType -> ArgInfo
addValArgTo ArgInfo
fun Expr InBndr
expr OutType
fun_ty ) SimplCont
cont
StrictBind { sc_bndr :: SimplCont -> InBndr
sc_bndr = InBndr
b, sc_body :: SimplCont -> Expr InBndr
sc_body = Expr InBndr
body, sc_env :: SimplCont -> SimplEnv
sc_env = SimplEnv
se, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont }
-> SimplEnv
-> InBndr
-> Expr InBndr
-> Expr InBndr
-> SimplCont
-> SimplM (SimplFloats, Expr InBndr)
completeBindX (SimplEnv
se SimplEnv -> SimplEnv -> SimplEnv
`setInScopeFromE` SimplEnv
env) InBndr
b Expr InBndr
expr Expr InBndr
body SimplCont
cont
ApplyToTy { sc_arg_ty :: SimplCont -> OutType
sc_arg_ty = OutType
ty, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont}
-> SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
rebuild SimplEnv
env (Expr InBndr -> Expr InBndr -> Expr InBndr
forall b. Expr b -> Expr b -> Expr b
App Expr InBndr
expr (OutType -> Expr InBndr
forall b. OutType -> Expr b
Type OutType
ty)) SimplCont
cont
ApplyToVal { sc_arg :: SimplCont -> Expr InBndr
sc_arg = Expr InBndr
arg, sc_env :: SimplCont -> SimplEnv
sc_env = SimplEnv
se, sc_dup :: SimplCont -> DupFlag
sc_dup = DupFlag
dup_flag, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont}
-> do { (DupFlag
_, SimplEnv
_, Expr InBndr
arg') <- SimplEnv
-> DupFlag
-> SimplEnv
-> Expr InBndr
-> SimplM (DupFlag, SimplEnv, Expr InBndr)
simplArg SimplEnv
env DupFlag
dup_flag SimplEnv
se Expr InBndr
arg
; SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
rebuild SimplEnv
env (Expr InBndr -> Expr InBndr -> Expr InBndr
forall b. Expr b -> Expr b -> Expr b
App Expr InBndr
expr Expr InBndr
arg') SimplCont
cont }
completeBindX :: SimplEnv
-> InId -> OutExpr
-> InExpr
-> SimplCont
-> SimplM (SimplFloats, OutExpr)
completeBindX :: SimplEnv
-> InBndr
-> Expr InBndr
-> Expr InBndr
-> SimplCont
-> SimplM (SimplFloats, Expr InBndr)
completeBindX SimplEnv
env InBndr
bndr Expr InBndr
rhs Expr InBndr
body SimplCont
cont
| OutType -> Expr InBndr -> Bool
needsCaseBinding (InBndr -> OutType
idType InBndr
bndr) Expr InBndr
rhs
= do { (SimplEnv
env1, InBndr
bndr1) <- SimplEnv -> InBndr -> SimplM (SimplEnv, InBndr)
simplNonRecBndr SimplEnv
env InBndr
bndr
; (SimplFloats
floats, Expr InBndr
expr') <- SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplLam SimplEnv
env1 Expr InBndr
body SimplCont
cont
; let expr'' :: Expr InBndr
expr'' = SimplFloats -> Expr InBndr -> Expr InBndr
wrapFloats SimplFloats
floats Expr InBndr
expr'
; let case_expr :: Expr InBndr
case_expr = Expr InBndr -> InBndr -> OutType -> [Alt InBndr] -> Expr InBndr
forall b. Expr b -> b -> OutType -> [Alt b] -> Expr b
Case Expr InBndr
rhs InBndr
bndr1 (SimplCont -> OutType
contResultType SimplCont
cont) [AltCon -> [InBndr] -> Expr InBndr -> Alt InBndr
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] Expr InBndr
expr'']
; (SimplFloats, Expr InBndr) -> SimplM (SimplFloats, Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplEnv -> SimplFloats
emptyFloats SimplEnv
env, Expr InBndr
case_expr) }
| Bool
otherwise
= do { (SimplFloats
floats1, SimplEnv
env') <- SimplEnv -> InBndr -> Expr InBndr -> SimplM (SimplFloats, SimplEnv)
simplNonRecX SimplEnv
env InBndr
bndr Expr InBndr
rhs
; (SimplFloats
floats2, Expr InBndr
expr') <- SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplLam SimplEnv
env' Expr InBndr
body SimplCont
cont
; (SimplFloats, Expr InBndr) -> SimplM (SimplFloats, Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplFloats
floats1 SimplFloats -> SimplFloats -> SimplFloats
`addFloats` SimplFloats
floats2, Expr InBndr
expr') }
simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont
-> SimplM (SimplFloats, OutExpr)
simplCast :: SimplEnv
-> Expr InBndr
-> Coercion
-> SimplCont
-> SimplM (SimplFloats, Expr InBndr)
simplCast SimplEnv
env Expr InBndr
body Coercion
co0 SimplCont
cont0
= do { Coercion
co1 <- {-#SCC "simplCast-simplCoercion" #-} SimplEnv -> Coercion -> SimplM Coercion
simplCoercion SimplEnv
env Coercion
co0
; SimplCont
cont1 <- {-#SCC "simplCast-addCoerce" #-}
if Coercion -> Bool
isReflCo Coercion
co1
then SimplCont -> SimplM SimplCont
forall (m :: * -> *) a. Monad m => a -> m a
return SimplCont
cont0
else Coercion -> SimplCont -> SimplM SimplCont
addCoerce Coercion
co1 SimplCont
cont0
; {-#SCC "simplCast-simplExprF" #-} SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplExprF SimplEnv
env Expr InBndr
body SimplCont
cont1 }
where
addCoerceM :: MOutCoercion -> SimplCont -> SimplM SimplCont
addCoerceM :: MOutCoercion -> SimplCont -> SimplM SimplCont
addCoerceM MOutCoercion
MRefl SimplCont
cont = SimplCont -> SimplM SimplCont
forall (m :: * -> *) a. Monad m => a -> m a
return SimplCont
cont
addCoerceM (MCo Coercion
co) SimplCont
cont = Coercion -> SimplCont -> SimplM SimplCont
addCoerce Coercion
co SimplCont
cont
addCoerce :: OutCoercion -> SimplCont -> SimplM SimplCont
addCoerce :: Coercion -> SimplCont -> SimplM SimplCont
addCoerce Coercion
co1 (CastIt Coercion
co2 SimplCont
cont)
| Coercion -> Bool
isReflexiveCo Coercion
co' = SimplCont -> SimplM SimplCont
forall (m :: * -> *) a. Monad m => a -> m a
return SimplCont
cont
| Bool
otherwise = Coercion -> SimplCont -> SimplM SimplCont
addCoerce Coercion
co' SimplCont
cont
where
co' :: Coercion
co' = Coercion -> Coercion -> Coercion
mkTransCo Coercion
co1 Coercion
co2
addCoerce Coercion
co (ApplyToTy { sc_arg_ty :: SimplCont -> OutType
sc_arg_ty = OutType
arg_ty, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
tail })
| Just (OutType
arg_ty', MOutCoercion
m_co') <- Coercion -> OutType -> Maybe (OutType, MOutCoercion)
pushCoTyArg Coercion
co OutType
arg_ty
= {-#SCC "addCoerce-pushCoTyArg" #-}
do { SimplCont
tail' <- MOutCoercion -> SimplCont -> SimplM SimplCont
addCoerceM MOutCoercion
m_co' SimplCont
tail
; SimplCont -> SimplM SimplCont
forall (m :: * -> *) a. Monad m => a -> m a
return (ApplyToTy :: OutType -> OutType -> SimplCont -> SimplCont
ApplyToTy { sc_arg_ty :: OutType
sc_arg_ty = OutType
arg_ty'
, sc_cont :: SimplCont
sc_cont = SimplCont
tail'
, sc_hole_ty :: OutType
sc_hole_ty = Coercion -> OutType
coercionLKind Coercion
co }) }
addCoerce Coercion
co cont :: SimplCont
cont@(ApplyToVal { sc_arg :: SimplCont -> Expr InBndr
sc_arg = Expr InBndr
arg, sc_env :: SimplCont -> SimplEnv
sc_env = SimplEnv
arg_se
, sc_dup :: SimplCont -> DupFlag
sc_dup = DupFlag
dup, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
tail })
| Just (MOutCoercion
m_co1, MOutCoercion
m_co2) <- Coercion -> Maybe (MOutCoercion, MOutCoercion)
pushCoValArg Coercion
co
, MOutCoercion -> Bool
fixed_rep MOutCoercion
m_co1
= {-#SCC "addCoerce-pushCoValArg" #-}
do { SimplCont
tail' <- MOutCoercion -> SimplCont -> SimplM SimplCont
addCoerceM MOutCoercion
m_co2 SimplCont
tail
; case MOutCoercion
m_co1 of {
MOutCoercion
MRefl -> SimplCont -> SimplM SimplCont
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplCont
cont { sc_cont :: SimplCont
sc_cont = SimplCont
tail'
, sc_hole_ty :: OutType
sc_hole_ty = Coercion -> OutType
coercionLKind Coercion
co }) ;
MCo Coercion
co1 ->
do { (DupFlag
dup', SimplEnv
arg_se', Expr InBndr
arg') <- SimplEnv
-> DupFlag
-> SimplEnv
-> Expr InBndr
-> SimplM (DupFlag, SimplEnv, Expr InBndr)
simplArg SimplEnv
env DupFlag
dup SimplEnv
arg_se Expr InBndr
arg
; SimplCont -> SimplM SimplCont
forall (m :: * -> *) a. Monad m => a -> m a
return (ApplyToVal :: DupFlag
-> OutType -> Expr InBndr -> SimplEnv -> SimplCont -> SimplCont
ApplyToVal { sc_arg :: Expr InBndr
sc_arg = Expr InBndr -> Coercion -> Expr InBndr
mkCast Expr InBndr
arg' Coercion
co1
, sc_env :: SimplEnv
sc_env = SimplEnv
arg_se'
, sc_dup :: DupFlag
sc_dup = DupFlag
dup'
, sc_cont :: SimplCont
sc_cont = SimplCont
tail'
, sc_hole_ty :: OutType
sc_hole_ty = Coercion -> OutType
coercionLKind Coercion
co }) } } }
addCoerce Coercion
co SimplCont
cont
| Coercion -> Bool
isReflexiveCo Coercion
co = SimplCont -> SimplM SimplCont
forall (m :: * -> *) a. Monad m => a -> m a
return SimplCont
cont
| Bool
otherwise = SimplCont -> SimplM SimplCont
forall (m :: * -> *) a. Monad m => a -> m a
return (Coercion -> SimplCont -> SimplCont
CastIt Coercion
co SimplCont
cont)
fixed_rep :: MCoercionR -> Bool
fixed_rep :: MOutCoercion -> Bool
fixed_rep MOutCoercion
MRefl = Bool
True
fixed_rep (MCo Coercion
co) = OutType -> Bool
typeHasFixedRuntimeRep (OutType -> Bool) -> OutType -> Bool
forall a b. (a -> b) -> a -> b
$ Coercion -> OutType
coercionRKind Coercion
co
simplArg :: SimplEnv -> DupFlag -> StaticEnv -> CoreExpr
-> SimplM (DupFlag, StaticEnv, OutExpr)
simplArg :: SimplEnv
-> DupFlag
-> SimplEnv
-> Expr InBndr
-> SimplM (DupFlag, SimplEnv, Expr InBndr)
simplArg SimplEnv
env DupFlag
dup_flag SimplEnv
arg_env Expr InBndr
arg
| DupFlag -> Bool
isSimplified DupFlag
dup_flag
= (DupFlag, SimplEnv, Expr InBndr)
-> SimplM (DupFlag, SimplEnv, Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (DupFlag
dup_flag, SimplEnv
arg_env, Expr InBndr
arg)
| Bool
otherwise
= do { let arg_env' :: SimplEnv
arg_env' = SimplEnv
arg_env SimplEnv -> SimplEnv -> SimplEnv
`setInScopeFromE` SimplEnv
env
; Expr InBndr
arg' <- SimplEnv -> Expr InBndr -> SimplM (Expr InBndr)
simplExpr SimplEnv
arg_env' Expr InBndr
arg
; (DupFlag, SimplEnv, Expr InBndr)
-> SimplM (DupFlag, SimplEnv, Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (DupFlag
Simplified, SimplEnv -> SimplEnv
zapSubstEnv SimplEnv
arg_env', Expr InBndr
arg') }
simplLam :: SimplEnv -> InExpr -> SimplCont
-> SimplM (SimplFloats, OutExpr)
simplLam :: SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplLam SimplEnv
env (Lam InBndr
bndr Expr InBndr
body) SimplCont
cont = SimplEnv
-> InBndr
-> Expr InBndr
-> SimplCont
-> SimplM (SimplFloats, Expr InBndr)
simpl_lam SimplEnv
env InBndr
bndr Expr InBndr
body SimplCont
cont
simplLam SimplEnv
env Expr InBndr
expr SimplCont
cont = SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplExprF SimplEnv
env Expr InBndr
expr SimplCont
cont
simpl_lam :: SimplEnv -> InBndr -> InExpr -> SimplCont
-> SimplM (SimplFloats, OutExpr)
simpl_lam :: SimplEnv
-> InBndr
-> Expr InBndr
-> SimplCont
-> SimplM (SimplFloats, Expr InBndr)
simpl_lam SimplEnv
env InBndr
bndr Expr InBndr
body (ApplyToTy { sc_arg_ty :: SimplCont -> OutType
sc_arg_ty = OutType
arg_ty, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont })
= do { Tick -> SimplM ()
tick (InBndr -> Tick
BetaReduction InBndr
bndr)
; SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplLam (SimplEnv -> InBndr -> OutType -> SimplEnv
extendTvSubst SimplEnv
env InBndr
bndr OutType
arg_ty) Expr InBndr
body SimplCont
cont }
simpl_lam SimplEnv
env InBndr
bndr Expr InBndr
body (ApplyToVal { sc_arg :: SimplCont -> Expr InBndr
sc_arg = Expr InBndr
arg, sc_env :: SimplCont -> SimplEnv
sc_env = SimplEnv
arg_se
, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont, sc_dup :: SimplCont -> DupFlag
sc_dup = DupFlag
dup })
| DupFlag -> Bool
isSimplified DupFlag
dup
= do { Tick -> SimplM ()
tick (InBndr -> Tick
BetaReduction InBndr
bndr)
; SimplEnv
-> InBndr
-> Expr InBndr
-> Expr InBndr
-> SimplCont
-> SimplM (SimplFloats, Expr InBndr)
completeBindX SimplEnv
env InBndr
bndr Expr InBndr
arg Expr InBndr
body SimplCont
cont }
| Bool
otherwise
= do { Tick -> SimplM ()
tick (InBndr -> Tick
BetaReduction InBndr
bndr)
; SimplEnv
-> InBndr
-> (Expr InBndr, SimplEnv)
-> Expr InBndr
-> SimplCont
-> SimplM (SimplFloats, Expr InBndr)
simplNonRecE SimplEnv
env InBndr
bndr (Expr InBndr
arg, SimplEnv
arg_se) Expr InBndr
body SimplCont
cont }
simpl_lam SimplEnv
env InBndr
bndr Expr InBndr
body (TickIt CoreTickish
tickish SimplCont
cont)
| Bool -> Bool
not (CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishCounts CoreTickish
tickish)
= SimplEnv
-> InBndr
-> Expr InBndr
-> SimplCont
-> SimplM (SimplFloats, Expr InBndr)
simpl_lam SimplEnv
env InBndr
bndr Expr InBndr
body SimplCont
cont
simpl_lam SimplEnv
env InBndr
bndr Expr InBndr
body SimplCont
cont
= do { let ([InBndr]
inner_bndrs, Expr InBndr
inner_body) = Expr InBndr -> ([InBndr], Expr InBndr)
forall b. Expr b -> ([b], Expr b)
collectBinders Expr InBndr
body
; (SimplEnv
env', [InBndr]
bndrs') <- SimplEnv -> [InBndr] -> SimplM (SimplEnv, [InBndr])
simplLamBndrs SimplEnv
env (InBndr
bndrInBndr -> [InBndr] -> [InBndr]
forall a. a -> [a] -> [a]
:[InBndr]
inner_bndrs)
; Expr InBndr
body' <- SimplEnv -> Expr InBndr -> SimplM (Expr InBndr)
simplExpr SimplEnv
env' Expr InBndr
inner_body
; Expr InBndr
new_lam <- SimplEnv
-> [InBndr] -> Expr InBndr -> SimplCont -> SimplM (Expr InBndr)
mkLam SimplEnv
env' [InBndr]
bndrs' Expr InBndr
body' SimplCont
cont
; SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
rebuild SimplEnv
env' Expr InBndr
new_lam SimplCont
cont }
simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, InBndr)
simplLamBndr SimplEnv
env InBndr
bndr = SimplEnv -> InBndr -> SimplM (SimplEnv, InBndr)
simplBinder SimplEnv
env InBndr
bndr
simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [InBndr])
simplLamBndrs SimplEnv
env [InBndr]
bndrs = (SimplEnv -> InBndr -> SimplM (SimplEnv, InBndr))
-> SimplEnv -> [InBndr] -> SimplM (SimplEnv, [InBndr])
forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM SimplEnv -> InBndr -> SimplM (SimplEnv, InBndr)
simplLamBndr SimplEnv
env [InBndr]
bndrs
simplNonRecE :: SimplEnv
-> InId
-> (InExpr, SimplEnv)
-> InExpr
-> SimplCont
-> SimplM (SimplFloats, OutExpr)
simplNonRecE :: SimplEnv
-> InBndr
-> (Expr InBndr, SimplEnv)
-> Expr InBndr
-> SimplCont
-> SimplM (SimplFloats, Expr InBndr)
simplNonRecE SimplEnv
env InBndr
bndr (Expr InBndr
rhs, SimplEnv
rhs_se) Expr InBndr
body SimplCont
cont
= Bool
-> SimplM (SimplFloats, Expr InBndr)
-> SimplM (SimplFloats, Expr InBndr)
forall a. HasCallStack => Bool -> a -> a
assert (InBndr -> Bool
isId InBndr
bndr Bool -> Bool -> Bool
&& Bool -> Bool
not (InBndr -> Bool
isJoinId InBndr
bndr) ) (SimplM (SimplFloats, Expr InBndr)
-> SimplM (SimplFloats, Expr InBndr))
-> SimplM (SimplFloats, Expr InBndr)
-> SimplM (SimplFloats, Expr InBndr)
forall a b. (a -> b) -> a -> b
$
do { (SimplEnv
env1, InBndr
bndr1) <- SimplEnv -> InBndr -> SimplM (SimplEnv, InBndr)
simplNonRecBndr SimplEnv
env InBndr
bndr
; let needs_case_binding :: Bool
needs_case_binding = OutType -> Expr InBndr -> Bool
needsCaseBinding (InBndr -> OutType
idType InBndr
bndr1) Expr InBndr
rhs
; if | Bool -> Bool
not Bool
needs_case_binding
, Just SimplEnv
env' <- SimplEnv
-> TopLevelFlag
-> InBndr
-> Expr InBndr
-> SimplEnv
-> Maybe SimplEnv
preInlineUnconditionally SimplEnv
env TopLevelFlag
NotTopLevel InBndr
bndr Expr InBndr
rhs SimplEnv
rhs_se ->
do { Tick -> SimplM ()
tick (InBndr -> Tick
PreInlineUnconditionally InBndr
bndr)
;
SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplLam SimplEnv
env' Expr InBndr
body SimplCont
cont }
| InBndr -> Bool
isStrictId InBndr
bndr1 Bool -> Bool -> Bool
&& SimplMode -> Bool
sm_case_case (SimplEnv -> SimplMode
getMode SimplEnv
env)
Bool -> Bool -> Bool
|| Bool
needs_case_binding ->
SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplExprF (SimplEnv
rhs_se SimplEnv -> SimplEnv -> SimplEnv
`setInScopeFromE` SimplEnv
env) Expr InBndr
rhs
(StrictBind :: DupFlag
-> InBndr -> Expr InBndr -> SimplEnv -> SimplCont -> SimplCont
StrictBind { sc_bndr :: InBndr
sc_bndr = InBndr
bndr, sc_body :: Expr InBndr
sc_body = Expr InBndr
body
, sc_env :: SimplEnv
sc_env = SimplEnv
env, sc_cont :: SimplCont
sc_cont = SimplCont
cont, sc_dup :: DupFlag
sc_dup = DupFlag
NoDup })
| Bool
otherwise ->
do { (SimplEnv
env2, InBndr
bndr2) <- SimplEnv
-> InBndr -> InBndr -> BindContext -> SimplM (SimplEnv, InBndr)
addBndrRules SimplEnv
env1 InBndr
bndr InBndr
bndr1 (TopLevelFlag -> RecFlag -> BindContext
BC_Let TopLevelFlag
NotTopLevel RecFlag
NonRecursive)
; (SimplFloats
floats1, SimplEnv
env3) <- SimplEnv
-> TopLevelFlag
-> RecFlag
-> InBndr
-> InBndr
-> Expr InBndr
-> SimplEnv
-> SimplM (SimplFloats, SimplEnv)
simplLazyBind SimplEnv
env2 TopLevelFlag
NotTopLevel RecFlag
NonRecursive InBndr
bndr InBndr
bndr2 Expr InBndr
rhs SimplEnv
rhs_se
; (SimplFloats
floats2, Expr InBndr
expr') <- SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplLam SimplEnv
env3 Expr InBndr
body SimplCont
cont
; (SimplFloats, Expr InBndr) -> SimplM (SimplFloats, Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplFloats
floats1 SimplFloats -> SimplFloats -> SimplFloats
`addFloats` SimplFloats
floats2, Expr InBndr
expr') } }
simplRecE :: SimplEnv
-> [(InId, InExpr)]
-> InExpr
-> SimplCont
-> SimplM (SimplFloats, OutExpr)
simplRecE :: SimplEnv
-> [(InBndr, Expr InBndr)]
-> Expr InBndr
-> SimplCont
-> SimplM (SimplFloats, Expr InBndr)
simplRecE SimplEnv
env [(InBndr, Expr InBndr)]
pairs Expr InBndr
body SimplCont
cont
= do { let bndrs :: [InBndr]
bndrs = ((InBndr, Expr InBndr) -> InBndr)
-> [(InBndr, Expr InBndr)] -> [InBndr]
forall a b. (a -> b) -> [a] -> [b]
map (InBndr, Expr InBndr) -> InBndr
forall a b. (a, b) -> a
fst [(InBndr, Expr InBndr)]
pairs
; Bool -> SimplM ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert ((InBndr -> Bool) -> [InBndr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not (Bool -> Bool) -> (InBndr -> Bool) -> InBndr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InBndr -> Bool
isJoinId) [InBndr]
bndrs)
; SimplEnv
env1 <- SimplEnv -> [InBndr] -> SimplM SimplEnv
simplRecBndrs SimplEnv
env [InBndr]
bndrs
; (SimplFloats
floats1, SimplEnv
env2) <- SimplEnv
-> BindContext
-> [(InBndr, Expr InBndr)]
-> SimplM (SimplFloats, SimplEnv)
simplRecBind SimplEnv
env1 (TopLevelFlag -> RecFlag -> BindContext
BC_Let TopLevelFlag
NotTopLevel RecFlag
Recursive) [(InBndr, Expr InBndr)]
pairs
; (SimplFloats
floats2, Expr InBndr
expr') <- SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplExprF SimplEnv
env2 Expr InBndr
body SimplCont
cont
; (SimplFloats, Expr InBndr) -> SimplM (SimplFloats, Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplFloats
floats1 SimplFloats -> SimplFloats -> SimplFloats
`addFloats` SimplFloats
floats2, Expr InBndr
expr') }
simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr
-> InExpr -> SimplCont
-> SimplM (SimplFloats, OutExpr)
simplNonRecJoinPoint :: SimplEnv
-> InBndr
-> Expr InBndr
-> Expr InBndr
-> SimplCont
-> SimplM (SimplFloats, Expr InBndr)
simplNonRecJoinPoint SimplEnv
env InBndr
bndr Expr InBndr
rhs Expr InBndr
body SimplCont
cont
| Bool -> Bool -> Bool
forall a. HasCallStack => Bool -> a -> a
assert (InBndr -> Bool
isJoinId InBndr
bndr ) Bool
True
, Just SimplEnv
env' <- SimplEnv
-> TopLevelFlag
-> InBndr
-> Expr InBndr
-> SimplEnv
-> Maybe SimplEnv
preInlineUnconditionally SimplEnv
env TopLevelFlag
NotTopLevel InBndr
bndr Expr InBndr
rhs SimplEnv
env
= do { Tick -> SimplM ()
tick (InBndr -> Tick
PreInlineUnconditionally InBndr
bndr)
; SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplExprF SimplEnv
env' Expr InBndr
body SimplCont
cont }
| Bool
otherwise
= SimplEnv
-> SimplCont
-> (SimplEnv -> SimplCont -> SimplM (SimplFloats, Expr InBndr))
-> SimplM (SimplFloats, Expr InBndr)
wrapJoinCont SimplEnv
env SimplCont
cont ((SimplEnv -> SimplCont -> SimplM (SimplFloats, Expr InBndr))
-> SimplM (SimplFloats, Expr InBndr))
-> (SimplEnv -> SimplCont -> SimplM (SimplFloats, Expr InBndr))
-> SimplM (SimplFloats, Expr InBndr)
forall a b. (a -> b) -> a -> b
$ \ SimplEnv
env SimplCont
cont ->
do {
; let mult :: OutType
mult = SimplCont -> OutType
contHoleScaling SimplCont
cont
res_ty :: OutType
res_ty = SimplCont -> OutType
contResultType SimplCont
cont
; (SimplEnv
env1, InBndr
bndr1) <- SimplEnv
-> InBndr -> OutType -> OutType -> SimplM (SimplEnv, InBndr)
simplNonRecJoinBndr SimplEnv
env InBndr
bndr OutType
mult OutType
res_ty
; (SimplEnv
env2, InBndr
bndr2) <- SimplEnv
-> InBndr -> InBndr -> BindContext -> SimplM (SimplEnv, InBndr)
addBndrRules SimplEnv
env1 InBndr
bndr InBndr
bndr1 (SimplCont -> BindContext
BC_Join SimplCont
cont)
; (SimplFloats
floats1, SimplEnv
env3) <- SimplEnv
-> SimplCont
-> InBndr
-> InBndr
-> Expr InBndr
-> SimplEnv
-> SimplM (SimplFloats, SimplEnv)
simplJoinBind SimplEnv
env2 SimplCont
cont InBndr
bndr InBndr
bndr2 Expr InBndr
rhs SimplEnv
env
; (SimplFloats
floats2, Expr InBndr
body') <- SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplExprF SimplEnv
env3 Expr InBndr
body SimplCont
cont
; (SimplFloats, Expr InBndr) -> SimplM (SimplFloats, Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplFloats
floats1 SimplFloats -> SimplFloats -> SimplFloats
`addFloats` SimplFloats
floats2, Expr InBndr
body') }
simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)]
-> InExpr -> SimplCont
-> SimplM (SimplFloats, OutExpr)
simplRecJoinPoint :: SimplEnv
-> [(InBndr, Expr InBndr)]
-> Expr InBndr
-> SimplCont
-> SimplM (SimplFloats, Expr InBndr)
simplRecJoinPoint SimplEnv
env [(InBndr, Expr InBndr)]
pairs Expr InBndr
body SimplCont
cont
= SimplEnv
-> SimplCont
-> (SimplEnv -> SimplCont -> SimplM (SimplFloats, Expr InBndr))
-> SimplM (SimplFloats, Expr InBndr)
wrapJoinCont SimplEnv
env SimplCont
cont ((SimplEnv -> SimplCont -> SimplM (SimplFloats, Expr InBndr))
-> SimplM (SimplFloats, Expr InBndr))
-> (SimplEnv -> SimplCont -> SimplM (SimplFloats, Expr InBndr))
-> SimplM (SimplFloats, Expr InBndr)
forall a b. (a -> b) -> a -> b
$ \ SimplEnv
env SimplCont
cont ->
do { let bndrs :: [InBndr]
bndrs = ((InBndr, Expr InBndr) -> InBndr)
-> [(InBndr, Expr InBndr)] -> [InBndr]
forall a b. (a -> b) -> [a] -> [b]
map (InBndr, Expr InBndr) -> InBndr
forall a b. (a, b) -> a
fst [(InBndr, Expr InBndr)]
pairs
mult :: OutType
mult = SimplCont -> OutType
contHoleScaling SimplCont
cont
res_ty :: OutType
res_ty = SimplCont -> OutType
contResultType SimplCont
cont
; SimplEnv
env1 <- SimplEnv -> [InBndr] -> OutType -> OutType -> SimplM SimplEnv
simplRecJoinBndrs SimplEnv
env [InBndr]
bndrs OutType
mult OutType
res_ty
; (SimplFloats
floats1, SimplEnv
env2) <- SimplEnv
-> BindContext
-> [(InBndr, Expr InBndr)]
-> SimplM (SimplFloats, SimplEnv)
simplRecBind SimplEnv
env1 (SimplCont -> BindContext
BC_Join SimplCont
cont) [(InBndr, Expr InBndr)]
pairs
; (SimplFloats
floats2, Expr InBndr
body') <- SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplExprF SimplEnv
env2 Expr InBndr
body SimplCont
cont
; (SimplFloats, Expr InBndr) -> SimplM (SimplFloats, Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplFloats
floats1 SimplFloats -> SimplFloats -> SimplFloats
`addFloats` SimplFloats
floats2, Expr InBndr
body') }
wrapJoinCont :: SimplEnv -> SimplCont
-> (SimplEnv -> SimplCont -> SimplM (SimplFloats, OutExpr))
-> SimplM (SimplFloats, OutExpr)
wrapJoinCont :: SimplEnv
-> SimplCont
-> (SimplEnv -> SimplCont -> SimplM (SimplFloats, Expr InBndr))
-> SimplM (SimplFloats, Expr InBndr)
wrapJoinCont SimplEnv
env SimplCont
cont SimplEnv -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
thing_inside
| SimplCont -> Bool
contIsStop SimplCont
cont
= SimplEnv -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
thing_inside SimplEnv
env SimplCont
cont
| Bool -> Bool
not (SimplMode -> Bool
sm_case_case (SimplEnv -> SimplMode
getMode SimplEnv
env))
= do { (SimplFloats
floats1, Expr InBndr
expr1) <- SimplEnv -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
thing_inside SimplEnv
env (OutType -> SimplCont
mkBoringStop (SimplCont -> OutType
contHoleType SimplCont
cont))
; let (SimplFloats
floats2, Expr InBndr
expr2) = SimplFloats -> Expr InBndr -> (SimplFloats, Expr InBndr)
wrapJoinFloatsX SimplFloats
floats1 Expr InBndr
expr1
; (SimplFloats
floats3, Expr InBndr
expr3) <- SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
rebuild (SimplEnv
env SimplEnv -> SimplFloats -> SimplEnv
`setInScopeFromF` SimplFloats
floats2) Expr InBndr
expr2 SimplCont
cont
; (SimplFloats, Expr InBndr) -> SimplM (SimplFloats, Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplFloats
floats2 SimplFloats -> SimplFloats -> SimplFloats
`addFloats` SimplFloats
floats3, Expr InBndr
expr3) }
| Bool
otherwise
= do { (SimplFloats
floats1, SimplCont
cont') <- SimplEnv -> SimplCont -> SimplM (SimplFloats, SimplCont)
mkDupableCont SimplEnv
env SimplCont
cont
; (SimplFloats
floats2, Expr InBndr
result) <- SimplEnv -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
thing_inside (SimplEnv
env SimplEnv -> SimplFloats -> SimplEnv
`setInScopeFromF` SimplFloats
floats1) SimplCont
cont'
; (SimplFloats, Expr InBndr) -> SimplM (SimplFloats, Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplFloats
floats1 SimplFloats -> SimplFloats -> SimplFloats
`addFloats` SimplFloats
floats2, Expr InBndr
result) }
trimJoinCont :: Id -> Maybe JoinArity -> SimplCont -> SimplCont
trimJoinCont :: InBndr -> Maybe JoinArity -> SimplCont -> SimplCont
trimJoinCont InBndr
_ Maybe JoinArity
Nothing SimplCont
cont
= SimplCont
cont
trimJoinCont InBndr
var (Just JoinArity
arity) SimplCont
cont
= JoinArity -> SimplCont -> SimplCont
trim JoinArity
arity SimplCont
cont
where
trim :: JoinArity -> SimplCont -> SimplCont
trim JoinArity
0 cont :: SimplCont
cont@(Stop {})
= SimplCont
cont
trim JoinArity
0 SimplCont
cont
= OutType -> SimplCont
mkBoringStop (SimplCont -> OutType
contResultType SimplCont
cont)
trim JoinArity
n cont :: SimplCont
cont@(ApplyToVal { sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
k })
= SimplCont
cont { sc_cont :: SimplCont
sc_cont = JoinArity -> SimplCont -> SimplCont
trim (JoinArity
nJoinArity -> JoinArity -> JoinArity
forall a. Num a => a -> a -> a
-JoinArity
1) SimplCont
k }
trim JoinArity
n cont :: SimplCont
cont@(ApplyToTy { sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
k })
= SimplCont
cont { sc_cont :: SimplCont
sc_cont = JoinArity -> SimplCont -> SimplCont
trim (JoinArity
nJoinArity -> JoinArity -> JoinArity
forall a. Num a => a -> a -> a
-JoinArity
1) SimplCont
k }
trim JoinArity
_ SimplCont
cont
= String -> SDoc -> SimplCont
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"completeCall" (SDoc -> SimplCont) -> SDoc -> SimplCont
forall a b. (a -> b) -> a -> b
$ InBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr InBndr
var SDoc -> SDoc -> SDoc
$$ SimplCont -> SDoc
forall a. Outputable a => a -> SDoc
ppr SimplCont
cont
simplVar :: SimplEnv -> InVar -> SimplM OutExpr
simplVar :: SimplEnv -> InBndr -> SimplM (Expr InBndr)
simplVar SimplEnv
env InBndr
var
| InBndr -> Bool
isTyVar InBndr
var = Expr InBndr -> SimplM (Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr InBndr -> SimplM (Expr InBndr))
-> Expr InBndr -> SimplM (Expr InBndr)
forall a b. (a -> b) -> a -> b
$! OutType -> Expr InBndr
forall b. OutType -> Expr b
Type (OutType -> Expr InBndr) -> OutType -> Expr InBndr
forall a b. (a -> b) -> a -> b
$! (SimplEnv -> InBndr -> OutType
substTyVar SimplEnv
env InBndr
var)
| InBndr -> Bool
isCoVar InBndr
var = Expr InBndr -> SimplM (Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr InBndr -> SimplM (Expr InBndr))
-> Expr InBndr -> SimplM (Expr InBndr)
forall a b. (a -> b) -> a -> b
$! Coercion -> Expr InBndr
forall b. Coercion -> Expr b
Coercion (Coercion -> Expr InBndr) -> Coercion -> Expr InBndr
forall a b. (a -> b) -> a -> b
$! (SimplEnv -> InBndr -> Coercion
substCoVar SimplEnv
env InBndr
var)
| Bool
otherwise
= case SimplEnv -> InBndr -> SimplSR
substId SimplEnv
env InBndr
var of
ContEx TvSubstEnv
tvs CvSubstEnv
cvs SimplIdSubst
ids Expr InBndr
e -> let env' :: SimplEnv
env' = SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv
setSubstEnv SimplEnv
env TvSubstEnv
tvs CvSubstEnv
cvs SimplIdSubst
ids
in SimplEnv -> Expr InBndr -> SimplM (Expr InBndr)
simplExpr SimplEnv
env' Expr InBndr
e
DoneId InBndr
var1 -> Expr InBndr -> SimplM (Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (InBndr -> Expr InBndr
forall b. InBndr -> Expr b
Var InBndr
var1)
DoneEx Expr InBndr
e Maybe JoinArity
_ -> Expr InBndr -> SimplM (Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr InBndr
e
simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr)
simplIdF :: SimplEnv
-> InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplIdF SimplEnv
env InBndr
var SimplCont
cont
= case SimplEnv -> InBndr -> SimplSR
substId SimplEnv
env InBndr
var of
ContEx TvSubstEnv
tvs CvSubstEnv
cvs SimplIdSubst
ids Expr InBndr
e ->
let env' :: SimplEnv
env' = SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv
setSubstEnv SimplEnv
env TvSubstEnv
tvs CvSubstEnv
cvs SimplIdSubst
ids
in SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplExprF SimplEnv
env' Expr InBndr
e SimplCont
cont
DoneId InBndr
var1 ->
let cont' :: SimplCont
cont' = InBndr -> Maybe JoinArity -> SimplCont -> SimplCont
trimJoinCont InBndr
var (InBndr -> Maybe JoinArity
isJoinId_maybe InBndr
var1) SimplCont
cont
in SimplEnv
-> InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
completeCall SimplEnv
env InBndr
var1 SimplCont
cont'
DoneEx Expr InBndr
e Maybe JoinArity
mb_join ->
let env' :: SimplEnv
env' = SimplEnv -> SimplEnv
zapSubstEnv SimplEnv
env
cont' :: SimplCont
cont' = InBndr -> Maybe JoinArity -> SimplCont -> SimplCont
trimJoinCont InBndr
var Maybe JoinArity
mb_join SimplCont
cont
in SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplExprF SimplEnv
env' Expr InBndr
e SimplCont
cont'
completeCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr)
completeCall :: SimplEnv
-> InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
completeCall SimplEnv
env InBndr
var SimplCont
cont
| Just Expr InBndr
expr <- Logger
-> UnfoldingOpts
-> JoinArity
-> InBndr
-> Bool
-> Bool
-> [ArgSummary]
-> CallCtxt
-> Maybe (Expr InBndr)
callSiteInline Logger
logger UnfoldingOpts
uf_opts JoinArity
case_depth InBndr
var Bool
active_unf
Bool
lone_variable [ArgSummary]
arg_infos CallCtxt
interesting_cont
= do { Tick -> SimplM ()
checkedTick (InBndr -> Tick
UnfoldingDone InBndr
var)
; Expr InBndr -> SimplCont -> SimplM ()
dump_inline Expr InBndr
expr SimplCont
cont
; let env1 :: SimplEnv
env1 = SimplEnv -> SimplEnv
zapSubstEnv SimplEnv
env
; SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplExprF SimplEnv
env1 Expr InBndr
expr SimplCont
cont }
| Bool
otherwise
= do { RuleEnv
rule_base <- SimplM RuleEnv
getSimplRules
; let rules :: [CoreRule]
rules = RuleEnv -> InBndr -> [CoreRule]
getRules RuleEnv
rule_base InBndr
var
info :: ArgInfo
info = SimplEnv
-> InBndr -> [CoreRule] -> JoinArity -> SimplCont -> ArgInfo
mkArgInfo SimplEnv
env InBndr
var [CoreRule]
rules
JoinArity
n_val_args SimplCont
call_cont
; SimplEnv
-> ArgInfo -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
rebuildCall SimplEnv
env ArgInfo
info SimplCont
cont }
where
uf_opts :: UnfoldingOpts
uf_opts = SimplEnv -> UnfoldingOpts
seUnfoldingOpts SimplEnv
env
case_depth :: JoinArity
case_depth = SimplEnv -> JoinArity
seCaseDepth SimplEnv
env
logger :: Logger
logger = SimplEnv -> Logger
seLogger SimplEnv
env
(Bool
lone_variable, [ArgSummary]
arg_infos, SimplCont
call_cont) = SimplCont -> (Bool, [ArgSummary], SimplCont)
contArgs SimplCont
cont
n_val_args :: JoinArity
n_val_args = [ArgSummary] -> JoinArity
forall (t :: * -> *) a. Foldable t => t a -> JoinArity
length [ArgSummary]
arg_infos
interesting_cont :: CallCtxt
interesting_cont = SimplEnv -> SimplCont -> CallCtxt
interestingCallContext SimplEnv
env SimplCont
call_cont
active_unf :: Bool
active_unf = SimplMode -> InBndr -> Bool
activeUnfolding (SimplEnv -> SimplMode
getMode SimplEnv
env) InBndr
var
log_inlining :: SDoc -> SimplM ()
log_inlining SDoc
doc
= IO () -> SimplM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SimplM ()) -> IO () -> SimplM ()
forall a b. (a -> b) -> a -> b
$ Logger
-> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
logDumpFile Logger
logger (PrintUnqualified -> PprStyle
mkDumpStyle PrintUnqualified
alwaysQualify)
DumpFlag
Opt_D_dump_inlinings
String
"" DumpFormat
FormatText SDoc
doc
dump_inline :: Expr InBndr -> SimplCont -> SimplM ()
dump_inline Expr InBndr
unfolding SimplCont
cont
| Bool -> Bool
not (Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_dump_inlinings) = () -> SimplM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool -> Bool
not (Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_verbose_core2core)
= Bool -> SimplM () -> SimplM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name -> Bool
isExternalName (InBndr -> Name
idName InBndr
var)) (SimplM () -> SimplM ()) -> SimplM () -> SimplM ()
forall a b. (a -> b) -> a -> b
$
SDoc -> SimplM ()
log_inlining (SDoc -> SimplM ()) -> SDoc -> SimplM ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
sep [String -> SDoc
text String
"Inlining done:", JoinArity -> SDoc -> SDoc
nest JoinArity
4 (InBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr InBndr
var)]
| Bool
otherwise
= SDoc -> SimplM ()
log_inlining (SDoc -> SimplM ()) -> SDoc -> SimplM ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
sep [String -> SDoc
text String
"Inlining done: " SDoc -> SDoc -> SDoc
<> InBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr InBndr
var,
JoinArity -> SDoc -> SDoc
nest JoinArity
4 ([SDoc] -> SDoc
vcat [String -> SDoc
text String
"Inlined fn: " SDoc -> SDoc -> SDoc
<+> JoinArity -> SDoc -> SDoc
nest JoinArity
2 (Expr InBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr Expr InBndr
unfolding),
String -> SDoc
text String
"Cont: " SDoc -> SDoc -> SDoc
<+> SimplCont -> SDoc
forall a. Outputable a => a -> SDoc
ppr SimplCont
cont])]
rebuildCall :: SimplEnv
-> ArgInfo
-> SimplCont
-> SimplM (SimplFloats, OutExpr)
rebuildCall :: SimplEnv
-> ArgInfo -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
rebuildCall SimplEnv
env (ArgInfo { ai_fun :: ArgInfo -> InBndr
ai_fun = InBndr
fun, ai_args :: ArgInfo -> [ArgSpec]
ai_args = [ArgSpec]
rev_args, ai_dmds :: ArgInfo -> [Demand]
ai_dmds = [] }) SimplCont
cont
| Bool -> Bool
not (SimplCont -> Bool
contIsTrivial SimplCont
cont)
= OutType -> ()
seqType OutType
cont_ty ()
-> SimplM (SimplFloats, Expr InBndr)
-> SimplM (SimplFloats, Expr InBndr)
`seq`
(SimplFloats, Expr InBndr) -> SimplM (SimplFloats, Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplEnv -> SimplFloats
emptyFloats SimplEnv
env, Expr InBndr -> OutType -> Expr InBndr
castBottomExpr Expr InBndr
res OutType
cont_ty)
where
res :: Expr InBndr
res = InBndr -> [ArgSpec] -> Expr InBndr
argInfoExpr InBndr
fun [ArgSpec]
rev_args
cont_ty :: OutType
cont_ty = SimplCont -> OutType
contResultType SimplCont
cont
rebuildCall SimplEnv
env info :: ArgInfo
info@(ArgInfo { ai_fun :: ArgInfo -> InBndr
ai_fun = InBndr
fun, ai_args :: ArgInfo -> [ArgSpec]
ai_args = [ArgSpec]
rev_args
, ai_rules :: ArgInfo -> FunRules
ai_rules = Just (JoinArity
nr_wanted, [CoreRule]
rules) }) SimplCont
cont
| JoinArity
nr_wanted JoinArity -> JoinArity -> Bool
forall a. Eq a => a -> a -> Bool
== JoinArity
0 Bool -> Bool -> Bool
|| Bool
no_more_args
, let info' :: ArgInfo
info' = ArgInfo
info { ai_rules :: FunRules
ai_rules = FunRules
forall a. Maybe a
Nothing }
=
do { Maybe (SimplEnv, Expr InBndr, SimplCont)
mb_match <- SimplEnv
-> [CoreRule]
-> InBndr
-> [ArgSpec]
-> SimplCont
-> SimplM (Maybe (SimplEnv, Expr InBndr, SimplCont))
tryRules SimplEnv
env [CoreRule]
rules InBndr
fun ([ArgSpec] -> [ArgSpec]
forall a. [a] -> [a]
reverse [ArgSpec]
rev_args) SimplCont
cont
; case Maybe (SimplEnv, Expr InBndr, SimplCont)
mb_match of
Just (SimplEnv
env', Expr InBndr
rhs, SimplCont
cont') -> SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplExprF SimplEnv
env' Expr InBndr
rhs SimplCont
cont'
Maybe (SimplEnv, Expr InBndr, SimplCont)
Nothing -> SimplEnv
-> ArgInfo -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
rebuildCall SimplEnv
env ArgInfo
info' SimplCont
cont }
where
no_more_args :: Bool
no_more_args = case SimplCont
cont of
ApplyToTy {} -> Bool
False
ApplyToVal {} -> Bool
False
SimplCont
_ -> Bool
True
rebuildCall SimplEnv
env ArgInfo
info (CastIt Coercion
co SimplCont
cont)
= SimplEnv
-> ArgInfo -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
rebuildCall SimplEnv
env (ArgInfo -> Coercion -> ArgInfo
addCastTo ArgInfo
info Coercion
co) SimplCont
cont
rebuildCall SimplEnv
env ArgInfo
info (ApplyToTy { sc_arg_ty :: SimplCont -> OutType
sc_arg_ty = OutType
arg_ty, sc_hole_ty :: SimplCont -> OutType
sc_hole_ty = OutType
hole_ty, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont })
= SimplEnv
-> ArgInfo -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
rebuildCall SimplEnv
env (ArgInfo -> OutType -> OutType -> ArgInfo
addTyArgTo ArgInfo
info OutType
arg_ty OutType
hole_ty) SimplCont
cont
rebuildCall SimplEnv
env (ArgInfo { ai_fun :: ArgInfo -> InBndr
ai_fun = InBndr
fun_id, ai_args :: ArgInfo -> [ArgSpec]
ai_args = [ArgSpec]
rev_args })
(ApplyToVal { sc_arg :: SimplCont -> Expr InBndr
sc_arg = Expr InBndr
arg, sc_env :: SimplCont -> SimplEnv
sc_env = SimplEnv
arg_se
, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont, sc_hole_ty :: SimplCont -> OutType
sc_hole_ty = OutType
fun_ty })
| InBndr
fun_id InBndr -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
runRWKey
, Bool -> Bool
not (SimplCont -> Bool
contIsStop SimplCont
cont)
, [ TyArg {}, TyArg {} ] <- [ArgSpec]
rev_args
= do { InBndr
s <- FastString -> OutType -> OutType -> SimplM InBndr
newId (String -> FastString
fsLit String
"s") OutType
Many OutType
realWorldStatePrimTy
; let (OutType
m,OutType
_,OutType
_) = OutType -> (OutType, OutType, OutType)
splitFunTy OutType
fun_ty
env' :: SimplEnv
env' = (SimplEnv
arg_se SimplEnv -> SimplEnv -> SimplEnv
`setInScopeFromE` SimplEnv
env) SimplEnv -> [InBndr] -> SimplEnv
`addNewInScopeIds` [InBndr
s]
ty' :: OutType
ty' = SimplCont -> OutType
contResultType SimplCont
cont
cont' :: SimplCont
cont' = ApplyToVal :: DupFlag
-> OutType -> Expr InBndr -> SimplEnv -> SimplCont -> SimplCont
ApplyToVal { sc_dup :: DupFlag
sc_dup = DupFlag
Simplified, sc_arg :: Expr InBndr
sc_arg = InBndr -> Expr InBndr
forall b. InBndr -> Expr b
Var InBndr
s
, sc_env :: SimplEnv
sc_env = SimplEnv
env', sc_cont :: SimplCont
sc_cont = SimplCont
cont
, sc_hole_ty :: OutType
sc_hole_ty = OutType -> OutType -> OutType -> OutType
mkVisFunTy OutType
m OutType
realWorldStatePrimTy OutType
ty' }
; Expr InBndr
body' <- SimplEnv -> Expr InBndr -> SimplCont -> SimplM (Expr InBndr)
simplExprC SimplEnv
env' Expr InBndr
arg SimplCont
cont'
; let arg' :: Expr InBndr
arg' = InBndr -> Expr InBndr -> Expr InBndr
forall b. b -> Expr b -> Expr b
Lam InBndr
s Expr InBndr
body'
rr' :: OutType
rr' = HasDebugCallStack => OutType -> OutType
OutType -> OutType
getRuntimeRep OutType
ty'
call' :: Expr InBndr
call' = Expr InBndr -> [Expr InBndr] -> Expr InBndr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (InBndr -> Expr InBndr
forall b. InBndr -> Expr b
Var InBndr
fun_id) [OutType -> Expr InBndr
forall b. OutType -> Expr b
mkTyArg OutType
rr', OutType -> Expr InBndr
forall b. OutType -> Expr b
mkTyArg OutType
ty', Expr InBndr
arg']
; (SimplFloats, Expr InBndr) -> SimplM (SimplFloats, Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplEnv -> SimplFloats
emptyFloats SimplEnv
env, Expr InBndr
call') }
rebuildCall SimplEnv
env ArgInfo
fun_info
(ApplyToVal { sc_arg :: SimplCont -> Expr InBndr
sc_arg = Expr InBndr
arg, sc_env :: SimplCont -> SimplEnv
sc_env = SimplEnv
arg_se
, sc_dup :: SimplCont -> DupFlag
sc_dup = DupFlag
dup_flag, sc_hole_ty :: SimplCont -> OutType
sc_hole_ty = OutType
fun_ty
, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont })
| DupFlag -> Bool
isSimplified DupFlag
dup_flag
= SimplEnv
-> ArgInfo -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
rebuildCall SimplEnv
env (ArgInfo -> Expr InBndr -> OutType -> ArgInfo
addValArgTo ArgInfo
fun_info Expr InBndr
arg OutType
fun_ty) SimplCont
cont
| ArgInfo -> Bool
isStrictArgInfo ArgInfo
fun_info
, SimplMode -> Bool
sm_case_case (SimplEnv -> SimplMode
getMode SimplEnv
env)
=
SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplExprF (SimplEnv
arg_se SimplEnv -> SimplEnv -> SimplEnv
`setInScopeFromE` SimplEnv
env) Expr InBndr
arg
(StrictArg :: DupFlag -> ArgInfo -> OutType -> SimplCont -> SimplCont
StrictArg { sc_fun :: ArgInfo
sc_fun = ArgInfo
fun_info, sc_fun_ty :: OutType
sc_fun_ty = OutType
fun_ty
, sc_dup :: DupFlag
sc_dup = DupFlag
Simplified
, sc_cont :: SimplCont
sc_cont = SimplCont
cont })
| Bool
otherwise
= do { Expr InBndr
arg' <- SimplEnv -> Expr InBndr -> SimplCont -> SimplM (Expr InBndr)
simplExprC (SimplEnv
arg_se SimplEnv -> SimplEnv -> SimplEnv
`setInScopeFromE` SimplEnv
env) Expr InBndr
arg
(OutType -> ArgInfo -> SimplCont
mkLazyArgStop OutType
arg_ty ArgInfo
fun_info)
; SimplEnv
-> ArgInfo -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
rebuildCall SimplEnv
env (ArgInfo -> Expr InBndr -> OutType -> ArgInfo
addValArgTo ArgInfo
fun_info Expr InBndr
arg' OutType
fun_ty) SimplCont
cont }
where
arg_ty :: OutType
arg_ty = OutType -> OutType
funArgTy OutType
fun_ty
rebuildCall SimplEnv
env (ArgInfo { ai_fun :: ArgInfo -> InBndr
ai_fun = InBndr
fun, ai_args :: ArgInfo -> [ArgSpec]
ai_args = [ArgSpec]
rev_args }) SimplCont
cont
= SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
rebuild SimplEnv
env (InBndr -> [ArgSpec] -> Expr InBndr
argInfoExpr InBndr
fun [ArgSpec]
rev_args) SimplCont
cont
tryRules :: SimplEnv -> [CoreRule]
-> Id -> [ArgSpec]
-> SimplCont
-> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont))
tryRules :: SimplEnv
-> [CoreRule]
-> InBndr
-> [ArgSpec]
-> SimplCont
-> SimplM (Maybe (SimplEnv, Expr InBndr, SimplCont))
tryRules SimplEnv
env [CoreRule]
rules InBndr
fn [ArgSpec]
args SimplCont
call_cont
| [CoreRule] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreRule]
rules
= Maybe (SimplEnv, Expr InBndr, SimplCont)
-> SimplM (Maybe (SimplEnv, Expr InBndr, SimplCont))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (SimplEnv, Expr InBndr, SimplCont)
forall a. Maybe a
Nothing
| Just (CoreRule
rule, Expr InBndr
rule_rhs) <- RuleOpts
-> InScopeEnv
-> (Activation -> Bool)
-> InBndr
-> [Expr InBndr]
-> [CoreRule]
-> Maybe (CoreRule, Expr InBndr)
lookupRule RuleOpts
ropts (SimplEnv -> InScopeEnv
getUnfoldingInRuleMatch SimplEnv
env)
(SimplMode -> Activation -> Bool
activeRule (SimplEnv -> SimplMode
getMode SimplEnv
env)) InBndr
fn
([ArgSpec] -> [Expr InBndr]
argInfoAppArgs [ArgSpec]
args) [CoreRule]
rules
= do { Tick -> SimplM ()
checkedTick (FastString -> Tick
RuleFired (CoreRule -> FastString
ruleName CoreRule
rule))
; let cont' :: SimplCont
cont' = SimplEnv -> [ArgSpec] -> SimplCont -> SimplCont
pushSimplifiedArgs SimplEnv
zapped_env
(JoinArity -> [ArgSpec] -> [ArgSpec]
forall a. JoinArity -> [a] -> [a]
drop (CoreRule -> JoinArity
ruleArity CoreRule
rule) [ArgSpec]
args)
SimplCont
call_cont
occ_anald_rhs :: Expr InBndr
occ_anald_rhs = Expr InBndr -> Expr InBndr
occurAnalyseExpr Expr InBndr
rule_rhs
; CoreRule -> Expr InBndr -> SimplM ()
dump CoreRule
rule Expr InBndr
rule_rhs
; Maybe (SimplEnv, Expr InBndr, SimplCont)
-> SimplM (Maybe (SimplEnv, Expr InBndr, SimplCont))
forall (m :: * -> *) a. Monad m => a -> m a
return ((SimplEnv, Expr InBndr, SimplCont)
-> Maybe (SimplEnv, Expr InBndr, SimplCont)
forall a. a -> Maybe a
Just (SimplEnv
zapped_env, Expr InBndr
occ_anald_rhs, SimplCont
cont')) }
| Bool
otherwise
= do { SimplM ()
nodump
; Maybe (SimplEnv, Expr InBndr, SimplCont)
-> SimplM (Maybe (SimplEnv, Expr InBndr, SimplCont))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (SimplEnv, Expr InBndr, SimplCont)
forall a. Maybe a
Nothing }
where
ropts :: RuleOpts
ropts = DynFlags -> RuleOpts
initRuleOpts DynFlags
dflags
dflags :: DynFlags
dflags = SimplEnv -> DynFlags
seDynFlags SimplEnv
env
logger :: Logger
logger = SimplEnv -> Logger
seLogger SimplEnv
env
zapped_env :: SimplEnv
zapped_env = SimplEnv -> SimplEnv
zapSubstEnv SimplEnv
env
printRuleModule :: CoreRule -> SDoc
printRuleModule CoreRule
rule
= SDoc -> SDoc
parens (SDoc -> (GenModule Unit -> SDoc) -> Maybe (GenModule Unit) -> SDoc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> SDoc
text String
"BUILTIN")
(ModuleName -> SDoc
pprModuleName (ModuleName -> SDoc)
-> (GenModule Unit -> ModuleName) -> GenModule Unit -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName)
(CoreRule -> Maybe (GenModule Unit)
ruleModule CoreRule
rule))
dump :: CoreRule -> Expr InBndr -> SimplM ()
dump CoreRule
rule Expr InBndr
rule_rhs
| Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_dump_rule_rewrites
= DumpFlag -> String -> SDoc -> SimplM ()
log_rule DumpFlag
Opt_D_dump_rule_rewrites String
"Rule fired" (SDoc -> SimplM ()) -> SDoc -> SimplM ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"Rule:" SDoc -> SDoc -> SDoc
<+> FastString -> SDoc
ftext (CoreRule -> FastString
ruleName CoreRule
rule)
, String -> SDoc
text String
"Module:" SDoc -> SDoc -> SDoc
<+> CoreRule -> SDoc
printRuleModule CoreRule
rule
, String -> SDoc
text String
"Before:" SDoc -> SDoc -> SDoc
<+> SDoc -> JoinArity -> SDoc -> SDoc
hang (InBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr InBndr
fn) JoinArity
2 ([SDoc] -> SDoc
sep ((ArgSpec -> SDoc) -> [ArgSpec] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ArgSpec -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ArgSpec]
args))
, String -> SDoc
text String
"After: " SDoc -> SDoc -> SDoc
<+> SDoc -> JoinArity -> SDoc -> SDoc
hang (Expr InBndr -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr Expr InBndr
rule_rhs) JoinArity
2
([SDoc] -> SDoc
sep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (ArgSpec -> SDoc) -> [ArgSpec] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ArgSpec -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([ArgSpec] -> [SDoc]) -> [ArgSpec] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ JoinArity -> [ArgSpec] -> [ArgSpec]
forall a. JoinArity -> [a] -> [a]
drop (CoreRule -> JoinArity
ruleArity CoreRule
rule) [ArgSpec]
args)
, String -> SDoc
text String
"Cont: " SDoc -> SDoc -> SDoc
<+> SimplCont -> SDoc
forall a. Outputable a => a -> SDoc
ppr SimplCont
call_cont ]
| Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_dump_rule_firings
= DumpFlag -> String -> SDoc -> SimplM ()
log_rule DumpFlag
Opt_D_dump_rule_firings String
"Rule fired:" (SDoc -> SimplM ()) -> SDoc -> SimplM ()
forall a b. (a -> b) -> a -> b
$
FastString -> SDoc
ftext (CoreRule -> FastString
ruleName CoreRule
rule)
SDoc -> SDoc -> SDoc
<+> CoreRule -> SDoc
printRuleModule CoreRule
rule
| Bool
otherwise
= () -> SimplM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
nodump :: SimplM ()
nodump
| Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_dump_rule_rewrites
= IO () -> SimplM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SimplM ()) -> IO () -> SimplM ()
forall a b. (a -> b) -> a -> b
$
Logger -> DumpFlag -> IO ()
touchDumpFile Logger
logger DumpFlag
Opt_D_dump_rule_rewrites
| Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_dump_rule_firings
= IO () -> SimplM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SimplM ()) -> IO () -> SimplM ()
forall a b. (a -> b) -> a -> b
$
Logger -> DumpFlag -> IO ()
touchDumpFile Logger
logger DumpFlag
Opt_D_dump_rule_firings
| Bool
otherwise
= () -> SimplM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
log_rule :: DumpFlag -> String -> SDoc -> SimplM ()
log_rule DumpFlag
flag String
hdr SDoc
details
= IO () -> SimplM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SimplM ()) -> IO () -> SimplM ()
forall a b. (a -> b) -> a -> b
$ Logger
-> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
logDumpFile Logger
logger (PrintUnqualified -> PprStyle
mkDumpStyle PrintUnqualified
alwaysQualify) DumpFlag
flag String
"" DumpFormat
FormatText
(SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
sep [String -> SDoc
text String
hdr, JoinArity -> SDoc -> SDoc
nest JoinArity
4 SDoc
details]
trySeqRules :: SimplEnv
-> OutExpr -> InExpr
-> SimplCont
-> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont))
trySeqRules :: SimplEnv
-> Expr InBndr
-> Expr InBndr
-> SimplCont
-> SimplM (Maybe (SimplEnv, Expr InBndr, SimplCont))
trySeqRules SimplEnv
in_env Expr InBndr
scrut Expr InBndr
rhs SimplCont
cont
= do { RuleEnv
rule_base <- SimplM RuleEnv
getSimplRules
; SimplEnv
-> [CoreRule]
-> InBndr
-> [ArgSpec]
-> SimplCont
-> SimplM (Maybe (SimplEnv, Expr InBndr, SimplCont))
tryRules SimplEnv
in_env (RuleEnv -> InBndr -> [CoreRule]
getRules RuleEnv
rule_base InBndr
seqId) InBndr
seqId [ArgSpec]
out_args SimplCont
rule_cont }
where
no_cast_scrut :: Expr InBndr
no_cast_scrut = Expr InBndr -> Expr InBndr
forall b. Expr b -> Expr b
drop_casts Expr InBndr
scrut
scrut_ty :: OutType
scrut_ty = HasDebugCallStack => Expr InBndr -> OutType
Expr InBndr -> OutType
exprType Expr InBndr
no_cast_scrut
seq_id_ty :: OutType
seq_id_ty = InBndr -> OutType
idType InBndr
seqId
res1_ty :: OutType
res1_ty = HasDebugCallStack => OutType -> OutType -> OutType
OutType -> OutType -> OutType
piResultTy OutType
seq_id_ty OutType
rhs_rep
res2_ty :: OutType
res2_ty = HasDebugCallStack => OutType -> OutType -> OutType
OutType -> OutType -> OutType
piResultTy OutType
res1_ty OutType
scrut_ty
res3_ty :: OutType
res3_ty = HasDebugCallStack => OutType -> OutType -> OutType
OutType -> OutType -> OutType
piResultTy OutType
res2_ty OutType
rhs_ty
res4_ty :: OutType
res4_ty = OutType -> OutType
funResultTy OutType
res3_ty
rhs_ty :: OutType
rhs_ty = SimplEnv -> OutType -> OutType
substTy SimplEnv
in_env (HasDebugCallStack => Expr InBndr -> OutType
Expr InBndr -> OutType
exprType Expr InBndr
rhs)
rhs_rep :: OutType
rhs_rep = HasDebugCallStack => OutType -> OutType
OutType -> OutType
getRuntimeRep OutType
rhs_ty
out_args :: [ArgSpec]
out_args = [ TyArg :: OutType -> OutType -> ArgSpec
TyArg { as_arg_ty :: OutType
as_arg_ty = OutType
rhs_rep
, as_hole_ty :: OutType
as_hole_ty = OutType
seq_id_ty }
, TyArg :: OutType -> OutType -> ArgSpec
TyArg { as_arg_ty :: OutType
as_arg_ty = OutType
scrut_ty
, as_hole_ty :: OutType
as_hole_ty = OutType
res1_ty }
, TyArg :: OutType -> OutType -> ArgSpec
TyArg { as_arg_ty :: OutType
as_arg_ty = OutType
rhs_ty
, as_hole_ty :: OutType
as_hole_ty = OutType
res2_ty }
, ValArg :: Demand -> Expr InBndr -> OutType -> ArgSpec
ValArg { as_arg :: Expr InBndr
as_arg = Expr InBndr
no_cast_scrut
, as_dmd :: Demand
as_dmd = Demand
seqDmd
, as_hole_ty :: OutType
as_hole_ty = OutType
res3_ty } ]
rule_cont :: SimplCont
rule_cont = ApplyToVal :: DupFlag
-> OutType -> Expr InBndr -> SimplEnv -> SimplCont -> SimplCont
ApplyToVal { sc_dup :: DupFlag
sc_dup = DupFlag
NoDup, sc_arg :: Expr InBndr
sc_arg = Expr InBndr
rhs
, sc_env :: SimplEnv
sc_env = SimplEnv
in_env, sc_cont :: SimplCont
sc_cont = SimplCont
cont
, sc_hole_ty :: OutType
sc_hole_ty = OutType
res4_ty }
drop_casts :: Expr b -> Expr b
drop_casts (Cast Expr b
e Coercion
_) = Expr b -> Expr b
drop_casts Expr b
e
drop_casts Expr b
e = Expr b
e
rebuildCase, reallyRebuildCase
:: SimplEnv
-> OutExpr
-> InId
-> [InAlt]
-> SimplCont
-> SimplM (SimplFloats, OutExpr)
rebuildCase :: SimplEnv
-> Expr InBndr
-> InBndr
-> [Alt InBndr]
-> SimplCont
-> SimplM (SimplFloats, Expr InBndr)
rebuildCase SimplEnv
env Expr InBndr
scrut InBndr
case_bndr [Alt InBndr]
alts SimplCont
cont
| Lit Literal
lit <- Expr InBndr
scrut
, Bool -> Bool
not (Literal -> Bool
litIsLifted Literal
lit)
= do { Tick -> SimplM ()
tick (InBndr -> Tick
KnownBranch InBndr
case_bndr)
; case AltCon -> [Alt InBndr] -> Maybe (Alt InBndr)
forall b. AltCon -> [Alt b] -> Maybe (Alt b)
findAlt (Literal -> AltCon
LitAlt Literal
lit) [Alt InBndr]
alts of
Maybe (Alt InBndr)
Nothing -> SimplEnv
-> InBndr
-> [Alt InBndr]
-> SimplCont
-> SimplM (SimplFloats, Expr InBndr)
missingAlt SimplEnv
env InBndr
case_bndr [Alt InBndr]
alts SimplCont
cont
Just (Alt AltCon
_ [InBndr]
bs Expr InBndr
rhs) -> SimplEnv
-> [FloatBind]
-> Expr InBndr
-> [InBndr]
-> Expr InBndr
-> SimplM (SimplFloats, Expr InBndr)
simple_rhs SimplEnv
env [] Expr InBndr
scrut [InBndr]
bs Expr InBndr
rhs }
| Just (InScopeSet
in_scope', [FloatBind]
wfloats, DataCon
con, [OutType]
ty_args, [Expr InBndr]
other_args)
<- InScopeEnv
-> Expr InBndr
-> Maybe
(InScopeSet, [FloatBind], DataCon, [OutType], [Expr InBndr])
HasDebugCallStack =>
InScopeEnv
-> Expr InBndr
-> Maybe
(InScopeSet, [FloatBind], DataCon, [OutType], [Expr InBndr])
exprIsConApp_maybe (SimplEnv -> InScopeEnv
getUnfoldingInRuleMatch SimplEnv
env) Expr InBndr
scrut
, let env0 :: SimplEnv
env0 = SimplEnv -> InScopeSet -> SimplEnv
setInScopeSet SimplEnv
env InScopeSet
in_scope'
= do { Tick -> SimplM ()
tick (InBndr -> Tick
KnownBranch InBndr
case_bndr)
; let scaled_wfloats :: [FloatBind]
scaled_wfloats = (FloatBind -> FloatBind) -> [FloatBind] -> [FloatBind]
forall a b. (a -> b) -> [a] -> [b]
map FloatBind -> FloatBind
scale_float [FloatBind]
wfloats
case_bndr_rhs :: Expr InBndr
case_bndr_rhs | Expr InBndr -> Bool
exprIsTrivial Expr InBndr
scrut = Expr InBndr
scrut
| Bool
otherwise = Expr InBndr
con_app
con_app :: Expr InBndr
con_app = InBndr -> Expr InBndr
forall b. InBndr -> Expr b
Var (DataCon -> InBndr
dataConWorkId DataCon
con) Expr InBndr -> [OutType] -> Expr InBndr
forall b. Expr b -> [OutType] -> Expr b
`mkTyApps` [OutType]
ty_args
Expr InBndr -> [Expr InBndr] -> Expr InBndr
forall b. Expr b -> [Expr b] -> Expr b
`mkApps` [Expr InBndr]
other_args
; case AltCon -> [Alt InBndr] -> Maybe (Alt InBndr)
forall b. AltCon -> [Alt b] -> Maybe (Alt b)
findAlt (DataCon -> AltCon
DataAlt DataCon
con) [Alt InBndr]
alts of
Maybe (Alt InBndr)
Nothing -> SimplEnv
-> InBndr
-> [Alt InBndr]
-> SimplCont
-> SimplM (SimplFloats, Expr InBndr)
missingAlt SimplEnv
env0 InBndr
case_bndr [Alt InBndr]
alts SimplCont
cont
Just (Alt AltCon
DEFAULT [InBndr]
bs Expr InBndr
rhs) -> SimplEnv
-> [FloatBind]
-> Expr InBndr
-> [InBndr]
-> Expr InBndr
-> SimplM (SimplFloats, Expr InBndr)
simple_rhs SimplEnv
env0 [FloatBind]
scaled_wfloats Expr InBndr
case_bndr_rhs [InBndr]
bs Expr InBndr
rhs
Just (Alt AltCon
_ [InBndr]
bs Expr InBndr
rhs) -> SimplEnv
-> Expr InBndr
-> [FloatBind]
-> DataCon
-> [OutType]
-> [Expr InBndr]
-> InBndr
-> [InBndr]
-> Expr InBndr
-> SimplCont
-> SimplM (SimplFloats, Expr InBndr)
knownCon SimplEnv
env0 Expr InBndr
scrut [FloatBind]
scaled_wfloats DataCon
con [OutType]
ty_args
[Expr InBndr]
other_args InBndr
case_bndr [InBndr]
bs Expr InBndr
rhs SimplCont
cont
}
where
simple_rhs :: SimplEnv
-> [FloatBind]
-> Expr InBndr
-> [InBndr]
-> Expr InBndr
-> SimplM (SimplFloats, Expr InBndr)
simple_rhs SimplEnv
env [FloatBind]
wfloats Expr InBndr
case_bndr_rhs [InBndr]
bs Expr InBndr
rhs =
Bool
-> SimplM (SimplFloats, Expr InBndr)
-> SimplM (SimplFloats, Expr InBndr)
forall a. HasCallStack => Bool -> a -> a
assert ([InBndr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InBndr]
bs) (SimplM (SimplFloats, Expr InBndr)
-> SimplM (SimplFloats, Expr InBndr))
-> SimplM (SimplFloats, Expr InBndr)
-> SimplM (SimplFloats, Expr InBndr)
forall a b. (a -> b) -> a -> b
$
do { (SimplFloats
floats1, SimplEnv
env') <- SimplEnv -> InBndr -> Expr InBndr -> SimplM (SimplFloats, SimplEnv)
simplNonRecX SimplEnv
env InBndr
case_bndr Expr InBndr
case_bndr_rhs
; (SimplFloats
floats2, Expr InBndr
expr') <- SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplExprF SimplEnv
env' Expr InBndr
rhs SimplCont
cont
; case [FloatBind]
wfloats of
[] -> (SimplFloats, Expr InBndr) -> SimplM (SimplFloats, Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplFloats
floats1 SimplFloats -> SimplFloats -> SimplFloats
`addFloats` SimplFloats
floats2, Expr InBndr
expr')
[FloatBind]
_ -> (SimplFloats, Expr InBndr) -> SimplM (SimplFloats, Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return
( SimplEnv -> SimplFloats
emptyFloats SimplEnv
env,
[FloatBind] -> Expr InBndr -> Expr InBndr
GHC.Core.Make.wrapFloats [FloatBind]
wfloats (Expr InBndr -> Expr InBndr) -> Expr InBndr -> Expr InBndr
forall a b. (a -> b) -> a -> b
$
SimplFloats -> Expr InBndr -> Expr InBndr
wrapFloats (SimplFloats
floats1 SimplFloats -> SimplFloats -> SimplFloats
`addFloats` SimplFloats
floats2) Expr InBndr
expr' )}
scale_float :: FloatBind -> FloatBind
scale_float (GHC.Core.Make.FloatCase Expr InBndr
scrut InBndr
case_bndr AltCon
con [InBndr]
vars) =
let
scale_id :: InBndr -> InBndr
scale_id InBndr
id = OutType -> InBndr -> InBndr
scaleVarBy OutType
holeScaling InBndr
id
in
Expr InBndr -> InBndr -> AltCon -> [InBndr] -> FloatBind
GHC.Core.Make.FloatCase Expr InBndr
scrut (InBndr -> InBndr
scale_id InBndr
case_bndr) AltCon
con ((InBndr -> InBndr) -> [InBndr] -> [InBndr]
forall a b. (a -> b) -> [a] -> [b]
map InBndr -> InBndr
scale_id [InBndr]
vars)
scale_float FloatBind
f = FloatBind
f
holeScaling :: OutType
holeScaling = SimplCont -> OutType
contHoleScaling SimplCont
cont OutType -> OutType -> OutType
`mkMultMul` InBndr -> OutType
idMult InBndr
case_bndr
rebuildCase SimplEnv
env Expr InBndr
scrut InBndr
case_bndr alts :: [Alt InBndr]
alts@[Alt AltCon
_ [InBndr]
bndrs Expr InBndr
rhs] SimplCont
cont
| Bool
is_plain_seq
, Expr InBndr -> Bool
exprOkForSideEffects Expr InBndr
scrut
= SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplExprF SimplEnv
env Expr InBndr
rhs SimplCont
cont
| Bool
all_dead_bndrs
, Expr InBndr -> InBndr -> Bool
doCaseToLet Expr InBndr
scrut InBndr
case_bndr
= do { Tick -> SimplM ()
tick (InBndr -> Tick
CaseElim InBndr
case_bndr)
; (SimplFloats
floats1, SimplEnv
env') <- SimplEnv -> InBndr -> Expr InBndr -> SimplM (SimplFloats, SimplEnv)
simplNonRecX SimplEnv
env InBndr
case_bndr Expr InBndr
scrut
; (SimplFloats
floats2, Expr InBndr
expr') <- SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplExprF SimplEnv
env' Expr InBndr
rhs SimplCont
cont
; (SimplFloats, Expr InBndr) -> SimplM (SimplFloats, Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplFloats
floats1 SimplFloats -> SimplFloats -> SimplFloats
`addFloats` SimplFloats
floats2, Expr InBndr
expr') }
| Bool
is_plain_seq
= do { Maybe (SimplEnv, Expr InBndr, SimplCont)
mb_rule <- SimplEnv
-> Expr InBndr
-> Expr InBndr
-> SimplCont
-> SimplM (Maybe (SimplEnv, Expr InBndr, SimplCont))
trySeqRules SimplEnv
env Expr InBndr
scrut Expr InBndr
rhs SimplCont
cont
; case Maybe (SimplEnv, Expr InBndr, SimplCont)
mb_rule of
Just (SimplEnv
env', Expr InBndr
rule_rhs, SimplCont
cont') -> SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplExprF SimplEnv
env' Expr InBndr
rule_rhs SimplCont
cont'
Maybe (SimplEnv, Expr InBndr, SimplCont)
Nothing -> SimplEnv
-> Expr InBndr
-> InBndr
-> [Alt InBndr]
-> SimplCont
-> SimplM (SimplFloats, Expr InBndr)
reallyRebuildCase SimplEnv
env Expr InBndr
scrut InBndr
case_bndr [Alt InBndr]
alts SimplCont
cont }
where
all_dead_bndrs :: Bool
all_dead_bndrs = (InBndr -> Bool) -> [InBndr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all InBndr -> Bool
isDeadBinder [InBndr]
bndrs
is_plain_seq :: Bool
is_plain_seq = Bool
all_dead_bndrs Bool -> Bool -> Bool
&& InBndr -> Bool
isDeadBinder InBndr
case_bndr
rebuildCase SimplEnv
env Expr InBndr
scrut InBndr
case_bndr [Alt InBndr]
alts SimplCont
cont
= SimplEnv
-> Expr InBndr
-> InBndr
-> [Alt InBndr]
-> SimplCont
-> SimplM (SimplFloats, Expr InBndr)
reallyRebuildCase SimplEnv
env Expr InBndr
scrut InBndr
case_bndr [Alt InBndr]
alts SimplCont
cont
doCaseToLet :: OutExpr
-> InId
-> Bool
doCaseToLet :: Expr InBndr -> InBndr -> Bool
doCaseToLet Expr InBndr
scrut InBndr
case_bndr
| InBndr -> Bool
isTyCoVar InBndr
case_bndr
= Expr InBndr -> Bool
forall b. Expr b -> Bool
isTyCoArg Expr InBndr
scrut
| HasDebugCallStack => OutType -> Bool
OutType -> Bool
isUnliftedType (InBndr -> OutType
idType InBndr
case_bndr)
= Expr InBndr -> Bool
exprOkForSpeculation Expr InBndr
scrut
| Bool
otherwise
= Expr InBndr -> Bool
exprIsHNF Expr InBndr
scrut
Bool -> Bool -> Bool
|| Demand -> Bool
isStrUsedDmd (InBndr -> Demand
idDemandInfo InBndr
case_bndr)
reallyRebuildCase :: SimplEnv
-> Expr InBndr
-> InBndr
-> [Alt InBndr]
-> SimplCont
-> SimplM (SimplFloats, Expr InBndr)
reallyRebuildCase SimplEnv
env Expr InBndr
scrut InBndr
case_bndr [Alt InBndr]
alts SimplCont
cont
| Bool -> Bool
not (SimplMode -> Bool
sm_case_case (SimplEnv -> SimplMode
getMode SimplEnv
env))
= do { Expr InBndr
case_expr <- SimplEnv
-> Expr InBndr
-> InBndr
-> [Alt InBndr]
-> SimplCont
-> SimplM (Expr InBndr)
simplAlts SimplEnv
env Expr InBndr
scrut InBndr
case_bndr [Alt InBndr]
alts
(OutType -> SimplCont
mkBoringStop (SimplCont -> OutType
contHoleType SimplCont
cont))
; SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
rebuild SimplEnv
env Expr InBndr
case_expr SimplCont
cont }
| Bool
otherwise
= do { (SimplFloats
floats, SimplEnv
env', SimplCont
cont') <- SimplEnv
-> [Alt InBndr]
-> SimplCont
-> SimplM (SimplFloats, SimplEnv, SimplCont)
mkDupableCaseCont SimplEnv
env [Alt InBndr]
alts SimplCont
cont
; Expr InBndr
case_expr <- SimplEnv
-> Expr InBndr
-> InBndr
-> [Alt InBndr]
-> SimplCont
-> SimplM (Expr InBndr)
simplAlts SimplEnv
env' Expr InBndr
scrut
(OutType -> InBndr -> InBndr
scaleIdBy OutType
holeScaling InBndr
case_bndr)
(OutType -> [Alt InBndr] -> [Alt InBndr]
scaleAltsBy OutType
holeScaling [Alt InBndr]
alts)
SimplCont
cont'
; (SimplFloats, Expr InBndr) -> SimplM (SimplFloats, Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplFloats
floats, Expr InBndr
case_expr) }
where
holeScaling :: OutType
holeScaling = SimplCont -> OutType
contHoleScaling SimplCont
cont
simplAlts :: SimplEnv
-> OutExpr
-> InId
-> [InAlt]
-> SimplCont
-> SimplM OutExpr
simplAlts :: SimplEnv
-> Expr InBndr
-> InBndr
-> [Alt InBndr]
-> SimplCont
-> SimplM (Expr InBndr)
simplAlts SimplEnv
env0 Expr InBndr
scrut InBndr
case_bndr [Alt InBndr]
alts SimplCont
cont'
= do { String -> SDoc -> SimplM ()
traceSmpl String
"simplAlts" ([SDoc] -> SDoc
vcat [ InBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr InBndr
case_bndr
, String -> SDoc
text String
"cont':" SDoc -> SDoc -> SDoc
<+> SimplCont -> SDoc
forall a. Outputable a => a -> SDoc
ppr SimplCont
cont'
, String -> SDoc
text String
"in_scope" SDoc -> SDoc -> SDoc
<+> InScopeSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr (SimplEnv -> InScopeSet
seInScope SimplEnv
env0) ])
; (SimplEnv
env1, InBndr
case_bndr1) <- SimplEnv -> InBndr -> SimplM (SimplEnv, InBndr)
simplBinder SimplEnv
env0 InBndr
case_bndr
; let case_bndr2 :: InBndr
case_bndr2 = InBndr
case_bndr1 InBndr -> Unfolding -> InBndr
`setIdUnfolding` Unfolding
evaldUnfolding
env2 :: SimplEnv
env2 = SimplEnv -> InBndr -> SimplEnv
modifyInScope SimplEnv
env1 InBndr
case_bndr2
; (FamInstEnv, FamInstEnv)
fam_envs <- SimplM (FamInstEnv, FamInstEnv)
getFamEnvs
; (SimplEnv
alt_env', Expr InBndr
scrut', InBndr
case_bndr') <- (FamInstEnv, FamInstEnv)
-> SimplEnv
-> Expr InBndr
-> InBndr
-> InBndr
-> [Alt InBndr]
-> SimplM (SimplEnv, Expr InBndr, InBndr)
improveSeq (FamInstEnv, FamInstEnv)
fam_envs SimplEnv
env2 Expr InBndr
scrut
InBndr
case_bndr InBndr
case_bndr2 [Alt InBndr]
alts
; ([AltCon]
imposs_deflt_cons, [Alt InBndr]
in_alts) <- Expr InBndr
-> InBndr -> [Alt InBndr] -> SimplM ([AltCon], [Alt InBndr])
prepareAlts Expr InBndr
scrut' InBndr
case_bndr' [Alt InBndr]
alts
; [Alt InBndr]
alts' <- (Alt InBndr -> SimplM (Alt InBndr))
-> [Alt InBndr] -> SimplM [Alt InBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SimplEnv
-> Maybe (Expr InBndr)
-> [AltCon]
-> InBndr
-> SimplCont
-> Alt InBndr
-> SimplM (Alt InBndr)
simplAlt SimplEnv
alt_env' (Expr InBndr -> Maybe (Expr InBndr)
forall a. a -> Maybe a
Just Expr InBndr
scrut') [AltCon]
imposs_deflt_cons InBndr
case_bndr' SimplCont
cont') [Alt InBndr]
in_alts
; let alts_ty' :: OutType
alts_ty' = SimplCont -> OutType
contResultType SimplCont
cont'
; OutType -> ()
seqType OutType
alts_ty' () -> SimplM (Expr InBndr) -> SimplM (Expr InBndr)
`seq`
DynFlags
-> Expr InBndr
-> InBndr
-> OutType
-> [Alt InBndr]
-> SimplM (Expr InBndr)
mkCase (SimplEnv -> DynFlags
seDynFlags SimplEnv
env0) Expr InBndr
scrut' InBndr
case_bndr' OutType
alts_ty' [Alt InBndr]
alts' }
improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv
-> OutExpr -> InId -> OutId -> [InAlt]
-> SimplM (SimplEnv, OutExpr, OutId)
improveSeq :: (FamInstEnv, FamInstEnv)
-> SimplEnv
-> Expr InBndr
-> InBndr
-> InBndr
-> [Alt InBndr]
-> SimplM (SimplEnv, Expr InBndr, InBndr)
improveSeq (FamInstEnv, FamInstEnv)
fam_envs SimplEnv
env Expr InBndr
scrut InBndr
case_bndr InBndr
case_bndr1 [Alt AltCon
DEFAULT [InBndr]
_ Expr InBndr
_]
| Just (Reduction Coercion
co OutType
ty2) <- (FamInstEnv, FamInstEnv) -> OutType -> Maybe Reduction
topNormaliseType_maybe (FamInstEnv, FamInstEnv)
fam_envs (InBndr -> OutType
idType InBndr
case_bndr1)
= do { InBndr
case_bndr2 <- FastString -> OutType -> OutType -> SimplM InBndr
newId (String -> FastString
fsLit String
"nt") OutType
Many OutType
ty2
; let rhs :: SimplSR
rhs = Expr InBndr -> Maybe JoinArity -> SimplSR
DoneEx (InBndr -> Expr InBndr
forall b. InBndr -> Expr b
Var InBndr
case_bndr2 Expr InBndr -> Coercion -> Expr InBndr
forall b. Expr b -> Coercion -> Expr b
`Cast` Coercion -> Coercion
mkSymCo Coercion
co) Maybe JoinArity
forall a. Maybe a
Nothing
env2 :: SimplEnv
env2 = SimplEnv -> InBndr -> SimplSR -> SimplEnv
extendIdSubst SimplEnv
env InBndr
case_bndr SimplSR
rhs
; (SimplEnv, Expr InBndr, InBndr)
-> SimplM (SimplEnv, Expr InBndr, InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplEnv
env2, Expr InBndr
scrut Expr InBndr -> Coercion -> Expr InBndr
forall b. Expr b -> Coercion -> Expr b
`Cast` Coercion
co, InBndr
case_bndr2) }
improveSeq (FamInstEnv, FamInstEnv)
_ SimplEnv
env Expr InBndr
scrut InBndr
_ InBndr
case_bndr1 [Alt InBndr]
_
= (SimplEnv, Expr InBndr, InBndr)
-> SimplM (SimplEnv, Expr InBndr, InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplEnv
env, Expr InBndr
scrut, InBndr
case_bndr1)
simplAlt :: SimplEnv
-> Maybe OutExpr
-> [AltCon]
-> OutId
-> SimplCont
-> InAlt
-> SimplM OutAlt
simplAlt :: SimplEnv
-> Maybe (Expr InBndr)
-> [AltCon]
-> InBndr
-> SimplCont
-> Alt InBndr
-> SimplM (Alt InBndr)
simplAlt SimplEnv
env Maybe (Expr InBndr)
_ [AltCon]
imposs_deflt_cons InBndr
case_bndr' SimplCont
cont' (Alt AltCon
DEFAULT [InBndr]
bndrs Expr InBndr
rhs)
= Bool -> SimplM (Alt InBndr) -> SimplM (Alt InBndr)
forall a. HasCallStack => Bool -> a -> a
assert ([InBndr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InBndr]
bndrs) (SimplM (Alt InBndr) -> SimplM (Alt InBndr))
-> SimplM (Alt InBndr) -> SimplM (Alt InBndr)
forall a b. (a -> b) -> a -> b
$
do { let env' :: SimplEnv
env' = SimplEnv -> InBndr -> Unfolding -> SimplEnv
addBinderUnfolding SimplEnv
env InBndr
case_bndr'
([AltCon] -> Unfolding
mkOtherCon [AltCon]
imposs_deflt_cons)
; Expr InBndr
rhs' <- SimplEnv -> Expr InBndr -> SimplCont -> SimplM (Expr InBndr)
simplExprC SimplEnv
env' Expr InBndr
rhs SimplCont
cont'
; Alt InBndr -> SimplM (Alt InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (AltCon -> [InBndr] -> Expr InBndr -> Alt InBndr
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] Expr InBndr
rhs') }
simplAlt SimplEnv
env Maybe (Expr InBndr)
scrut' [AltCon]
_ InBndr
case_bndr' SimplCont
cont' (Alt (LitAlt Literal
lit) [InBndr]
bndrs Expr InBndr
rhs)
= Bool -> SimplM (Alt InBndr) -> SimplM (Alt InBndr)
forall a. HasCallStack => Bool -> a -> a
assert ([InBndr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InBndr]
bndrs) (SimplM (Alt InBndr) -> SimplM (Alt InBndr))
-> SimplM (Alt InBndr) -> SimplM (Alt InBndr)
forall a b. (a -> b) -> a -> b
$
do { SimplEnv
env' <- SimplEnv
-> Maybe (Expr InBndr) -> InBndr -> Expr InBndr -> SimplM SimplEnv
addAltUnfoldings SimplEnv
env Maybe (Expr InBndr)
scrut' InBndr
case_bndr' (Literal -> Expr InBndr
forall b. Literal -> Expr b
Lit Literal
lit)
; Expr InBndr
rhs' <- SimplEnv -> Expr InBndr -> SimplCont -> SimplM (Expr InBndr)
simplExprC SimplEnv
env' Expr InBndr
rhs SimplCont
cont'
; Alt InBndr -> SimplM (Alt InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (AltCon -> [InBndr] -> Expr InBndr -> Alt InBndr
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (Literal -> AltCon
LitAlt Literal
lit) [] Expr InBndr
rhs') }
simplAlt SimplEnv
env Maybe (Expr InBndr)
scrut' [AltCon]
_ InBndr
case_bndr' SimplCont
cont' (Alt (DataAlt DataCon
con) [InBndr]
vs Expr InBndr
rhs)
= do {
let vs_with_evals :: [InBndr]
vs_with_evals = Maybe (Expr InBndr) -> DataCon -> [InBndr] -> [InBndr]
addEvals Maybe (Expr InBndr)
scrut' DataCon
con [InBndr]
vs
; (SimplEnv
env', [InBndr]
vs') <- SimplEnv -> [InBndr] -> SimplM (SimplEnv, [InBndr])
simplLamBndrs SimplEnv
env [InBndr]
vs_with_evals
; let inst_tys' :: [OutType]
inst_tys' = OutType -> [OutType]
tyConAppArgs (InBndr -> OutType
idType InBndr
case_bndr')
con_app :: OutExpr
con_app :: Expr InBndr
con_app = DataCon -> [OutType] -> [InBndr] -> Expr InBndr
forall b. DataCon -> [OutType] -> [InBndr] -> Expr b
mkConApp2 DataCon
con [OutType]
inst_tys' [InBndr]
vs'
; SimplEnv
env'' <- SimplEnv
-> Maybe (Expr InBndr) -> InBndr -> Expr InBndr -> SimplM SimplEnv
addAltUnfoldings SimplEnv
env' Maybe (Expr InBndr)
scrut' InBndr
case_bndr' Expr InBndr
con_app
; Expr InBndr
rhs' <- SimplEnv -> Expr InBndr -> SimplCont -> SimplM (Expr InBndr)
simplExprC SimplEnv
env'' Expr InBndr
rhs SimplCont
cont'
; Alt InBndr -> SimplM (Alt InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (AltCon -> [InBndr] -> Expr InBndr -> Alt InBndr
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
con) [InBndr]
vs' Expr InBndr
rhs') }
addEvals :: Maybe OutExpr -> DataCon -> [Id] -> [Id]
addEvals :: Maybe (Expr InBndr) -> DataCon -> [InBndr] -> [InBndr]
addEvals Maybe (Expr InBndr)
scrut DataCon
con [InBndr]
vs
| Just Expr InBndr
scr <- Maybe (Expr InBndr)
scrut
, DataCon -> Bool
isUnboxedTupleDataCon DataCon
con
, [InBndr
s,InBndr
x] <- [InBndr]
vs
, Just (Var InBndr
f) <- Word -> Expr InBndr -> Maybe (Expr InBndr)
forall a. Word -> Expr a -> Maybe (Expr a)
stripNArgs Word
4 Expr InBndr
scr
, Just PrimOp
SeqOp <- InBndr -> Maybe PrimOp
isPrimOpId_maybe InBndr
f
, let x' :: InBndr
x' = StrictnessMark -> InBndr -> InBndr
zapIdOccInfoAndSetEvald StrictnessMark
MarkedStrict InBndr
x
= [InBndr
s, InBndr
x']
addEvals Maybe (Expr InBndr)
_scrut DataCon
con [InBndr]
vs = [InBndr] -> [StrictnessMark] -> [InBndr]
go [InBndr]
vs [StrictnessMark]
the_strs
where
the_strs :: [StrictnessMark]
the_strs = DataCon -> [StrictnessMark]
dataConRepStrictness DataCon
con
go :: [InBndr] -> [StrictnessMark] -> [InBndr]
go [] [] = []
go (InBndr
v:[InBndr]
vs') [StrictnessMark]
strs | InBndr -> Bool
isTyVar InBndr
v = InBndr
v InBndr -> [InBndr] -> [InBndr]
forall a. a -> [a] -> [a]
: [InBndr] -> [StrictnessMark] -> [InBndr]
go [InBndr]
vs' [StrictnessMark]
strs
go (InBndr
v:[InBndr]
vs') (StrictnessMark
str:[StrictnessMark]
strs) = StrictnessMark -> InBndr -> InBndr
zapIdOccInfoAndSetEvald StrictnessMark
str InBndr
v InBndr -> [InBndr] -> [InBndr]
forall a. a -> [a] -> [a]
: [InBndr] -> [StrictnessMark] -> [InBndr]
go [InBndr]
vs' [StrictnessMark]
strs
go [InBndr]
_ [StrictnessMark]
_ = String -> SDoc -> [InBndr]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Simplify.addEvals"
(DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
con SDoc -> SDoc -> SDoc
$$
[InBndr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [InBndr]
vs SDoc -> SDoc -> SDoc
$$
[SDoc] -> SDoc
forall (t :: * -> *) a.
(Outputable (t a), Foldable t) =>
t a -> SDoc
ppr_with_length ((StrictnessMark -> SDoc) -> [StrictnessMark] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map StrictnessMark -> SDoc
strdisp [StrictnessMark]
the_strs) SDoc -> SDoc -> SDoc
$$
[Scaled OutType] -> SDoc
forall (t :: * -> *) a.
(Outputable (t a), Foldable t) =>
t a -> SDoc
ppr_with_length (DataCon -> [Scaled OutType]
dataConRepArgTys DataCon
con) SDoc -> SDoc -> SDoc
$$
[StrictnessMark] -> SDoc
forall (t :: * -> *) a.
(Outputable (t a), Foldable t) =>
t a -> SDoc
ppr_with_length (DataCon -> [StrictnessMark]
dataConRepStrictness DataCon
con))
where
ppr_with_length :: t a -> SDoc
ppr_with_length t a
list
= t a -> SDoc
forall a. Outputable a => a -> SDoc
ppr t a
list SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens (String -> SDoc
text String
"length =" SDoc -> SDoc -> SDoc
<+> JoinArity -> SDoc
forall a. Outputable a => a -> SDoc
ppr (t a -> JoinArity
forall (t :: * -> *) a. Foldable t => t a -> JoinArity
length t a
list))
strdisp :: StrictnessMark -> SDoc
strdisp StrictnessMark
MarkedStrict = String -> SDoc
text String
"MarkedStrict"
strdisp StrictnessMark
NotMarkedStrict = String -> SDoc
text String
"NotMarkedStrict"
zapIdOccInfoAndSetEvald :: StrictnessMark -> Id -> Id
zapIdOccInfoAndSetEvald :: StrictnessMark -> InBndr -> InBndr
zapIdOccInfoAndSetEvald StrictnessMark
str InBndr
v =
StrictnessMark -> InBndr -> InBndr
setCaseBndrEvald StrictnessMark
str (InBndr -> InBndr) -> InBndr -> InBndr
forall a b. (a -> b) -> a -> b
$
InBndr -> InBndr
zapIdOccInfo InBndr
v
addAltUnfoldings :: SimplEnv -> Maybe OutExpr -> OutId -> OutExpr -> SimplM SimplEnv
addAltUnfoldings :: SimplEnv
-> Maybe (Expr InBndr) -> InBndr -> Expr InBndr -> SimplM SimplEnv
addAltUnfoldings SimplEnv
env Maybe (Expr InBndr)
scrut InBndr
case_bndr Expr InBndr
con_app
= do { let con_app_unf :: Unfolding
con_app_unf = Expr InBndr -> Unfolding
mk_simple_unf Expr InBndr
con_app
env1 :: SimplEnv
env1 = SimplEnv -> InBndr -> Unfolding -> SimplEnv
addBinderUnfolding SimplEnv
env InBndr
case_bndr Unfolding
con_app_unf
env2 :: SimplEnv
env2 | OutType
Many <- InBndr -> OutType
idMult InBndr
case_bndr = case Maybe (Expr InBndr)
scrut of
Just (Var InBndr
v) -> SimplEnv -> InBndr -> Unfolding -> SimplEnv
addBinderUnfolding SimplEnv
env1 InBndr
v Unfolding
con_app_unf
Just (Cast (Var InBndr
v) Coercion
co) -> SimplEnv -> InBndr -> Unfolding -> SimplEnv
addBinderUnfolding SimplEnv
env1 InBndr
v (Unfolding -> SimplEnv) -> Unfolding -> SimplEnv
forall a b. (a -> b) -> a -> b
$
Expr InBndr -> Unfolding
mk_simple_unf (Expr InBndr -> Coercion -> Expr InBndr
forall b. Expr b -> Coercion -> Expr b
Cast Expr InBndr
con_app (Coercion -> Coercion
mkSymCo Coercion
co))
Maybe (Expr InBndr)
_ -> SimplEnv
env1
| Bool
otherwise = SimplEnv
env1
; String -> SDoc -> SimplM ()
traceSmpl String
"addAltUnf" ([SDoc] -> SDoc
vcat [InBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr InBndr
case_bndr SDoc -> SDoc -> SDoc
<+> Maybe (Expr InBndr) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe (Expr InBndr)
scrut, Expr InBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr Expr InBndr
con_app])
; SimplEnv -> SimplM SimplEnv
forall (m :: * -> *) a. Monad m => a -> m a
return SimplEnv
env2 }
where
!opts :: UnfoldingOpts
opts = SimplEnv -> UnfoldingOpts
seUnfoldingOpts SimplEnv
env
mk_simple_unf :: Expr InBndr -> Unfolding
mk_simple_unf = UnfoldingOpts -> Expr InBndr -> Unfolding
mkSimpleUnfolding UnfoldingOpts
opts
addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv
addBinderUnfolding :: SimplEnv -> InBndr -> Unfolding -> SimplEnv
addBinderUnfolding SimplEnv
env InBndr
bndr Unfolding
unf
| Bool
debugIsOn, Just Expr InBndr
tmpl <- Unfolding -> Maybe (Expr InBndr)
maybeUnfoldingTemplate Unfolding
unf
= Bool -> String -> SDoc -> SimplEnv -> SimplEnv
forall a. HasCallStack => Bool -> String -> SDoc -> a -> a
warnPprTrace (Bool -> Bool
not (OutType -> OutType -> Bool
eqType (InBndr -> OutType
idType InBndr
bndr) (HasDebugCallStack => Expr InBndr -> OutType
Expr InBndr -> OutType
exprType Expr InBndr
tmpl)))
String
"unfolding type mismatch"
(InBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr InBndr
bndr SDoc -> SDoc -> SDoc
$$ OutType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (InBndr -> OutType
idType InBndr
bndr) SDoc -> SDoc -> SDoc
$$ Expr InBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr Expr InBndr
tmpl SDoc -> SDoc -> SDoc
$$ OutType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => Expr InBndr -> OutType
Expr InBndr -> OutType
exprType Expr InBndr
tmpl)) (SimplEnv -> SimplEnv) -> SimplEnv -> SimplEnv
forall a b. (a -> b) -> a -> b
$
SimplEnv -> InBndr -> SimplEnv
modifyInScope SimplEnv
env (InBndr
bndr InBndr -> Unfolding -> InBndr
`setIdUnfolding` Unfolding
unf)
| Bool
otherwise
= SimplEnv -> InBndr -> SimplEnv
modifyInScope SimplEnv
env (InBndr
bndr InBndr -> Unfolding -> InBndr
`setIdUnfolding` Unfolding
unf)
zapBndrOccInfo :: Bool -> Id -> Id
zapBndrOccInfo :: Bool -> InBndr -> InBndr
zapBndrOccInfo Bool
keep_occ_info InBndr
pat_id
| Bool
keep_occ_info = InBndr
pat_id
| Bool
otherwise = InBndr -> InBndr
zapIdOccInfo InBndr
pat_id
knownCon :: SimplEnv
-> OutExpr
-> [FloatBind] -> DataCon -> [OutType] -> [OutExpr]
-> InId -> [InBndr] -> InExpr
-> SimplCont
-> SimplM (SimplFloats, OutExpr)
knownCon :: SimplEnv
-> Expr InBndr
-> [FloatBind]
-> DataCon
-> [OutType]
-> [Expr InBndr]
-> InBndr
-> [InBndr]
-> Expr InBndr
-> SimplCont
-> SimplM (SimplFloats, Expr InBndr)
knownCon SimplEnv
env Expr InBndr
scrut [FloatBind]
dc_floats DataCon
dc [OutType]
dc_ty_args [Expr InBndr]
dc_args InBndr
bndr [InBndr]
bs Expr InBndr
rhs SimplCont
cont
= do { (SimplFloats
floats1, SimplEnv
env1) <- SimplEnv
-> [InBndr] -> [Expr InBndr] -> SimplM (SimplFloats, SimplEnv)
bind_args SimplEnv
env [InBndr]
bs [Expr InBndr]
dc_args
; (SimplFloats
floats2, SimplEnv
env2) <- SimplEnv -> SimplM (SimplFloats, SimplEnv)
bind_case_bndr SimplEnv
env1
; (SimplFloats
floats3, Expr InBndr
expr') <- SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplExprF SimplEnv
env2 Expr InBndr
rhs SimplCont
cont
; case [FloatBind]
dc_floats of
[] ->
(SimplFloats, Expr InBndr) -> SimplM (SimplFloats, Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplFloats
floats1 SimplFloats -> SimplFloats -> SimplFloats
`addFloats` SimplFloats
floats2 SimplFloats -> SimplFloats -> SimplFloats
`addFloats` SimplFloats
floats3, Expr InBndr
expr')
[FloatBind]
_ ->
(SimplFloats, Expr InBndr) -> SimplM (SimplFloats, Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return ( SimplEnv -> SimplFloats
emptyFloats SimplEnv
env
, [FloatBind] -> Expr InBndr -> Expr InBndr
GHC.Core.Make.wrapFloats [FloatBind]
dc_floats (Expr InBndr -> Expr InBndr) -> Expr InBndr -> Expr InBndr
forall a b. (a -> b) -> a -> b
$
SimplFloats -> Expr InBndr -> Expr InBndr
wrapFloats (SimplFloats
floats1 SimplFloats -> SimplFloats -> SimplFloats
`addFloats` SimplFloats
floats2 SimplFloats -> SimplFloats -> SimplFloats
`addFloats` SimplFloats
floats3) Expr InBndr
expr') }
where
zap_occ :: InBndr -> InBndr
zap_occ = Bool -> InBndr -> InBndr
zapBndrOccInfo (InBndr -> Bool
isDeadBinder InBndr
bndr)
bind_args :: SimplEnv
-> [InBndr] -> [Expr InBndr] -> SimplM (SimplFloats, SimplEnv)
bind_args SimplEnv
env' [] [Expr InBndr]
_ = (SimplFloats, SimplEnv) -> SimplM (SimplFloats, SimplEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplEnv -> SimplFloats
emptyFloats SimplEnv
env', SimplEnv
env')
bind_args SimplEnv
env' (InBndr
b:[InBndr]
bs') (Type OutType
ty : [Expr InBndr]
args)
= Bool
-> (SimplEnv
-> [InBndr] -> [Expr InBndr] -> SimplM (SimplFloats, SimplEnv))
-> SimplEnv
-> [InBndr]
-> [Expr InBndr]
-> SimplM (SimplFloats, SimplEnv)
forall a. HasCallStack => Bool -> a -> a
assert (InBndr -> Bool
isTyVar InBndr
b )
SimplEnv
-> [InBndr] -> [Expr InBndr] -> SimplM (SimplFloats, SimplEnv)
bind_args (SimplEnv -> InBndr -> OutType -> SimplEnv
extendTvSubst SimplEnv
env' InBndr
b OutType
ty) [InBndr]
bs' [Expr InBndr]
args
bind_args SimplEnv
env' (InBndr
b:[InBndr]
bs') (Coercion Coercion
co : [Expr InBndr]
args)
= Bool
-> (SimplEnv
-> [InBndr] -> [Expr InBndr] -> SimplM (SimplFloats, SimplEnv))
-> SimplEnv
-> [InBndr]
-> [Expr InBndr]
-> SimplM (SimplFloats, SimplEnv)
forall a. HasCallStack => Bool -> a -> a
assert (InBndr -> Bool
isCoVar InBndr
b )
SimplEnv
-> [InBndr] -> [Expr InBndr] -> SimplM (SimplFloats, SimplEnv)
bind_args (SimplEnv -> InBndr -> Coercion -> SimplEnv
extendCvSubst SimplEnv
env' InBndr
b Coercion
co) [InBndr]
bs' [Expr InBndr]
args
bind_args SimplEnv
env' (InBndr
b:[InBndr]
bs') (Expr InBndr
arg : [Expr InBndr]
args)
= Bool
-> SimplM (SimplFloats, SimplEnv) -> SimplM (SimplFloats, SimplEnv)
forall a. HasCallStack => Bool -> a -> a
assert (InBndr -> Bool
isId InBndr
b) (SimplM (SimplFloats, SimplEnv) -> SimplM (SimplFloats, SimplEnv))
-> SimplM (SimplFloats, SimplEnv) -> SimplM (SimplFloats, SimplEnv)
forall a b. (a -> b) -> a -> b
$
do { let b' :: InBndr
b' = InBndr -> InBndr
zap_occ InBndr
b
; (SimplFloats
floats1, SimplEnv
env2) <- SimplEnv -> InBndr -> Expr InBndr -> SimplM (SimplFloats, SimplEnv)
simplNonRecX SimplEnv
env' InBndr
b' Expr InBndr
arg
; (SimplFloats
floats2, SimplEnv
env3) <- SimplEnv
-> [InBndr] -> [Expr InBndr] -> SimplM (SimplFloats, SimplEnv)
bind_args SimplEnv
env2 [InBndr]
bs' [Expr InBndr]
args
; (SimplFloats, SimplEnv) -> SimplM (SimplFloats, SimplEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplFloats
floats1 SimplFloats -> SimplFloats -> SimplFloats
`addFloats` SimplFloats
floats2, SimplEnv
env3) }
bind_args SimplEnv
_ [InBndr]
_ [Expr InBndr]
_ =
String -> SDoc -> SimplM (SimplFloats, SimplEnv)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"bind_args" (SDoc -> SimplM (SimplFloats, SimplEnv))
-> SDoc -> SimplM (SimplFloats, SimplEnv)
forall a b. (a -> b) -> a -> b
$ DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
dc SDoc -> SDoc -> SDoc
$$ [InBndr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [InBndr]
bs SDoc -> SDoc -> SDoc
$$ [Expr InBndr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Expr InBndr]
dc_args SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"scrut:" SDoc -> SDoc -> SDoc
<+> Expr InBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr Expr InBndr
scrut
bind_case_bndr :: SimplEnv -> SimplM (SimplFloats, SimplEnv)
bind_case_bndr SimplEnv
env
| InBndr -> Bool
isDeadBinder InBndr
bndr = (SimplFloats, SimplEnv) -> SimplM (SimplFloats, SimplEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplEnv -> SimplFloats
emptyFloats SimplEnv
env, SimplEnv
env)
| Expr InBndr -> Bool
exprIsTrivial Expr InBndr
scrut = (SimplFloats, SimplEnv) -> SimplM (SimplFloats, SimplEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplEnv -> SimplFloats
emptyFloats SimplEnv
env
, SimplEnv -> InBndr -> SimplSR -> SimplEnv
extendIdSubst SimplEnv
env InBndr
bndr (Expr InBndr -> Maybe JoinArity -> SimplSR
DoneEx Expr InBndr
scrut Maybe JoinArity
forall a. Maybe a
Nothing))
| Bool
otherwise = do { [Expr InBndr]
dc_args <- (InBndr -> SimplM (Expr InBndr))
-> [InBndr] -> SimplM [Expr InBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SimplEnv -> InBndr -> SimplM (Expr InBndr)
simplVar SimplEnv
env) [InBndr]
bs
; let con_app :: Expr InBndr
con_app = InBndr -> Expr InBndr
forall b. InBndr -> Expr b
Var (DataCon -> InBndr
dataConWorkId DataCon
dc)
Expr InBndr -> [OutType] -> Expr InBndr
forall b. Expr b -> [OutType] -> Expr b
`mkTyApps` [OutType]
dc_ty_args
Expr InBndr -> [Expr InBndr] -> Expr InBndr
forall b. Expr b -> [Expr b] -> Expr b
`mkApps` [Expr InBndr]
dc_args
; SimplEnv -> InBndr -> Expr InBndr -> SimplM (SimplFloats, SimplEnv)
simplNonRecX SimplEnv
env InBndr
bndr Expr InBndr
con_app }
missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont
-> SimplM (SimplFloats, OutExpr)
missingAlt :: SimplEnv
-> InBndr
-> [Alt InBndr]
-> SimplCont
-> SimplM (SimplFloats, Expr InBndr)
missingAlt SimplEnv
env InBndr
case_bndr [Alt InBndr]
_ SimplCont
cont
= Bool
-> String
-> SDoc
-> SimplM (SimplFloats, Expr InBndr)
-> SimplM (SimplFloats, Expr InBndr)
forall a. HasCallStack => Bool -> String -> SDoc -> a -> a
warnPprTrace Bool
True String
"missingAlt" (InBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr InBndr
case_bndr) (SimplM (SimplFloats, Expr InBndr)
-> SimplM (SimplFloats, Expr InBndr))
-> SimplM (SimplFloats, Expr InBndr)
-> SimplM (SimplFloats, Expr InBndr)
forall a b. (a -> b) -> a -> b
$
let cont_ty :: OutType
cont_ty = SimplCont -> OutType
contResultType SimplCont
cont
in OutType -> ()
seqType OutType
cont_ty ()
-> SimplM (SimplFloats, Expr InBndr)
-> SimplM (SimplFloats, Expr InBndr)
`seq`
(SimplFloats, Expr InBndr) -> SimplM (SimplFloats, Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplEnv -> SimplFloats
emptyFloats SimplEnv
env, OutType -> Expr InBndr
mkImpossibleExpr OutType
cont_ty)
mkDupableCaseCont :: SimplEnv -> [InAlt] -> SimplCont
-> SimplM ( SimplFloats
, SimplEnv
, SimplCont)
mkDupableCaseCont :: SimplEnv
-> [Alt InBndr]
-> SimplCont
-> SimplM (SimplFloats, SimplEnv, SimplCont)
mkDupableCaseCont SimplEnv
env [Alt InBndr]
alts SimplCont
cont
| [Alt InBndr] -> Bool
altsWouldDup [Alt InBndr]
alts = do { (SimplFloats
floats, SimplCont
cont) <- SimplEnv -> SimplCont -> SimplM (SimplFloats, SimplCont)
mkDupableCont SimplEnv
env SimplCont
cont
; let env' :: SimplEnv
env' = SimplEnv -> SimplEnv
bumpCaseDepth (SimplEnv -> SimplEnv) -> SimplEnv -> SimplEnv
forall a b. (a -> b) -> a -> b
$
SimplEnv
env SimplEnv -> SimplFloats -> SimplEnv
`setInScopeFromF` SimplFloats
floats
; (SimplFloats, SimplEnv, SimplCont)
-> SimplM (SimplFloats, SimplEnv, SimplCont)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplFloats
floats, SimplEnv
env', SimplCont
cont) }
| Bool
otherwise = (SimplFloats, SimplEnv, SimplCont)
-> SimplM (SimplFloats, SimplEnv, SimplCont)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplEnv -> SimplFloats
emptyFloats SimplEnv
env, SimplEnv
env, SimplCont
cont)
altsWouldDup :: [InAlt] -> Bool
altsWouldDup :: [Alt InBndr] -> Bool
altsWouldDup [] = Bool
False
altsWouldDup [Alt InBndr
_] = Bool
False
altsWouldDup (Alt InBndr
alt:[Alt InBndr]
alts)
| Alt InBndr -> Bool
is_bot_alt Alt InBndr
alt = [Alt InBndr] -> Bool
altsWouldDup [Alt InBndr]
alts
| Bool
otherwise = Bool -> Bool
not ((Alt InBndr -> Bool) -> [Alt InBndr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Alt InBndr -> Bool
is_bot_alt [Alt InBndr]
alts)
where
is_bot_alt :: Alt InBndr -> Bool
is_bot_alt (Alt AltCon
_ [InBndr]
_ Expr InBndr
rhs) = Expr InBndr -> Bool
exprIsDeadEnd Expr InBndr
rhs
mkDupableCont :: SimplEnv
-> SimplCont
-> SimplM ( SimplFloats
, SimplCont)
mkDupableCont :: SimplEnv -> SimplCont -> SimplM (SimplFloats, SimplCont)
mkDupableCont SimplEnv
env SimplCont
cont
= SimplEnv
-> [Demand] -> SimplCont -> SimplM (SimplFloats, SimplCont)
mkDupableContWithDmds SimplEnv
env (Demand -> [Demand]
forall a. a -> [a]
repeat Demand
topDmd) SimplCont
cont
mkDupableContWithDmds
:: SimplEnv -> [Demand]
-> SimplCont -> SimplM ( SimplFloats, SimplCont)
mkDupableContWithDmds :: SimplEnv
-> [Demand] -> SimplCont -> SimplM (SimplFloats, SimplCont)
mkDupableContWithDmds SimplEnv
env [Demand]
_ SimplCont
cont
| SimplCont -> Bool
contIsDupable SimplCont
cont
= (SimplFloats, SimplCont) -> SimplM (SimplFloats, SimplCont)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplEnv -> SimplFloats
emptyFloats SimplEnv
env, SimplCont
cont)
mkDupableContWithDmds SimplEnv
_ [Demand]
_ (Stop {}) = String -> SimplM (SimplFloats, SimplCont)
forall a. String -> a
panic String
"mkDupableCont"
mkDupableContWithDmds SimplEnv
env [Demand]
dmds (CastIt Coercion
ty SimplCont
cont)
= do { (SimplFloats
floats, SimplCont
cont') <- SimplEnv
-> [Demand] -> SimplCont -> SimplM (SimplFloats, SimplCont)
mkDupableContWithDmds SimplEnv
env [Demand]
dmds SimplCont
cont
; (SimplFloats, SimplCont) -> SimplM (SimplFloats, SimplCont)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplFloats
floats, Coercion -> SimplCont -> SimplCont
CastIt Coercion
ty SimplCont
cont') }
mkDupableContWithDmds SimplEnv
env [Demand]
dmds (TickIt CoreTickish
t SimplCont
cont)
= do { (SimplFloats
floats, SimplCont
cont') <- SimplEnv
-> [Demand] -> SimplCont -> SimplM (SimplFloats, SimplCont)
mkDupableContWithDmds SimplEnv
env [Demand]
dmds SimplCont
cont
; (SimplFloats, SimplCont) -> SimplM (SimplFloats, SimplCont)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplFloats
floats, CoreTickish -> SimplCont -> SimplCont
TickIt CoreTickish
t SimplCont
cont') }
mkDupableContWithDmds SimplEnv
env [Demand]
_
(StrictBind { sc_bndr :: SimplCont -> InBndr
sc_bndr = InBndr
bndr, sc_body :: SimplCont -> Expr InBndr
sc_body = Expr InBndr
body
, sc_env :: SimplCont -> SimplEnv
sc_env = SimplEnv
se, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont})
= do { let sb_env :: SimplEnv
sb_env = SimplEnv
se SimplEnv -> SimplEnv -> SimplEnv
`setInScopeFromE` SimplEnv
env
; (SimplEnv
sb_env1, InBndr
bndr') <- SimplEnv -> InBndr -> SimplM (SimplEnv, InBndr)
simplBinder SimplEnv
sb_env InBndr
bndr
; (SimplFloats
floats1, Expr InBndr
join_inner) <- SimplEnv
-> Expr InBndr -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
simplLam SimplEnv
sb_env1 Expr InBndr
body SimplCont
cont
; let join_body :: Expr InBndr
join_body = SimplFloats -> Expr InBndr -> Expr InBndr
wrapFloats SimplFloats
floats1 Expr InBndr
join_inner
res_ty :: OutType
res_ty = SimplCont -> OutType
contResultType SimplCont
cont
; SimplEnv
-> InBndr
-> Expr InBndr
-> OutType
-> SimplM (SimplFloats, SimplCont)
mkDupableStrictBind SimplEnv
env InBndr
bndr' Expr InBndr
join_body OutType
res_ty }
mkDupableContWithDmds SimplEnv
env [Demand]
_
(StrictArg { sc_fun :: SimplCont -> ArgInfo
sc_fun = ArgInfo
fun, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont
, sc_fun_ty :: SimplCont -> OutType
sc_fun_ty = OutType
fun_ty })
| Maybe DataCon -> Bool
forall a. Maybe a -> Bool
isNothing (InBndr -> Maybe DataCon
isDataConId_maybe (ArgInfo -> InBndr
ai_fun ArgInfo
fun))
, SimplCont -> Bool
thumbsUpPlanA SimplCont
cont
=
do { let (Demand
_ : [Demand]
dmds) = ArgInfo -> [Demand]
ai_dmds ArgInfo
fun
; (SimplFloats
floats1, SimplCont
cont') <- SimplEnv
-> [Demand] -> SimplCont -> SimplM (SimplFloats, SimplCont)
mkDupableContWithDmds SimplEnv
env [Demand]
dmds SimplCont
cont
; ([LetFloats]
floats_s, [ArgSpec]
args') <- (ArgSpec -> SimplM (LetFloats, ArgSpec))
-> [ArgSpec] -> SimplM ([LetFloats], [ArgSpec])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM (HasDebugCallStack =>
SimplEnv -> ArgSpec -> SimplM (LetFloats, ArgSpec)
SimplEnv -> ArgSpec -> SimplM (LetFloats, ArgSpec)
makeTrivialArg SimplEnv
env)
(ArgInfo -> [ArgSpec]
ai_args ArgInfo
fun)
; (SimplFloats, SimplCont) -> SimplM (SimplFloats, SimplCont)
forall (m :: * -> *) a. Monad m => a -> m a
return ( (SimplFloats -> LetFloats -> SimplFloats)
-> SimplFloats -> [LetFloats] -> SimplFloats
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' SimplFloats -> LetFloats -> SimplFloats
addLetFloats SimplFloats
floats1 [LetFloats]
floats_s
, StrictArg :: DupFlag -> ArgInfo -> OutType -> SimplCont -> SimplCont
StrictArg { sc_fun :: ArgInfo
sc_fun = ArgInfo
fun { ai_args :: [ArgSpec]
ai_args = [ArgSpec]
args' }
, sc_cont :: SimplCont
sc_cont = SimplCont
cont'
, sc_fun_ty :: OutType
sc_fun_ty = OutType
fun_ty
, sc_dup :: DupFlag
sc_dup = DupFlag
OkToDup} ) }
| Bool
otherwise
=
do { let rhs_ty :: OutType
rhs_ty = SimplCont -> OutType
contResultType SimplCont
cont
(OutType
m,OutType
arg_ty,OutType
_) = OutType -> (OutType, OutType, OutType)
splitFunTy OutType
fun_ty
; InBndr
arg_bndr <- FastString -> OutType -> OutType -> SimplM InBndr
newId (String -> FastString
fsLit String
"arg") OutType
m OutType
arg_ty
; let env' :: SimplEnv
env' = SimplEnv
env SimplEnv -> [InBndr] -> SimplEnv
`addNewInScopeIds` [InBndr
arg_bndr]
; (SimplFloats
floats, Expr InBndr
join_rhs) <- SimplEnv
-> ArgInfo -> SimplCont -> SimplM (SimplFloats, Expr InBndr)
rebuildCall SimplEnv
env' (ArgInfo -> Expr InBndr -> OutType -> ArgInfo
addValArgTo ArgInfo
fun (InBndr -> Expr InBndr
forall b. InBndr -> Expr b
Var InBndr
arg_bndr) OutType
fun_ty) SimplCont
cont
; SimplEnv
-> InBndr
-> Expr InBndr
-> OutType
-> SimplM (SimplFloats, SimplCont)
mkDupableStrictBind SimplEnv
env' InBndr
arg_bndr (SimplFloats -> Expr InBndr -> Expr InBndr
wrapFloats SimplFloats
floats Expr InBndr
join_rhs) OutType
rhs_ty }
where
thumbsUpPlanA :: SimplCont -> Bool
thumbsUpPlanA (StrictArg {}) = Bool
False
thumbsUpPlanA (CastIt Coercion
_ SimplCont
k) = SimplCont -> Bool
thumbsUpPlanA SimplCont
k
thumbsUpPlanA (TickIt CoreTickish
_ SimplCont
k) = SimplCont -> Bool
thumbsUpPlanA SimplCont
k
thumbsUpPlanA (ApplyToVal { sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
k }) = SimplCont -> Bool
thumbsUpPlanA SimplCont
k
thumbsUpPlanA (ApplyToTy { sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
k }) = SimplCont -> Bool
thumbsUpPlanA SimplCont
k
thumbsUpPlanA (Select {}) = Bool
True
thumbsUpPlanA (StrictBind {}) = Bool
True
thumbsUpPlanA (Stop {}) = Bool
True
mkDupableContWithDmds SimplEnv
env [Demand]
dmds
(ApplyToTy { sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont, sc_arg_ty :: SimplCont -> OutType
sc_arg_ty = OutType
arg_ty, sc_hole_ty :: SimplCont -> OutType
sc_hole_ty = OutType
hole_ty })
= do { (SimplFloats
floats, SimplCont
cont') <- SimplEnv
-> [Demand] -> SimplCont -> SimplM (SimplFloats, SimplCont)
mkDupableContWithDmds SimplEnv
env [Demand]
dmds SimplCont
cont
; (SimplFloats, SimplCont) -> SimplM (SimplFloats, SimplCont)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplFloats
floats, ApplyToTy :: OutType -> OutType -> SimplCont -> SimplCont
ApplyToTy { sc_cont :: SimplCont
sc_cont = SimplCont
cont'
, sc_arg_ty :: OutType
sc_arg_ty = OutType
arg_ty, sc_hole_ty :: OutType
sc_hole_ty = OutType
hole_ty }) }
mkDupableContWithDmds SimplEnv
env [Demand]
dmds
(ApplyToVal { sc_arg :: SimplCont -> Expr InBndr
sc_arg = Expr InBndr
arg, sc_dup :: SimplCont -> DupFlag
sc_dup = DupFlag
dup, sc_env :: SimplCont -> SimplEnv
sc_env = SimplEnv
se
, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont, sc_hole_ty :: SimplCont -> OutType
sc_hole_ty = OutType
hole_ty })
=
do { let (Demand
dmd:[Demand]
_) = [Demand]
dmds
; (SimplFloats
floats1, SimplCont
cont') <- SimplEnv
-> [Demand] -> SimplCont -> SimplM (SimplFloats, SimplCont)
mkDupableContWithDmds SimplEnv
env [Demand]
dmds SimplCont
cont
; let env' :: SimplEnv
env' = SimplEnv
env SimplEnv -> SimplFloats -> SimplEnv
`setInScopeFromF` SimplFloats
floats1
; (DupFlag
_, SimplEnv
se', Expr InBndr
arg') <- SimplEnv
-> DupFlag
-> SimplEnv
-> Expr InBndr
-> SimplM (DupFlag, SimplEnv, Expr InBndr)
simplArg SimplEnv
env' DupFlag
dup SimplEnv
se Expr InBndr
arg
; (LetFloats
let_floats2, Expr InBndr
arg'') <- HasDebugCallStack =>
SimplEnv
-> TopLevelFlag
-> Demand
-> FastString
-> Expr InBndr
-> SimplM (LetFloats, Expr InBndr)
SimplEnv
-> TopLevelFlag
-> Demand
-> FastString
-> Expr InBndr
-> SimplM (LetFloats, Expr InBndr)
makeTrivial SimplEnv
env TopLevelFlag
NotTopLevel Demand
dmd (String -> FastString
fsLit String
"karg") Expr InBndr
arg'
; let all_floats :: SimplFloats
all_floats = SimplFloats
floats1 SimplFloats -> LetFloats -> SimplFloats
`addLetFloats` LetFloats
let_floats2
; (SimplFloats, SimplCont) -> SimplM (SimplFloats, SimplCont)
forall (m :: * -> *) a. Monad m => a -> m a
return ( SimplFloats
all_floats
, ApplyToVal :: DupFlag
-> OutType -> Expr InBndr -> SimplEnv -> SimplCont -> SimplCont
ApplyToVal { sc_arg :: Expr InBndr
sc_arg = Expr InBndr
arg''
, sc_env :: SimplEnv
sc_env = SimplEnv
se' SimplEnv -> SimplFloats -> SimplEnv
`setInScopeFromF` SimplFloats
all_floats
, sc_dup :: DupFlag
sc_dup = DupFlag
OkToDup, sc_cont :: SimplCont
sc_cont = SimplCont
cont'
, sc_hole_ty :: OutType
sc_hole_ty = OutType
hole_ty }) }
mkDupableContWithDmds SimplEnv
env [Demand]
_
(Select { sc_bndr :: SimplCont -> InBndr
sc_bndr = InBndr
case_bndr, sc_alts :: SimplCont -> [Alt InBndr]
sc_alts = [Alt InBndr]
alts, sc_env :: SimplCont -> SimplEnv
sc_env = SimplEnv
se, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont })
=
do { Tick -> SimplM ()
tick (InBndr -> Tick
CaseOfCase InBndr
case_bndr)
; (SimplFloats
floats, SimplEnv
alt_env, SimplCont
alt_cont) <- SimplEnv
-> [Alt InBndr]
-> SimplCont
-> SimplM (SimplFloats, SimplEnv, SimplCont)
mkDupableCaseCont (SimplEnv
se SimplEnv -> SimplEnv -> SimplEnv
`setInScopeFromE` SimplEnv
env) [Alt InBndr]
alts SimplCont
cont
; let cont_scaling :: OutType
cont_scaling = SimplCont -> OutType
contHoleScaling SimplCont
cont
; (SimplEnv
alt_env', InBndr
case_bndr') <- SimplEnv -> InBndr -> SimplM (SimplEnv, InBndr)
simplBinder SimplEnv
alt_env (OutType -> InBndr -> InBndr
scaleIdBy OutType
cont_scaling InBndr
case_bndr)
; [Alt InBndr]
alts' <- (Alt InBndr -> SimplM (Alt InBndr))
-> [Alt InBndr] -> SimplM [Alt InBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SimplEnv
-> Maybe (Expr InBndr)
-> [AltCon]
-> InBndr
-> SimplCont
-> Alt InBndr
-> SimplM (Alt InBndr)
simplAlt SimplEnv
alt_env' Maybe (Expr InBndr)
forall a. Maybe a
Nothing [] InBndr
case_bndr' SimplCont
alt_cont) (OutType -> [Alt InBndr] -> [Alt InBndr]
scaleAltsBy OutType
cont_scaling [Alt InBndr]
alts)
; (JoinFloats
join_floats, [Alt InBndr]
alts'') <- (JoinFloats -> Alt InBndr -> SimplM (JoinFloats, Alt InBndr))
-> JoinFloats -> [Alt InBndr] -> SimplM (JoinFloats, [Alt InBndr])
forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM (Platform
-> InBndr
-> JoinFloats
-> Alt InBndr
-> SimplM (JoinFloats, Alt InBndr)
mkDupableAlt (DynFlags -> Platform
targetPlatform (SimplEnv -> DynFlags
seDynFlags SimplEnv
env)) InBndr
case_bndr')
JoinFloats
emptyJoinFloats [Alt InBndr]
alts'
; let all_floats :: SimplFloats
all_floats = SimplFloats
floats SimplFloats -> JoinFloats -> SimplFloats
`addJoinFloats` JoinFloats
join_floats
; (SimplFloats, SimplCont) -> SimplM (SimplFloats, SimplCont)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplFloats
all_floats
, Select :: DupFlag
-> InBndr -> [Alt InBndr] -> SimplEnv -> SimplCont -> SimplCont
Select { sc_dup :: DupFlag
sc_dup = DupFlag
OkToDup
, sc_bndr :: InBndr
sc_bndr = InBndr
case_bndr'
, sc_alts :: [Alt InBndr]
sc_alts = [Alt InBndr]
alts''
, sc_env :: SimplEnv
sc_env = SimplEnv -> SimplEnv
zapSubstEnv SimplEnv
se SimplEnv -> SimplFloats -> SimplEnv
`setInScopeFromF` SimplFloats
all_floats
, sc_cont :: SimplCont
sc_cont = OutType -> SimplCont
mkBoringStop (SimplCont -> OutType
contResultType SimplCont
cont) } ) }
mkDupableStrictBind :: SimplEnv -> OutId -> OutExpr -> OutType
-> SimplM (SimplFloats, SimplCont)
mkDupableStrictBind :: SimplEnv
-> InBndr
-> Expr InBndr
-> OutType
-> SimplM (SimplFloats, SimplCont)
mkDupableStrictBind SimplEnv
env InBndr
arg_bndr Expr InBndr
join_rhs OutType
res_ty
| Expr InBndr -> Bool
exprIsTrivial Expr InBndr
join_rhs
= (SimplFloats, SimplCont) -> SimplM (SimplFloats, SimplCont)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplEnv -> SimplFloats
emptyFloats SimplEnv
env
, StrictBind :: DupFlag
-> InBndr -> Expr InBndr -> SimplEnv -> SimplCont -> SimplCont
StrictBind { sc_bndr :: InBndr
sc_bndr = InBndr
arg_bndr
, sc_body :: Expr InBndr
sc_body = Expr InBndr
join_rhs
, sc_env :: SimplEnv
sc_env = SimplEnv -> SimplEnv
zapSubstEnv SimplEnv
env
, sc_dup :: DupFlag
sc_dup = DupFlag
OkToDup
, sc_cont :: SimplCont
sc_cont = OutType -> SimplCont
mkBoringStop OutType
res_ty } )
| Bool
otherwise
= do { InBndr
join_bndr <- [InBndr] -> OutType -> SimplM InBndr
newJoinId [InBndr
arg_bndr] OutType
res_ty
; let arg_info :: ArgInfo
arg_info = ArgInfo :: InBndr
-> [ArgSpec]
-> FunRules
-> Bool
-> [Demand]
-> [JoinArity]
-> ArgInfo
ArgInfo { ai_fun :: InBndr
ai_fun = InBndr
join_bndr
, ai_rules :: FunRules
ai_rules = FunRules
forall a. Maybe a
Nothing, ai_args :: [ArgSpec]
ai_args = []
, ai_encl :: Bool
ai_encl = Bool
False, ai_dmds :: [Demand]
ai_dmds = Demand -> [Demand]
forall a. a -> [a]
repeat Demand
topDmd
, ai_discs :: [JoinArity]
ai_discs = JoinArity -> [JoinArity]
forall a. a -> [a]
repeat JoinArity
0 }
; (SimplFloats, SimplCont) -> SimplM (SimplFloats, SimplCont)
forall (m :: * -> *) a. Monad m => a -> m a
return ( SimplFloats -> JoinFloats -> SimplFloats
addJoinFloats (SimplEnv -> SimplFloats
emptyFloats SimplEnv
env) (JoinFloats -> SimplFloats) -> JoinFloats -> SimplFloats
forall a b. (a -> b) -> a -> b
$
InBind -> JoinFloats
unitJoinFloat (InBind -> JoinFloats) -> InBind -> JoinFloats
forall a b. (a -> b) -> a -> b
$
InBndr -> Expr InBndr -> InBind
forall b. b -> Expr b -> Bind b
NonRec InBndr
join_bndr (Expr InBndr -> InBind) -> Expr InBndr -> InBind
forall a b. (a -> b) -> a -> b
$
InBndr -> Expr InBndr -> Expr InBndr
forall b. b -> Expr b -> Expr b
Lam (InBndr -> InBndr
setOneShotLambda InBndr
arg_bndr) Expr InBndr
join_rhs
, StrictArg :: DupFlag -> ArgInfo -> OutType -> SimplCont -> SimplCont
StrictArg { sc_dup :: DupFlag
sc_dup = DupFlag
OkToDup
, sc_fun :: ArgInfo
sc_fun = ArgInfo
arg_info
, sc_fun_ty :: OutType
sc_fun_ty = InBndr -> OutType
idType InBndr
join_bndr
, sc_cont :: SimplCont
sc_cont = OutType -> SimplCont
mkBoringStop OutType
res_ty
} ) }
mkDupableAlt :: Platform -> OutId
-> JoinFloats -> OutAlt
-> SimplM (JoinFloats, OutAlt)
mkDupableAlt :: Platform
-> InBndr
-> JoinFloats
-> Alt InBndr
-> SimplM (JoinFloats, Alt InBndr)
mkDupableAlt Platform
_platform InBndr
case_bndr JoinFloats
jfloats (Alt AltCon
con [InBndr]
bndrs' Expr InBndr
rhs')
| Expr InBndr -> Bool
exprIsTrivial Expr InBndr
rhs'
= (JoinFloats, Alt InBndr) -> SimplM (JoinFloats, Alt InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (JoinFloats
jfloats, AltCon -> [InBndr] -> Expr InBndr -> Alt InBndr
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [InBndr]
bndrs' Expr InBndr
rhs')
| Bool
otherwise
= do { let rhs_ty' :: OutType
rhs_ty' = HasDebugCallStack => Expr InBndr -> OutType
Expr InBndr -> OutType
exprType Expr InBndr
rhs'
final_bndrs' :: [InBndr]
final_bndrs'
| InBndr -> Bool
isDeadBinder InBndr
case_bndr = (InBndr -> Bool) -> [InBndr] -> [InBndr]
forall a. (a -> Bool) -> [a] -> [a]
filter InBndr -> Bool
abstract_over [InBndr]
bndrs'
| Bool
otherwise = [InBndr]
bndrs' [InBndr] -> [InBndr] -> [InBndr]
forall a. [a] -> [a] -> [a]
++ [InBndr
case_bndr]
abstract_over :: InBndr -> Bool
abstract_over InBndr
bndr
| InBndr -> Bool
isTyVar InBndr
bndr = Bool
True
| Bool
otherwise = Bool -> Bool
not (InBndr -> Bool
isDeadBinder InBndr
bndr)
final_args :: [Expr InBndr]
final_args = [InBndr] -> [Expr InBndr]
forall b. [InBndr] -> [Expr b]
varsToCoreExprs [InBndr]
final_bndrs'
really_final_bndrs :: [InBndr]
really_final_bndrs = (InBndr -> InBndr) -> [InBndr] -> [InBndr]
forall a b. (a -> b) -> [a] -> [b]
map InBndr -> InBndr
one_shot [InBndr]
final_bndrs'
one_shot :: InBndr -> InBndr
one_shot InBndr
v | InBndr -> Bool
isId InBndr
v = InBndr -> InBndr
setOneShotLambda InBndr
v
| Bool
otherwise = InBndr
v
join_rhs :: Expr InBndr
join_rhs = [InBndr] -> Expr InBndr -> Expr InBndr
forall b. [b] -> Expr b -> Expr b
mkLams [InBndr]
really_final_bndrs Expr InBndr
rhs'
; InBndr
join_bndr <- [InBndr] -> OutType -> SimplM InBndr
newJoinId [InBndr]
final_bndrs' OutType
rhs_ty'
; let join_call :: Expr InBndr
join_call = Expr InBndr -> [Expr InBndr] -> Expr InBndr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (InBndr -> Expr InBndr
forall b. InBndr -> Expr b
Var InBndr
join_bndr) [Expr InBndr]
final_args
alt' :: Alt InBndr
alt' = AltCon -> [InBndr] -> Expr InBndr -> Alt InBndr
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [InBndr]
bndrs' Expr InBndr
join_call
; (JoinFloats, Alt InBndr) -> SimplM (JoinFloats, Alt InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return ( JoinFloats
jfloats JoinFloats -> JoinFloats -> JoinFloats
`addJoinFlts` InBind -> JoinFloats
unitJoinFloat (InBndr -> Expr InBndr -> InBind
forall b. b -> Expr b -> Bind b
NonRec InBndr
join_bndr Expr InBndr
join_rhs)
, Alt InBndr
alt') }
simplLetUnfolding :: SimplEnv
-> BindContext
-> InId
-> OutExpr -> OutType -> ArityType
-> Unfolding -> SimplM Unfolding
simplLetUnfolding :: SimplEnv
-> BindContext
-> InBndr
-> Expr InBndr
-> OutType
-> ArityType
-> Unfolding
-> SimplM Unfolding
simplLetUnfolding SimplEnv
env BindContext
bind_cxt InBndr
id Expr InBndr
new_rhs OutType
rhs_ty ArityType
arity Unfolding
unf
| Unfolding -> Bool
isStableUnfolding Unfolding
unf
= SimplEnv
-> BindContext
-> InBndr
-> OutType
-> ArityType
-> Unfolding
-> SimplM Unfolding
simplStableUnfolding SimplEnv
env BindContext
bind_cxt InBndr
id OutType
rhs_ty ArityType
arity Unfolding
unf
| InBndr -> Bool
isExitJoinId InBndr
id
= Unfolding -> SimplM Unfolding
forall (m :: * -> *) a. Monad m => a -> m a
return Unfolding
noUnfolding
| Bool
otherwise
=
let !opts :: UnfoldingOpts
opts = SimplEnv -> UnfoldingOpts
seUnfoldingOpts SimplEnv
env
in UnfoldingOpts
-> TopLevelFlag
-> UnfoldingSource
-> InBndr
-> Expr InBndr
-> SimplM Unfolding
mkLetUnfolding UnfoldingOpts
opts (BindContext -> TopLevelFlag
bindContextLevel BindContext
bind_cxt) UnfoldingSource
InlineRhs InBndr
id Expr InBndr
new_rhs
mkLetUnfolding :: UnfoldingOpts -> TopLevelFlag -> UnfoldingSource
-> InId -> OutExpr -> SimplM Unfolding
mkLetUnfolding :: UnfoldingOpts
-> TopLevelFlag
-> UnfoldingSource
-> InBndr
-> Expr InBndr
-> SimplM Unfolding
mkLetUnfolding !UnfoldingOpts
uf_opts TopLevelFlag
top_lvl UnfoldingSource
src InBndr
id Expr InBndr
new_rhs
= Unfolding -> SimplM Unfolding
forall (m :: * -> *) a. Monad m => a -> m a
return (UnfoldingOpts
-> UnfoldingSource -> Bool -> Bool -> Expr InBndr -> Unfolding
mkUnfolding UnfoldingOpts
uf_opts UnfoldingSource
src Bool
is_top_lvl Bool
is_bottoming Expr InBndr
new_rhs)
where
!is_top_lvl :: Bool
is_top_lvl = TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl
!is_bottoming :: Bool
is_bottoming = InBndr -> Bool
isDeadEndId InBndr
id
simplStableUnfolding :: SimplEnv -> BindContext
-> InId
-> OutType
-> ArityType
-> Unfolding
->SimplM Unfolding
simplStableUnfolding :: SimplEnv
-> BindContext
-> InBndr
-> OutType
-> ArityType
-> Unfolding
-> SimplM Unfolding
simplStableUnfolding SimplEnv
env BindContext
bind_cxt InBndr
id OutType
rhs_ty ArityType
id_arity Unfolding
unf
= case Unfolding
unf of
Unfolding
NoUnfolding -> Unfolding -> SimplM Unfolding
forall (m :: * -> *) a. Monad m => a -> m a
return Unfolding
unf
Unfolding
BootUnfolding -> Unfolding -> SimplM Unfolding
forall (m :: * -> *) a. Monad m => a -> m a
return Unfolding
unf
OtherCon {} -> Unfolding -> SimplM Unfolding
forall (m :: * -> *) a. Monad m => a -> m a
return Unfolding
unf
DFunUnfolding { df_bndrs :: Unfolding -> [InBndr]
df_bndrs = [InBndr]
bndrs, df_con :: Unfolding -> DataCon
df_con = DataCon
con, df_args :: Unfolding -> [Expr InBndr]
df_args = [Expr InBndr]
args }
-> do { (SimplEnv
env', [InBndr]
bndrs') <- SimplEnv -> [InBndr] -> SimplM (SimplEnv, [InBndr])
simplBinders SimplEnv
unf_env [InBndr]
bndrs
; [Expr InBndr]
args' <- (Expr InBndr -> SimplM (Expr InBndr))
-> [Expr InBndr] -> SimplM [Expr InBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SimplEnv -> Expr InBndr -> SimplM (Expr InBndr)
simplExpr SimplEnv
env') [Expr InBndr]
args
; Unfolding -> SimplM Unfolding
forall (m :: * -> *) a. Monad m => a -> m a
return ([InBndr] -> DataCon -> [Expr InBndr] -> Unfolding
mkDFunUnfolding [InBndr]
bndrs' DataCon
con [Expr InBndr]
args') }
CoreUnfolding { uf_tmpl :: Unfolding -> Expr InBndr
uf_tmpl = Expr InBndr
expr, uf_src :: Unfolding -> UnfoldingSource
uf_src = UnfoldingSource
src, uf_guidance :: Unfolding -> UnfoldingGuidance
uf_guidance = UnfoldingGuidance
guide }
| UnfoldingSource -> Bool
isStableSource UnfoldingSource
src
-> do { Expr InBndr
expr' <- case BindContext
bind_cxt of
BC_Join SimplCont
cont ->
SimplEnv
-> InBndr -> Expr InBndr -> SimplCont -> SimplM (Expr InBndr)
simplJoinRhs SimplEnv
unf_env InBndr
id Expr InBndr
expr SimplCont
cont
BC_Let {} ->
do { Expr InBndr
expr' <- SimplEnv -> Expr InBndr -> SimplCont -> SimplM (Expr InBndr)
simplExprC SimplEnv
unf_env Expr InBndr
expr (OutType -> SimplCont
mkBoringStop OutType
rhs_ty)
; Expr InBndr -> SimplM (Expr InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr InBndr -> Expr InBndr
eta_expand Expr InBndr
expr') }
; case UnfoldingGuidance
guide of
UnfWhen { ug_arity :: UnfoldingGuidance -> JoinArity
ug_arity = JoinArity
arity
, ug_unsat_ok :: UnfoldingGuidance -> Bool
ug_unsat_ok = Bool
sat_ok
, ug_boring_ok :: UnfoldingGuidance -> Bool
ug_boring_ok = Bool
boring_ok
}
-> let !new_boring_ok :: Bool
new_boring_ok = Bool
boring_ok Bool -> Bool -> Bool
|| Expr InBndr -> Bool
inlineBoringOk Expr InBndr
expr'
guide' :: UnfoldingGuidance
guide' =
UnfWhen :: JoinArity -> Bool -> Bool -> UnfoldingGuidance
UnfWhen { ug_arity :: JoinArity
ug_arity = JoinArity
arity
, ug_unsat_ok :: Bool
ug_unsat_ok = Bool
sat_ok
, ug_boring_ok :: Bool
ug_boring_ok = Bool
new_boring_ok
}
in Unfolding -> SimplM Unfolding
forall (m :: * -> *) a. Monad m => a -> m a
return (UnfoldingSource
-> Bool -> Expr InBndr -> UnfoldingGuidance -> Unfolding
mkCoreUnfolding UnfoldingSource
src Bool
is_top_lvl Expr InBndr
expr' UnfoldingGuidance
guide')
UnfoldingGuidance
_other
-> UnfoldingOpts
-> TopLevelFlag
-> UnfoldingSource
-> InBndr
-> Expr InBndr
-> SimplM Unfolding
mkLetUnfolding UnfoldingOpts
uf_opts TopLevelFlag
top_lvl UnfoldingSource
src InBndr
id Expr InBndr
expr' }
| Bool
otherwise -> Unfolding -> SimplM Unfolding
forall (m :: * -> *) a. Monad m => a -> m a
return Unfolding
noUnfolding
where
uf_opts :: UnfoldingOpts
uf_opts = SimplEnv -> UnfoldingOpts
seUnfoldingOpts SimplEnv
env
top_lvl :: TopLevelFlag
top_lvl = BindContext -> TopLevelFlag
bindContextLevel BindContext
bind_cxt
!is_top_lvl :: Bool
is_top_lvl = TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl
act :: Activation
act = InBndr -> Activation
idInlineActivation InBndr
id
unf_env :: SimplEnv
unf_env = (SimplMode -> SimplMode) -> SimplEnv -> SimplEnv
updMode (Activation -> SimplMode -> SimplMode
updModeForStableUnfoldings Activation
act) SimplEnv
env
eta_expand :: Expr InBndr -> Expr InBndr
eta_expand Expr InBndr
expr
| Bool -> Bool
not Bool
eta_on = Expr InBndr
expr
| Expr InBndr -> Bool
exprIsTrivial Expr InBndr
expr = Expr InBndr
expr
| Bool
otherwise = InScopeSet -> ArityType -> Expr InBndr -> Expr InBndr
etaExpandAT (SimplEnv -> InScopeSet
getInScope SimplEnv
env) ArityType
id_arity Expr InBndr
expr
eta_on :: Bool
eta_on = SimplMode -> Bool
sm_eta_expand (SimplEnv -> SimplMode
getMode SimplEnv
env)
addBndrRules :: SimplEnv -> InBndr -> OutBndr
-> BindContext
-> SimplM (SimplEnv, OutBndr)
addBndrRules :: SimplEnv
-> InBndr -> InBndr -> BindContext -> SimplM (SimplEnv, InBndr)
addBndrRules SimplEnv
env InBndr
in_id InBndr
out_id BindContext
bind_cxt
| [CoreRule] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreRule]
old_rules
= (SimplEnv, InBndr) -> SimplM (SimplEnv, InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplEnv
env, InBndr
out_id)
| Bool
otherwise
= do { [CoreRule]
new_rules <- SimplEnv
-> Maybe InBndr -> [CoreRule] -> BindContext -> SimplM [CoreRule]
simplRules SimplEnv
env (InBndr -> Maybe InBndr
forall a. a -> Maybe a
Just InBndr
out_id) [CoreRule]
old_rules BindContext
bind_cxt
; let final_id :: InBndr
final_id = InBndr
out_id InBndr -> RuleInfo -> InBndr
`setIdSpecialisation` [CoreRule] -> RuleInfo
mkRuleInfo [CoreRule]
new_rules
; (SimplEnv, InBndr) -> SimplM (SimplEnv, InBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplEnv -> InBndr -> SimplEnv
modifyInScope SimplEnv
env InBndr
final_id, InBndr
final_id) }
where
old_rules :: [CoreRule]
old_rules = RuleInfo -> [CoreRule]
ruleInfoRules (InBndr -> RuleInfo
idSpecialisation InBndr
in_id)
simplImpRules :: SimplEnv -> [CoreRule] -> SimplM [CoreRule]
simplImpRules :: SimplEnv -> [CoreRule] -> SimplM [CoreRule]
simplImpRules SimplEnv
env [CoreRule]
rules
= SimplEnv
-> Maybe InBndr -> [CoreRule] -> BindContext -> SimplM [CoreRule]
simplRules SimplEnv
env Maybe InBndr
forall a. Maybe a
Nothing [CoreRule]
rules (TopLevelFlag -> RecFlag -> BindContext
BC_Let TopLevelFlag
TopLevel RecFlag
NonRecursive)
simplRules :: SimplEnv -> Maybe OutId -> [CoreRule]
-> BindContext -> SimplM [CoreRule]
simplRules :: SimplEnv
-> Maybe InBndr -> [CoreRule] -> BindContext -> SimplM [CoreRule]
simplRules SimplEnv
env Maybe InBndr
mb_new_id [CoreRule]
rules BindContext
bind_cxt
= (CoreRule -> SimplM CoreRule) -> [CoreRule] -> SimplM [CoreRule]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CoreRule -> SimplM CoreRule
simpl_rule [CoreRule]
rules
where
simpl_rule :: CoreRule -> SimplM CoreRule
simpl_rule rule :: CoreRule
rule@(BuiltinRule {})
= CoreRule -> SimplM CoreRule
forall (m :: * -> *) a. Monad m => a -> m a
return CoreRule
rule
simpl_rule rule :: CoreRule
rule@(Rule { ru_bndrs :: CoreRule -> [InBndr]
ru_bndrs = [InBndr]
bndrs, ru_args :: CoreRule -> [Expr InBndr]
ru_args = [Expr InBndr]
args
, ru_fn :: CoreRule -> Name
ru_fn = Name
fn_name, ru_rhs :: CoreRule -> Expr InBndr
ru_rhs = Expr InBndr
rhs
, ru_act :: CoreRule -> Activation
ru_act = Activation
act })
= do { (SimplEnv
env', [InBndr]
bndrs') <- SimplEnv -> [InBndr] -> SimplM (SimplEnv, [InBndr])
simplBinders SimplEnv
env [InBndr]
bndrs
; let rhs_ty :: OutType
rhs_ty = SimplEnv -> OutType -> OutType
substTy SimplEnv
env' (HasDebugCallStack => Expr InBndr -> OutType
Expr InBndr -> OutType
exprType Expr InBndr
rhs)
rhs_cont :: SimplCont
rhs_cont = case BindContext
bind_cxt of
BC_Let {} -> OutType -> SimplCont
mkBoringStop OutType
rhs_ty
BC_Join SimplCont
cont -> Bool -> SDoc -> SimplCont -> SimplCont
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr Bool
join_ok SDoc
bad_join_msg SimplCont
cont
lhs_env :: SimplEnv
lhs_env = (SimplMode -> SimplMode) -> SimplEnv -> SimplEnv
updMode SimplMode -> SimplMode
updModeForRules SimplEnv
env'
rhs_env :: SimplEnv
rhs_env = (SimplMode -> SimplMode) -> SimplEnv -> SimplEnv
updMode (Activation -> SimplMode -> SimplMode
updModeForStableUnfoldings Activation
act) SimplEnv
env'
fn_name' :: Name
fn_name' = case Maybe InBndr
mb_new_id of
Just InBndr
id -> InBndr -> Name
idName InBndr
id
Maybe InBndr
Nothing -> Name
fn_name
join_ok :: Bool
join_ok = case Maybe InBndr
mb_new_id of
Just InBndr
id | Just JoinArity
join_arity <- InBndr -> Maybe JoinArity
isJoinId_maybe InBndr
id
-> [Expr InBndr] -> JoinArity
forall (t :: * -> *) a. Foldable t => t a -> JoinArity
length [Expr InBndr]
args JoinArity -> JoinArity -> Bool
forall a. Eq a => a -> a -> Bool
== JoinArity
join_arity
Maybe InBndr
_ -> Bool
False
bad_join_msg :: SDoc
bad_join_msg = [SDoc] -> SDoc
vcat [ Maybe InBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe InBndr
mb_new_id, CoreRule -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreRule
rule
, Maybe (Maybe JoinArity) -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((InBndr -> Maybe JoinArity)
-> Maybe InBndr -> Maybe (Maybe JoinArity)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap InBndr -> Maybe JoinArity
isJoinId_maybe Maybe InBndr
mb_new_id) ]
; [Expr InBndr]
args' <- (Expr InBndr -> SimplM (Expr InBndr))
-> [Expr InBndr] -> SimplM [Expr InBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SimplEnv -> Expr InBndr -> SimplM (Expr InBndr)
simplExpr SimplEnv
lhs_env) [Expr InBndr]
args
; Expr InBndr
rhs' <- SimplEnv -> Expr InBndr -> SimplCont -> SimplM (Expr InBndr)
simplExprC SimplEnv
rhs_env Expr InBndr
rhs SimplCont
rhs_cont
; CoreRule -> SimplM CoreRule
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreRule
rule { ru_bndrs :: [InBndr]
ru_bndrs = [InBndr]
bndrs'
, ru_fn :: Name
ru_fn = Name
fn_name'
, ru_args :: [Expr InBndr]
ru_args = [Expr InBndr]
args'
, ru_rhs :: Expr InBndr
ru_rhs = Expr InBndr
rhs' }) }