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