{-# 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.Driver.Flags
import GHC.Core
import GHC.Core.Opt.Simplify.Monad
import GHC.Core.Opt.ConstantFold
import GHC.Core.Type hiding ( substCo, substTy, substTyVar, extendTvSubst, extendCvSubst )
import GHC.Core.TyCo.Compare( eqType )
import GHC.Core.Opt.Simplify.Env
import GHC.Core.Opt.Simplify.Inline
import GHC.Core.Opt.Simplify.Utils
import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs, scrutOkForBinderSwap, BinderSwapDecision (..) )
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
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.Types.Prim( realWorldStatePrimTy )
import GHC.Builtin.Names( runRWKey, seqHashKey )
import GHC.Data.Maybe ( isNothing, orElse, mapMaybe )
import GHC.Data.FastString
import GHC.Unit.Module ( moduleName )
import GHC.Utils.Outputable
import GHC.Utils.Panic
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 {
; !env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} SimplEnv -> [CoreBndr] -> SimplM SimplEnv
simplRecBndrs SimplEnv
env0 ([InBind] -> [CoreBndr]
forall b. [Bind b] -> [b]
bindersOfBinds [InBind]
binds0)
; (floats, env2) <- {-#SCC "simplTopBinds-simpl_binds" #-} simpl_binds env1 binds0
; freeTick SimplifierDone
; return (floats, 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 { (float, env1) <- SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv)
simpl_bind SimplEnv
env InBind
bind
; (floats, env2) <- simpl_binds env1 binds
; let !floats1 = SimplFloats
float SimplFloats -> SimplFloats -> SimplFloats
`addFloats` SimplFloats
floats
; return (floats1, 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
; (env', b') <- SimplEnv
-> CoreBndr
-> CoreBndr
-> BindContext
-> SimplM (SimplEnv, CoreBndr)
addBndrRules SimplEnv
env CoreBndr
b (SimplEnv -> CoreBndr -> CoreBndr
lookupRecBndr SimplEnv
env CoreBndr
b) BindContext
bind_cxt
; simplRecOrTopPair env' bind_cxt b b' 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 { (env1, 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, 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
; (rec_floats, env2) <- enterRecGroupRHSs env1 new_bndrs $ \SimplEnv
env ->
SimplEnv
-> [(CoreBndr, CoreBndr, CoreExpr)]
-> SimplM (SimplFloats, SimplEnv)
go SimplEnv
env [(CoreBndr, CoreBndr, CoreExpr)]
triples
; return (mkRecFloats rec_floats, 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 { (env', bndr') <- SimplEnv
-> CoreBndr
-> CoreBndr
-> BindContext
-> SimplM (SimplEnv, CoreBndr)
addBndrRules SimplEnv
env CoreBndr
bndr (SimplEnv -> CoreBndr -> CoreBndr
lookupRecBndr SimplEnv
env CoreBndr
bndr) BindContext
bind_cxt
; return (env', (bndr, bndr', 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 { (float, env1) <- SimplEnv
-> BindContext
-> CoreBndr
-> CoreBndr
-> CoreExpr
-> SimplM (SimplFloats, SimplEnv)
simplRecOrTopPair SimplEnv
env BindContext
bind_cxt
CoreBndr
old_bndr CoreBndr
new_bndr CoreExpr
rhs
; (floats, env2) <- go env1 pairs
; return (float `addFloats` floats, 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
$
RecFlag
-> SimplCont
-> (CoreBndr, SimplEnv)
-> (CoreBndr, SimplEnv)
-> (CoreExpr, SimplEnv)
-> SimplM (SimplFloats, SimplEnv)
simplJoinBind RecFlag
is_rec SimplCont
cont
(CoreBndr
old_bndr,SimplEnv
env) (CoreBndr
new_bndr,SimplEnv
env) (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
$
TopLevelFlag
-> RecFlag
-> (CoreBndr, SimplEnv)
-> (CoreBndr, SimplEnv)
-> (CoreExpr, SimplEnv)
-> SimplM (SimplFloats, SimplEnv)
simplLazyBind TopLevelFlag
top_lvl RecFlag
is_rec
(CoreBndr
old_bndr,SimplEnv
env) (CoreBndr
new_bndr,SimplEnv
env) (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 <- SimplM Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
if logHasDumpFlag logger Opt_D_verbose_core2core
then logTraceMsg logger herald doc thing_inside
else thing_inside
simplLazyBind :: TopLevelFlag -> RecFlag
-> (InId, SimplEnv)
-> (OutId, SimplEnv)
-> (InExpr, SimplEnv)
-> SimplM (SimplFloats, SimplEnv)
simplLazyBind :: TopLevelFlag
-> RecFlag
-> (CoreBndr, SimplEnv)
-> (CoreBndr, SimplEnv)
-> (CoreExpr, SimplEnv)
-> SimplM (SimplFloats, SimplEnv)
simplLazyBind TopLevelFlag
top_lvl RecFlag
is_rec (CoreBndr
bndr,SimplEnv
unf_se) (CoreBndr
bndr1,SimplEnv
env) (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
; (body_env, tvs') <- {-#SCC "simplBinders" #-} SimplEnv -> [CoreBndr] -> SimplM (SimplEnv, [CoreBndr])
simplBinders SimplEnv
rhs_env [CoreBndr]
tvs
; let rhs_cont = Kind -> RecFlag -> Demand -> SimplCont
mkRhsStop (HasDebugCallStack => SimplEnv -> Kind -> Kind
SimplEnv -> Kind -> Kind
substTy SimplEnv
body_env (HasDebugCallStack => CoreExpr -> Kind
CoreExpr -> Kind
exprType CoreExpr
body))
RecFlag
is_rec (CoreBndr -> Demand
idDemandInfo CoreBndr
bndr)
; (body_floats0, body0) <- {-#SCC "simplExprF" #-} simplExprF body_env body rhs_cont
; (body_floats2, body2) <- {-#SCC "prepareBinding" #-}
prepareBinding env top_lvl is_rec
False
bndr1 body_floats0 body0
; (rhs_floats, body3)
<- if isEmptyFloats body_floats2 || null tvs then
{-#SCC "simplLazyBind-simple-floating" #-}
return (body_floats2, body2)
else
{-#SCC "simplLazyBind-type-abstraction-first" #-}
do { (poly_binds, body3) <- abstractFloats (seUnfoldingOpts env) top_lvl
tvs' body_floats2 body2
; let 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
; return (poly_floats, body3) }
; let env1 = SimplEnv
env SimplEnv -> SimplFloats -> SimplEnv
`setInScopeFromF` SimplFloats
rhs_floats
; rhs' <- rebuildLam env1 tvs' body3 rhs_cont
; (bind_float, env2) <- completeBind (BC_Let top_lvl is_rec) (bndr,unf_se) (bndr1,rhs',env1)
; return (rhs_floats `addFloats` bind_float, env2) }
simplJoinBind :: RecFlag
-> SimplCont
-> (InId, SimplEnv)
-> (OutId, SimplEnv)
-> (InExpr, SimplEnv)
-> SimplM (SimplFloats, SimplEnv)
simplJoinBind :: RecFlag
-> SimplCont
-> (CoreBndr, SimplEnv)
-> (CoreBndr, SimplEnv)
-> (CoreExpr, SimplEnv)
-> SimplM (SimplFloats, SimplEnv)
simplJoinBind RecFlag
is_rec SimplCont
cont (CoreBndr
old_bndr, SimplEnv
unf_se) (CoreBndr
new_bndr, SimplEnv
env) (CoreExpr
rhs, SimplEnv
rhs_se)
= do { let rhs_env :: SimplEnv
rhs_env = SimplEnv
rhs_se SimplEnv -> SimplEnv -> SimplEnv
`setInScopeFromE` SimplEnv
env
; rhs' <- SimplEnv -> CoreBndr -> CoreExpr -> SimplCont -> SimplM CoreExpr
simplJoinRhs SimplEnv
rhs_env CoreBndr
old_bndr CoreExpr
rhs SimplCont
cont
; completeBind (BC_Join is_rec cont) (old_bndr, unf_se) (new_bndr, rhs', env) }
simplAuxBind :: String
-> SimplEnv
-> InId
-> OutExpr
-> SimplM (SimplFloats, SimplEnv)
simplAuxBind :: String
-> SimplEnv
-> CoreBndr
-> CoreExpr
-> SimplM (SimplFloats, SimplEnv)
simplAuxBind String
_str 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
Bool -> Bool -> Bool
|| case (CoreBndr -> OccInfo
idOccInfo CoreBndr
bndr) of
OneOcc{ occ_n_br :: OccInfo -> Int
occ_n_br = Int
1, occ_in_lam :: OccInfo -> InsideLam
occ_in_lam = InsideLam
NotInsideLam } -> Bool
True
OccInfo
_ -> Bool
False
= (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 -> CoreExpr -> SimplEnv
extendCvIdSubst SimplEnv
env CoreBndr
bndr CoreExpr
new_rhs )
| Bool
otherwise
= do {
let !occ_fs :: FastString
occ_fs = CoreBndr -> FastString
forall a. NamedThing a => a -> FastString
getOccFS CoreBndr
bndr
; (anf_floats, rhs1) <- HasDebugCallStack =>
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
; unless (isEmptyLetFloats anf_floats) (tick LetFloatFromLet)
; let rhs_floats = SimplEnv -> SimplFloats
emptyFloats SimplEnv
env SimplFloats -> LetFloats -> SimplFloats
`addLetFloats` LetFloats
anf_floats
; (env1, new_bndr) <- simplBinder (env `setInScopeFromF` rhs_floats) bndr
; (bind_float, env2) <- completeBind (BC_Let NotTopLevel NonRecursive)
(bndr,env) (new_bndr, rhs1, env1)
; return (rhs_floats `addFloats` bind_float, env2) }
tryCastWorkerWrapper :: SimplEnv -> BindContext
-> InId -> OutId -> OutExpr
-> SimplM (SimplFloats, SimplEnv)
tryCastWorkerWrapper :: SimplEnv
-> BindContext
-> CoreBndr
-> CoreBndr
-> CoreExpr
-> SimplM (SimplFloats, SimplEnv)
tryCastWorkerWrapper SimplEnv
env BindContext
bind_cxt CoreBndr
old_bndr CoreBndr
bndr (Cast CoreExpr
rhs CoercionR
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)
, HasDebugCallStack => Kind -> Bool
Kind -> Bool
typeHasFixedRuntimeRep Kind
work_ty
, Bool -> Bool
not (InlinePragma -> Bool
isOpaquePragma (CoreBndr -> InlinePragma
idInlinePragma CoreBndr
old_bndr))
= do { uniq <- SimplM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
; let work_name = Unique -> FastString -> Name
mkSystemVarName Unique
uniq FastString
occ_fs
work_id = HasDebugCallStack => Name -> Kind -> Kind -> IdInfo -> CoreBndr
Name -> Kind -> Kind -> IdInfo -> CoreBndr
mkLocalIdWithInfo Name
work_name Kind
ManyTy Kind
work_ty IdInfo
work_info
is_strict = CoreBndr -> Bool
isStrictId CoreBndr
bndr
; (rhs_floats, work_rhs) <- prepareBinding env top_lvl is_rec is_strict
work_id (emptyFloats env) rhs
; work_unf <- mk_worker_unfolding top_lvl work_id work_rhs
; let work_id_w_unf = CoreBndr
work_id CoreBndr -> Unfolding -> CoreBndr
`setIdUnfolding` Unfolding
work_unf
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 -> CoercionR -> CoreExpr
forall b. Expr b -> CoercionR -> Expr b
Cast (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
work_id_w_unf) CoercionR
co
; if postInlineUnconditionally env bind_cxt old_bndr bndr triv_rhs
then do { tick (PostInlineUnconditionally bndr)
; return ( floats
, extendIdSubst (setInScopeFromF env floats) old_bndr $
DoneEx triv_rhs NotJoinPoint ) }
else do { wrap_unf <- mkLetUnfolding env top_lvl VanillaSrc bndr False triv_rhs
; let 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 -> InBind -> SimplFloats
`extendFloats` CoreBndr -> CoreExpr -> InBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
bndr' CoreExpr
triv_rhs
; return ( floats', setInScopeFromF env floats' ) } }
where
!occ_fs :: FastString
occ_fs = CoreBndr -> FastString
forall a. NamedThing a => a -> FastString
getOccFS CoreBndr
bndr
work_ty :: Kind
work_ty = HasDebugCallStack => CoercionR -> Kind
CoercionR -> Kind
coercionLKind CoercionR
co
info :: IdInfo
info = HasDebugCallStack => 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
_ -> SimplEnv
-> TopLevelFlag
-> UnfoldingSource
-> CoreBndr
-> Bool
-> CoreExpr
-> SimplM Unfolding
mkLetUnfolding SimplEnv
env TopLevelFlag
top_lvl UnfoldingSource
VanillaSrc CoreBndr
work_id Bool
False CoreExpr
work_rhs
tryCastWorkerWrapper SimplEnv
env BindContext
_ CoreBndr
_ 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 = FastString -> SourceText
SourceText (FastString -> SourceText) -> FastString -> SourceText
forall a b. (a -> b) -> a -> b
$ String -> FastString
fsLit 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
; (anf_floats, rhs2) <- HasDebugCallStack =>
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
rhs_floats1 SimplFloats -> LetFloats -> SimplFloats
`addLetFloats` LetFloats
anf_floats
; if doFloatFromRhs (seFloatEnable env) top_lvl is_rec strict_bind all_floats rhs2
then
do { tick LetFloatFromLet
; return (all_floats, rhs2) }
else
return (emptyFloats env, wrapFloats rhs_floats1 rhs1) }
prepareRhs :: HasDebugCallStack
=> SimplEnv -> TopLevelFlag
-> FastString
-> OutExpr
-> SimplM (LetFloats, OutExpr)
prepareRhs :: HasDebugCallStack =>
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 CoercionR
_) 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 CoercionR
co)
= do { (floats, rhs') <- CoreExpr -> SimplM (LetFloats, CoreExpr)
anfise CoreExpr
rhs
; return (floats, Cast rhs' co) }
anfise (App CoreExpr
fun (Type Kind
ty))
= do { (floats, rhs') <- CoreExpr -> SimplM (LetFloats, CoreExpr)
anfise CoreExpr
fun
; return (floats, App rhs' (Type ty)) }
anfise (App CoreExpr
fun CoreExpr
arg)
= do { (floats1, fun') <- CoreExpr -> SimplM (LetFloats, CoreExpr)
anfise CoreExpr
fun
; (floats2, arg') <- makeTrivial env top_lvl topDmd occ arg
; return (floats1 `addLetFlts` floats2, App fun' 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 { (floats, rhs') <- CoreExpr -> SimplM (LetFloats, CoreExpr)
anfise CoreExpr
rhs
; return (floats, Tick t 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 { (floats, rhs') <- CoreExpr -> SimplM (LetFloats, CoreExpr)
anfise CoreExpr
rhs
; let 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
-> ((CoreBndr, CoreExpr) -> (CoreBndr, CoreExpr)) -> LetFloats
mapLetFloats LetFloats
floats (CoreBndr, CoreExpr) -> (CoreBndr, CoreExpr)
tickIt
; return (floats', Tick t 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 :: HasDebugCallStack =>
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 { (floats, e') <- HasDebugCallStack =>
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
; return (floats, 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 :: HasDebugCallStack =>
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' CoercionR
co <- CoreExpr
expr
= do { (floats, triv_expr) <- HasDebugCallStack =>
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'
; return (floats, Cast triv_expr co) }
| Bool
otherwise
= do { (floats, expr1) <- HasDebugCallStack =>
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
; uniq <- getUniqueM
; let name = Unique -> FastString -> Name
mkSystemVarName Unique
uniq FastString
occ_fs
var = HasDebugCallStack => Name -> Kind -> Kind -> IdInfo -> CoreBndr
Name -> Kind -> Kind -> IdInfo -> CoreBndr
mkLocalIdWithInfo Name
name Kind
ManyTy Kind
expr_ty IdInfo
id_info
; (arity_type, expr2) <- tryEtaExpandRhs env (BC_Let top_lvl NonRecursive) var expr1
; unf <- mkLetUnfolding env top_lvl VanillaSrc var False expr2
; let final_id = CoreBndr -> ArityType -> Unfolding -> CoreBndr
addLetBndrInfo CoreBndr
var ArityType
arity_type Unfolding
unf
bind = CoreBndr -> CoreExpr -> InBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
final_id CoreExpr
expr2
; traceSmpl "makeTrivial" (vcat [text "final_id" <+> ppr final_id, text "rhs" <+> ppr expr2 ])
; return ( floats `addLetFlts` unitLetFloat bind, Var final_id ) }
where
id_info :: IdInfo
id_info = IdInfo
vanillaIdInfo IdInfo -> Demand -> IdInfo
`setDemandInfo` Demand
dmd
expr_ty :: Kind
expr_ty = HasDebugCallStack => CoreExpr -> Kind
CoreExpr -> Kind
exprType CoreExpr
expr
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 :: BindContext
-> (InId, SimplEnv)
-> (OutId, OutExpr, SimplEnv)
-> SimplM (SimplFloats, SimplEnv)
completeBind :: BindContext
-> (CoreBndr, SimplEnv)
-> (CoreBndr, CoreExpr, SimplEnv)
-> SimplM (SimplFloats, SimplEnv)
completeBind BindContext
bind_cxt (CoreBndr
old_bndr, SimplEnv
unf_se) (CoreBndr
new_bndr, CoreExpr
new_rhs, SimplEnv
env)
| CoreBndr -> Bool
isCoVar CoreBndr
old_bndr
= case CoreExpr
new_rhs of
Coercion CoercionR
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 -> CoercionR -> SimplEnv
extendCvSubst SimplEnv
env CoreBndr
old_bndr CoercionR
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 = HasDebugCallStack => CoreBndr -> IdInfo
CoreBndr -> IdInfo
idInfo CoreBndr
old_bndr
old_unf :: Unfolding
old_unf = IdInfo -> Unfolding
realUnfoldingInfo IdInfo
old_info
; (new_arity, eta_rhs) <- SimplEnv
-> BindContext
-> CoreBndr
-> CoreExpr
-> SimplM (ArityType, CoreExpr)
tryEtaExpandRhs SimplEnv
env BindContext
bind_cxt CoreBndr
new_bndr CoreExpr
new_rhs
; new_unfolding <- simplLetUnfolding (unf_se `setInScopeFromE` env)
bind_cxt old_bndr
eta_rhs (idType new_bndr) new_arity old_unf
; let new_bndr_w_info = CoreBndr -> ArityType -> Unfolding -> CoreBndr
addLetBndrInfo CoreBndr
new_bndr ArityType
new_arity Unfolding
new_unfolding
; if postInlineUnconditionally env bind_cxt old_bndr new_bndr_w_info eta_rhs
then
do { tick (PostInlineUnconditionally old_bndr)
; let unf_rhs = Unfolding -> Maybe CoreExpr
maybeUnfoldingTemplate Unfolding
new_unfolding Maybe CoreExpr -> CoreExpr -> CoreExpr
forall a. Maybe a -> a -> a
`orElse` CoreExpr
eta_rhs
; simplTrace "PostInlineUnconditionally" (ppr new_bndr <+> ppr unf_rhs) $
return ( emptyFloats env
, extendIdSubst env old_bndr $
DoneEx unf_rhs (idJoinPointHood new_bndr)) }
else
tryCastWorkerWrapper env bind_cxt old_bndr new_bndr_w_info 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 = HasDebugCallStack => 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
lazifyDemandInfo 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 { ty' <- SimplEnv -> Kind -> SimplM Kind
simplType SimplEnv
env Kind
ty
; return (Type 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 = HasDebugCallStack => SimplEnv -> Kind -> Kind
SimplEnv -> Kind -> Kind
substTy SimplEnv
env (HasDebugCallStack => 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 { (floats, expr') <- SimplEnv -> CoreExpr -> SimplCont -> SimplM (SimplFloats, CoreExpr)
simplExprF SimplEnv
env CoreExpr
expr SimplCont
cont
;
return (wrapFloats floats expr') }
simplExprF :: SimplEnv
-> InExpr
-> SimplCont
-> SimplM (SimplFloats, OutExpr)
simplExprF :: SimplEnv -> CoreExpr -> SimplCont -> SimplM (SimplFloats, CoreExpr)
simplExprF !SimplEnv
env CoreExpr
e !SimplCont
cont
=
HasDebugCallStack =>
SimplEnv -> CoreExpr -> SimplCont -> SimplM (SimplFloats, CoreExpr)
SimplEnv -> CoreExpr -> SimplCont -> SimplM (SimplFloats, CoreExpr)
simplExprF1 SimplEnv
env CoreExpr
e SimplCont
cont
simplExprF1 :: HasDebugCallStack
=> SimplEnv -> InExpr -> SimplCont
-> SimplM (SimplFloats, OutExpr)
simplExprF1 :: HasDebugCallStack =>
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 CoercionR
co) SimplCont
cont = {-#SCC "simplCast" #-} SimplEnv
-> CoreExpr
-> CoercionR
-> SimplCont
-> SimplM (SimplFloats, CoreExpr)
simplCast SimplEnv
env CoreExpr
body CoercionR
co SimplCont
cont
simplExprF1 SimplEnv
env (Coercion CoercionR
co) SimplCont
cont = {-#SCC "simplCoercionF" #-} SimplEnv
-> CoercionR -> SimplCont -> SimplM (SimplFloats, CoreExpr)
simplCoercionF SimplEnv
env CoercionR
co SimplCont
cont
simplExprF1 SimplEnv
env (App CoreExpr
fun CoreExpr
arg) SimplCont
cont
= {-#SCC "simplExprF1-App" #-} case CoreExpr
arg of
Type Kind
ty -> do {
arg' <- SimplEnv -> Kind -> SimplM Kind
simplType SimplEnv
env Kind
ty
; let hole' = HasDebugCallStack => SimplEnv -> Kind -> Kind
SimplEnv -> Kind -> Kind
substTy SimplEnv
env (HasDebugCallStack => CoreExpr -> Kind
CoreExpr -> Kind
exprType CoreExpr
fun)
; simplExprF env fun $
ApplyToTy { sc_arg_ty = arg'
, sc_hole_ty = hole'
, sc_cont = 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 = HasDebugCallStack => SimplEnv -> Kind -> Kind
SimplEnv -> Kind -> Kind
substTy SimplEnv
env (HasDebugCallStack => 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 { ty' <- SimplEnv -> Kind -> SimplM Kind
simplType SimplEnv
env Kind
ty
; simplExprF (extendTvSubst env bndr ty') body 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" #-}
HasDebugCallStack =>
SimplEnv
-> FromWhat
-> CoreBndr
-> (CoreExpr, SimplEnv)
-> CoreExpr
-> SimplCont
-> SimplM (SimplFloats, CoreExpr)
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
| JoinPoint Int
arity <- CoreBndr -> JoinPointHood
idJoinPointHood 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
; (env', 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)
; join_body' <- simplExprC env' join_body cont
; return $ mkLams join_bndrs' 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 = HasDebugCallStack => SimplEnv -> Kind -> Kind
SimplEnv -> Kind -> Kind
substTy SimplEnv
env Kind
ty
simplCoercionF :: SimplEnv -> InCoercion -> SimplCont
-> SimplM (SimplFloats, OutExpr)
simplCoercionF :: SimplEnv
-> CoercionR -> SimplCont -> SimplM (SimplFloats, CoreExpr)
simplCoercionF SimplEnv
env CoercionR
co SimplCont
cont
= do { co' <- SimplEnv -> CoercionR -> SimplM CoercionR
simplCoercion SimplEnv
env CoercionR
co
; rebuild env (Coercion co') cont }
simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion
simplCoercion :: SimplEnv -> CoercionR -> SimplM CoercionR
simplCoercion SimplEnv
env CoercionR
co
= do { let opt_co :: CoercionR
opt_co | SimplEnv -> Bool
reSimplifying SimplEnv
env = SimplEnv -> CoercionR -> CoercionR
substCo SimplEnv
env CoercionR
co
| Bool
otherwise = OptCoercionOpts -> Subst -> CoercionR -> CoercionR
optCoercion OptCoercionOpts
opts Subst
subst CoercionR
co
; CoercionR -> ()
seqCo CoercionR
opt_co () -> SimplM CoercionR -> SimplM CoercionR
forall a b. a -> b -> b
`seq` CoercionR -> SimplM CoercionR
forall a. a -> SimplM a
forall (m :: * -> *) a. Monad m => a -> m a
return CoercionR
opt_co }
where
subst :: Subst
subst = SimplEnv -> Subst
getSubst SimplEnv
env
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 { (floats, expr') <- SimplEnv -> CoreExpr -> SimplCont -> SimplM (SimplFloats, CoreExpr)
simplExprF SimplEnv
env CoreExpr
expr SimplCont
cont
; return (floats, mkTick tickish 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
; (floats, expr1) <- SimplEnv -> CoreExpr -> SimplCont -> SimplM (SimplFloats, CoreExpr)
simplExprF SimplEnv
env CoreExpr
expr SimplCont
inc
; let expr2 = SimplFloats -> CoreExpr -> CoreExpr
wrapFloats SimplFloats
floats CoreExpr
expr1
tickish' = SimplEnv -> CoreTickish -> CoreTickish
forall {pass :: TickishPass}.
(XTickishId pass ~ CoreBndr) =>
SimplEnv -> GenTickish pass -> GenTickish pass
simplTickish SimplEnv
env CoreTickish
tickish
; rebuild env (mkTick tickish' expr2) outc
}
simplTickish :: SimplEnv -> GenTickish pass -> GenTickish pass
simplTickish SimplEnv
env GenTickish pass
tickish
| Breakpoint XBreakpoint pass
ext Int
n [XTickishId pass]
ids Module
modl <- GenTickish pass
tickish
= XBreakpoint pass
-> Int -> [XTickishId pass] -> Module -> GenTickish pass
forall (pass :: TickishPass).
XBreakpoint pass
-> Int -> [XTickishId pass] -> Module -> GenTickish pass
Breakpoint XBreakpoint pass
ext Int
n ((CoreBndr -> Maybe CoreBndr) -> [CoreBndr] -> [CoreBndr]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (SimplSR -> Maybe CoreBndr
getDoneId (SimplSR -> Maybe CoreBndr)
-> (CoreBndr -> SimplSR) -> CoreBndr -> Maybe CoreBndr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimplEnv -> CoreBndr -> SimplSR
substId SimplEnv
env) [CoreBndr]
[XTickishId pass]
ids) Module
modl
| 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 cont :: SimplCont
cont@(CastIt { 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 SimplCont
other = (Kind -> SimplCont
mkBoringStop (SimplCont -> Kind
contHoleType SimplCont
other), SimplCont
other)
getDoneId :: SimplSR -> Maybe CoreBndr
getDoneId (DoneId CoreBndr
id) = CoreBndr -> Maybe CoreBndr
forall a. a -> Maybe a
Just CoreBndr
id
getDoneId (DoneEx (Var CoreBndr
id) JoinPointHood
_) = CoreBndr -> Maybe CoreBndr
forall a. a -> Maybe a
Just CoreBndr
id
getDoneId (DoneEx CoreExpr
e JoinPointHood
_) = CoreExpr -> Maybe CoreBndr
getIdFromTrivialExpr_maybe CoreExpr
e
getDoneId SimplSR
other = String -> SDoc -> Maybe 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 { sc_co :: SimplCont -> CoercionR
sc_co = CoercionR
co, sc_opt :: SimplCont -> Bool
sc_opt = Bool
opt, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont }
-> SimplEnv -> CoreExpr -> SimplCont -> SimplM (SimplFloats, CoreExpr)
rebuild SimplEnv
env (HasDebugCallStack => CoreExpr -> CoercionR -> CoreExpr
CoreExpr -> CoercionR -> CoreExpr
mkCast CoreExpr
expr CoercionR
co') SimplCont
cont
where
co' :: CoercionR
co' = SimplEnv -> CoercionR -> Bool -> CoercionR
optOutCoercion SimplEnv
env CoercionR
co Bool
opt
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 { (_, _, arg') <- SimplEnv
-> DupFlag
-> Kind
-> Maybe ArgInfo
-> SimplEnv
-> CoreExpr
-> SimplM (DupFlag, SimplEnv, CoreExpr)
simplLazyArg SimplEnv
env DupFlag
dup_flag Kind
fun_ty Maybe ArgInfo
forall a. Maybe a
Nothing SimplEnv
se CoreExpr
arg
; rebuild env (App expr arg') 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 Levity
arg_levity <- FromWhat
from_what
, Levity -> CoreExpr -> Bool
needsCaseBindingL Levity
arg_levity CoreExpr
rhs
= do { (env1, bndr1) <- SimplEnv -> CoreBndr -> SimplM (SimplEnv, CoreBndr)
simplNonRecBndr SimplEnv
env CoreBndr
bndr
; (floats, expr') <- simplNonRecBody env1 from_what body cont
; let expr'' = SimplFloats -> CoreExpr -> CoreExpr
wrapFloats SimplFloats
floats CoreExpr
expr'
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'']
; return (emptyFloats env, case_expr) }
| Bool
otherwise
= do { (env1, bndr1) <- SimplEnv -> CoreBndr -> SimplM (SimplEnv, CoreBndr)
simplNonRecBndr SimplEnv
env CoreBndr
bndr
; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive)
; let is_strict = CoreBndr -> Bool
isStrictId CoreBndr
bndr2
; (rhs_floats, rhs1) <- prepareBinding env NotTopLevel NonRecursive is_strict
bndr2 (emptyFloats env) rhs
; let env3 = SimplEnv
env2 SimplEnv -> SimplFloats -> SimplEnv
`setInScopeFromF` SimplFloats
rhs_floats
; (bind_float, env4) <- completeBind (BC_Let NotTopLevel NonRecursive)
(bndr,env) (bndr2, rhs1, env3)
; (body_floats, body') <- simplNonRecBody env4 from_what body cont
; let all_floats = SimplFloats
rhs_floats SimplFloats -> SimplFloats -> SimplFloats
`addFloats` SimplFloats
bind_float SimplFloats -> SimplFloats -> SimplFloats
`addFloats` SimplFloats
body_floats
; return ( all_floats, body' ) }
optOutCoercion :: SimplEnv -> OutCoercion -> Bool -> OutCoercion
optOutCoercion :: SimplEnv -> CoercionR -> Bool -> CoercionR
optOutCoercion SimplEnv
env CoercionR
co Bool
already_optimised
| Bool
already_optimised = CoercionR
co
| Bool
otherwise = OptCoercionOpts -> Subst -> CoercionR -> CoercionR
optCoercion OptCoercionOpts
opts Subst
empty_subst CoercionR
co
where
empty_subst :: Subst
empty_subst = InScopeSet -> Subst
mkEmptySubst (SimplEnv -> InScopeSet
seInScope SimplEnv
env)
opts :: OptCoercionOpts
opts = SimplEnv -> OptCoercionOpts
seOptCoercionOpts SimplEnv
env
simplCast :: SimplEnv -> InExpr -> InCoercion -> SimplCont
-> SimplM (SimplFloats, OutExpr)
simplCast :: SimplEnv
-> CoreExpr
-> CoercionR
-> SimplCont
-> SimplM (SimplFloats, CoreExpr)
simplCast SimplEnv
env CoreExpr
body CoercionR
co0 SimplCont
cont0
= do { co1 <- {-#SCC "simplCast-simplCoercion" #-} SimplEnv -> CoercionR -> SimplM CoercionR
simplCoercion SimplEnv
env CoercionR
co0
; cont1 <- {-#SCC "simplCast-addCoerce" #-}
if isReflCo co1
then return cont0
else addCoerce co1 True cont0
; {-#SCC "simplCast-simplExprF" #-} simplExprF env body cont1 }
where
addCoerceM :: MOutCoercion -> Bool -> SimplCont -> SimplM SimplCont
addCoerceM :: MOutCoercion -> Bool -> SimplCont -> SimplM SimplCont
addCoerceM MOutCoercion
MRefl Bool
_ SimplCont
cont = SimplCont -> SimplM SimplCont
forall a. a -> SimplM a
forall (m :: * -> *) a. Monad m => a -> m a
return SimplCont
cont
addCoerceM (MCo CoercionR
co) Bool
opt SimplCont
cont = CoercionR -> Bool -> SimplCont -> SimplM SimplCont
addCoerce CoercionR
co Bool
opt SimplCont
cont
addCoerce :: OutCoercion -> Bool -> SimplCont -> SimplM SimplCont
addCoerce :: CoercionR -> Bool -> SimplCont -> SimplM SimplCont
addCoerce CoercionR
co1 Bool
_ (CastIt { sc_co :: SimplCont -> CoercionR
sc_co = CoercionR
co2, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont })
= CoercionR -> Bool -> SimplCont -> SimplM SimplCont
addCoerce (HasDebugCallStack => CoercionR -> CoercionR -> CoercionR
CoercionR -> CoercionR -> CoercionR
mkTransCo CoercionR
co1 CoercionR
co2) Bool
False SimplCont
cont
addCoerce CoercionR
co Bool
opt (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') <- CoercionR -> Kind -> Maybe (Kind, MOutCoercion)
pushCoTyArg CoercionR
co Kind
arg_ty
= {-#SCC "addCoerce-pushCoTyArg" #-}
do { tail' <- MOutCoercion -> Bool -> SimplCont -> SimplM SimplCont
addCoerceM MOutCoercion
m_co' Bool
opt SimplCont
tail
; return (ApplyToTy { sc_arg_ty = arg_ty'
, sc_cont = tail'
, sc_hole_ty = coercionLKind co }) }
addCoerce CoercionR
co Bool
opt 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 })
| Bool -> Bool
not Bool
opt
= CoercionR -> Bool -> SimplCont -> SimplM SimplCont
addCoerce (SimplEnv -> CoercionR -> Bool -> CoercionR
optOutCoercion SimplEnv
env CoercionR
co Bool
opt) Bool
True SimplCont
cont
| Just (MOutCoercion
m_co1, MOutCoercion
m_co2) <- CoercionR -> Maybe (MOutCoercion, MOutCoercion)
pushCoValArg CoercionR
co
, MOutCoercion -> Bool
fixed_rep MOutCoercion
m_co1
= {-#SCC "addCoerce-pushCoValArg" #-}
do { tail' <- MOutCoercion -> Bool -> SimplCont -> SimplM SimplCont
addCoerceM MOutCoercion
m_co2 Bool
opt SimplCont
tail
; case 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 CoercionR
co1 ->
do { (dup', arg_se', arg') <- SimplEnv
-> DupFlag
-> Kind
-> Maybe ArgInfo
-> SimplEnv
-> CoreExpr
-> SimplM (DupFlag, SimplEnv, CoreExpr)
simplLazyArg SimplEnv
env DupFlag
dup Kind
fun_ty Maybe ArgInfo
forall a. Maybe a
Nothing SimplEnv
arg_se CoreExpr
arg
; return (ApplyToVal { sc_arg = mkCast arg' co1
, sc_env = arg_se'
, sc_dup = dup'
, sc_cont = tail'
, sc_hole_ty = coercionLKind co }) } } }
addCoerce CoercionR
co Bool
opt SimplCont
cont
| CoercionR -> Bool
isReflCo CoercionR
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 (CastIt { sc_co :: CoercionR
sc_co = CoercionR
co, sc_opt :: Bool
sc_opt = Bool
opt, sc_cont :: SimplCont
sc_cont = SimplCont
cont })
fixed_rep :: MCoercionR -> Bool
fixed_rep :: MOutCoercion -> Bool
fixed_rep MOutCoercion
MRefl = Bool
True
fixed_rep (MCo CoercionR
co) = HasDebugCallStack => Kind -> Bool
Kind -> Bool
typeHasFixedRuntimeRep (Kind -> Bool) -> Kind -> Bool
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => CoercionR -> Kind
CoercionR -> Kind
coercionRKind CoercionR
co
simplLazyArg :: SimplEnv -> DupFlag
-> OutType
-> Maybe ArgInfo
-> StaticEnv -> CoreExpr
-> SimplM (DupFlag, StaticEnv, OutExpr)
simplLazyArg :: SimplEnv
-> DupFlag
-> Kind
-> Maybe ArgInfo
-> SimplEnv
-> CoreExpr
-> SimplM (DupFlag, SimplEnv, CoreExpr)
simplLazyArg SimplEnv
env DupFlag
dup_flag Kind
fun_ty Maybe ArgInfo
mb_arg_info 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
; let arg_ty :: Kind
arg_ty = HasDebugCallStack => Kind -> Kind
Kind -> Kind
funArgTy Kind
fun_ty
; let stop :: SimplCont
stop = case Maybe ArgInfo
mb_arg_info of
Maybe ArgInfo
Nothing -> Kind -> SimplCont
mkBoringStop Kind
arg_ty
Just ArgInfo
ai -> Kind -> ArgInfo -> SimplCont
mkLazyArgStop Kind
arg_ty ArgInfo
ai
; arg' <- SimplEnv -> CoreExpr -> SimplCont -> SimplM CoreExpr
simplExprC SimplEnv
arg_env' CoreExpr
arg SimplCont
stop
; return (Simplified, zapSubstEnv arg_env', 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 = HasDebugCallStack =>
SimplEnv
-> CoreBndr
-> CoreExpr
-> SimplCont
-> SimplM (SimplFloats, CoreExpr)
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 :: HasDebugCallStack
=> SimplEnv -> InBndr -> InExpr -> SimplCont
-> SimplM (SimplFloats, OutExpr)
simpl_lam :: HasDebugCallStack =>
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 = Coercion CoercionR
arg_co, sc_env :: SimplCont -> SimplEnv
sc_env = SimplEnv
arg_se
, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont })
= Bool
-> SDoc
-> SimplM (SimplFloats, CoreExpr)
-> SimplM (SimplFloats, CoreExpr)
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (CoreBndr -> Bool
isCoVar CoreBndr
bndr) (CoreBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBndr
bndr) (SimplM (SimplFloats, CoreExpr) -> SimplM (SimplFloats, CoreExpr))
-> SimplM (SimplFloats, CoreExpr) -> SimplM (SimplFloats, CoreExpr)
forall a b. (a -> b) -> a -> b
$
do { Tick -> SimplM ()
tick (CoreBndr -> Tick
BetaReduction CoreBndr
bndr)
; let arg_co' :: CoercionR
arg_co' = SimplEnv -> CoercionR -> CoercionR
substCo (SimplEnv
arg_se SimplEnv -> SimplEnv -> SimplEnv
`setInScopeFromE` SimplEnv
env) CoercionR
arg_co
; SimplEnv -> CoreExpr -> SimplCont -> SimplM (SimplFloats, CoreExpr)
simplLam (SimplEnv -> CoreBndr -> CoercionR -> SimplEnv
extendCvSubst SimplEnv
env CoreBndr
bndr CoercionR
arg_co') 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 from_what :: FromWhat
from_what = Levity -> FromWhat
FromBeta Levity
arg_levity
arg_levity :: Levity
arg_levity
| Kind -> Bool
isForAllTy Kind
fun_ty = Bool -> SDoc -> Levity -> Levity
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (CoreBndr -> Bool
isCoVar CoreBndr
bndr) (CoreBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBndr
bndr) Levity
Unlifted
| Bool
otherwise = HasDebugCallStack => Kind -> Levity
Kind -> Levity
typeLevity (HasDebugCallStack => Kind -> Kind
Kind -> Kind
funArgTy Kind
fun_ty)
; if | DupFlag -> Bool
isSimplified DupFlag
dup
-> SimplEnv
-> FromWhat
-> CoreBndr
-> CoreExpr
-> CoreExpr
-> SimplCont
-> SimplM (SimplFloats, CoreExpr)
completeBindX SimplEnv
env FromWhat
from_what 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 (Levity -> CoreExpr -> Bool
needsCaseBindingL Levity
arg_levity 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
-> HasDebugCallStack =>
SimplEnv
-> FromWhat
-> CoreBndr
-> (CoreExpr, SimplEnv)
-> CoreExpr
-> SimplCont
-> SimplM (SimplFloats, CoreExpr)
SimplEnv
-> FromWhat
-> CoreBndr
-> (CoreExpr, SimplEnv)
-> CoreExpr
-> SimplCont
-> SimplM (SimplFloats, CoreExpr)
simplNonRecE SimplEnv
env FromWhat
from_what 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)
= HasDebugCallStack =>
SimplEnv
-> CoreBndr
-> CoreExpr
-> SimplCont
-> SimplM (SimplFloats, CoreExpr)
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
; (env', bndrs') <- SimplEnv -> [CoreBndr] -> SimplM (SimplEnv, [CoreBndr])
simplLamBndrs SimplEnv
env (CoreBndr
bndrCoreBndr -> [CoreBndr] -> [CoreBndr]
forall a. a -> [a] -> [a]
:[CoreBndr]
inner_bndrs)
; body' <- simplExpr env' inner_body
; new_lam <- rebuildLam env' bndrs' body' cont
; rebuild env' new_lam 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 :: HasDebugCallStack
=> SimplEnv
-> FromWhat
-> InId
-> (InExpr, SimplEnv)
-> InExpr
-> SimplCont
-> SimplM (SimplFloats, OutExpr)
simplNonRecE :: HasDebugCallStack =>
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 { (env1, bndr1) <- SimplEnv -> CoreBndr -> SimplM (SimplEnv, CoreBndr)
simplNonRecBndr SimplEnv
env CoreBndr
bndr
; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive)
; (floats1, env3) <- simplLazyBind NotTopLevel NonRecursive
(bndr,env) (bndr2,env2) (rhs,rhs_se)
; (floats2, expr') <- simplNonRecBody env3 from_what body cont
; return (floats1 `addFloats` floats2, expr') }
where
is_strict_bind :: Bool
is_strict_bind = case FromWhat
from_what of
FromBeta Levity
Unlifted -> 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)
; env1 <- SimplEnv -> [CoreBndr] -> SimplM SimplEnv
simplRecBndrs SimplEnv
env [CoreBndr]
bndrs
; (floats1, env2) <- simplRecBind env1 (BC_Let NotTopLevel Recursive) pairs
; (floats2, expr') <- simplExprF env2 body cont
; return (floats1 `addFloats` floats2, 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
; (env1, bndr1) <- SimplEnv -> CoreBndr -> Kind -> Kind -> SimplM (SimplEnv, CoreBndr)
simplNonRecJoinBndr SimplEnv
env CoreBndr
bndr Kind
mult Kind
res_ty
; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Join NonRecursive cont)
; (floats1, env3) <- simplJoinBind NonRecursive cont (bndr,env) (bndr2,env2) (rhs,env)
; (floats2, body') <- simplExprF env3 body cont
; return (floats1 `addFloats` floats2, 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
; env1 <- SimplEnv -> [CoreBndr] -> Kind -> Kind -> SimplM SimplEnv
simplRecJoinBndrs SimplEnv
env [CoreBndr]
bndrs Kind
mult Kind
res_ty
; (floats1, env2) <- simplRecBind env1 (BC_Join Recursive cont) pairs
; (floats2, body') <- simplExprF env2 body cont
; return (floats1 `addFloats` floats2, 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 { (floats1, expr1) <- SimplEnv -> SimplCont -> SimplM (SimplFloats, CoreExpr)
thing_inside SimplEnv
env (Kind -> SimplCont
mkBoringStop (SimplCont -> Kind
contHoleType SimplCont
cont))
; let (floats2, expr2) = wrapJoinFloatsX floats1 expr1
; (floats3, expr3) <- rebuild (env `setInScopeFromF` floats2) expr2 cont
; return (floats2 `addFloats` floats3, expr3) }
| Bool
otherwise
= do { (floats1, cont') <- SimplEnv -> SimplCont -> SimplM (SimplFloats, SimplCont)
mkDupableCont SimplEnv
env SimplCont
cont
; (floats2, result) <- thing_inside (env `setInScopeFromF` floats1) cont'
; return (floats1 `addFloats` floats2, result) }
trimJoinCont :: Id
-> JoinPointHood
-> SimplCont -> SimplCont
trimJoinCont :: CoreBndr -> JoinPointHood -> SimplCont -> SimplCont
trimJoinCont CoreBndr
_ JoinPointHood
NotJoinPoint SimplCont
cont
= SimplCont
cont
trimJoinCont CoreBndr
var (JoinPoint 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
$! CoercionR -> CoreExpr
forall b. CoercionR -> Expr b
Coercion (CoercionR -> CoreExpr) -> CoercionR -> CoreExpr
forall a b. (a -> b) -> a -> b
$! (SimplEnv -> CoreBndr -> CoercionR
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 JoinPointHood
_ -> 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
| Just DataCon
dc <- CoreBndr -> Maybe DataCon
isDataConWorkId_maybe CoreBndr
var
, DataCon -> Bool
isLazyDataConRep DataCon
dc
= 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 { rule_base <- SimplM RuleEnv
getSimplRules
; let cont' = CoreBndr -> JoinPointHood -> SimplCont -> SimplCont
trimJoinCont CoreBndr
var1 (CoreBndr -> JoinPointHood
idJoinPointHood CoreBndr
var1) SimplCont
cont
info = SimplEnv -> RuleEnv -> CoreBndr -> SimplCont -> ArgInfo
mkArgInfo SimplEnv
env RuleEnv
rule_base CoreBndr
var1 SimplCont
cont'
; rebuildCall env info cont' }
DoneEx CoreExpr
e JoinPointHood
mb_join -> SimplEnv -> CoreExpr -> SimplCont -> SimplM (SimplFloats, CoreExpr)
simplExprF SimplEnv
env' CoreExpr
e SimplCont
cont'
where
cont' :: SimplCont
cont' = CoreBndr -> JoinPointHood -> SimplCont -> SimplCont
trimJoinCont CoreBndr
var JoinPointHood
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 <- SimplM Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
; let full_cont = SimplEnv -> [ArgSpec] -> SimplCont -> SimplCont
pushSimplifiedRevArgs SimplEnv
env [ArgSpec]
rev_args SimplCont
cont
; mb_inline <- tryInlining env logger fun full_cont
; case 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 { 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 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 { sc_co :: SimplCont -> CoercionR
sc_co = CoercionR
co, sc_opt :: SimplCont -> Bool
sc_opt = Bool
opt, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont })
= SimplEnv -> ArgInfo -> SimplCont -> SimplM (SimplFloats, CoreExpr)
rebuildCall SimplEnv
env (ArgInfo -> CoercionR -> ArgInfo
addCastTo ArgInfo
info CoercionR
co') SimplCont
cont
where
co' :: CoercionR
co' = SimplEnv -> CoercionR -> Bool -> CoercionR
optOutCoercion SimplEnv
env CoercionR
co Bool
opt
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 { as_arg_ty :: ArgSpec -> Kind
as_arg_ty = Kind
hole_ty }, TyArg {} ] <- [ArgSpec]
rev_args
= do { let arg_env :: SimplEnv
arg_env = SimplEnv
arg_se SimplEnv -> SimplEnv -> SimplEnv
`setInScopeFromE` SimplEnv
env
overall_res_ty :: Kind
overall_res_ty = SimplCont -> Kind
contResultType SimplCont
cont
(SimplCont
outer_cont, Kind
new_runrw_res_ty, SimplCont
inner_cont)
| SimplEnv -> Bool
seCaseCase SimplEnv
env = (Kind -> SimplCont
mkBoringStop Kind
overall_res_ty, Kind
overall_res_ty, SimplCont
cont)
| Bool
otherwise = (SimplCont
cont, Kind
hole_ty, Kind -> SimplCont
mkBoringStop Kind
hole_ty)
; arg' <- case CoreExpr
arg of
Lam CoreBndr
s CoreExpr
body -> do { (env', s') <- SimplEnv -> CoreBndr -> SimplM (SimplEnv, CoreBndr)
simplBinder SimplEnv
arg_env CoreBndr
s
; body' <- simplExprC env' body inner_cont
; return (Lam s' body') }
CoreExpr
_ -> do { s' <- FastString -> Kind -> Kind -> SimplM CoreBndr
newId (String -> FastString
fsLit String
"s") Kind
ManyTy Kind
realWorldStatePrimTy
; let (m,_,_) = splitFunTy fun_ty
env' = SimplEnv
arg_env SimplEnv -> [CoreBndr] -> SimplEnv
`addNewInScopeIds` [CoreBndr
s']
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
inner_cont
, sc_hole_ty :: Kind
sc_hole_ty = HasDebugCallStack => Kind -> Kind -> Kind -> Kind
Kind -> Kind -> Kind -> Kind
mkVisFunTy Kind
m Kind
realWorldStatePrimTy Kind
new_runrw_res_ty }
; body' <- simplExprC env' arg cont'
; return (Lam s' body') }
; let rr' = HasDebugCallStack => Kind -> Kind
Kind -> Kind
getRuntimeRep Kind
new_runrw_res_ty
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
new_runrw_res_ty, CoreExpr
arg']
; rebuild env call' outer_cont }
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 { (_, _, arg') <- SimplEnv
-> DupFlag
-> Kind
-> Maybe ArgInfo
-> SimplEnv
-> CoreExpr
-> SimplM (DupFlag, SimplEnv, CoreExpr)
simplLazyArg SimplEnv
env DupFlag
dup_flag Kind
fun_ty (ArgInfo -> Maybe ArgInfo
forall a. a -> Maybe a
Just ArgInfo
fun_info) SimplEnv
arg_se CoreExpr
arg
; rebuildCall env (addValArgTo fun_info arg' fun_ty) cont }
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 <- SimplEnv
-> Logger
-> CoreBndr
-> Bool
-> [ArgSummary]
-> CallCtxt
-> Maybe CoreExpr
callSiteInline SimplEnv
env Logger
logger CoreBndr
var 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
(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
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 <- SimplM Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
; checkedTick (RuleFired (ruleName rule))
; let 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 -> CoreExpr
occurAnalyseExpr CoreExpr
rule_rhs
; dump logger rule rule_rhs
; return (Just (zapped_env, occ_anald_rhs, cont')) }
| Bool
otherwise
= do { logger <- SimplM Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
; nodump logger
; return 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 -> (Module -> doc) -> Maybe Module -> 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) -> (Module -> ModuleName) -> Module -> doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName)
(CoreRule -> Maybe Module
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 <- m Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
; liftIO $ logDumpFile logger (mkDumpStyle alwaysQualify) flag "" FormatText
$ sep [text hdr, nest 4 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 { rule_base <- SimplM RuleEnv
getSimplRules
; tryRules in_env (getRules rule_base seqId) seqId out_args 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 = HasDebugCallStack => 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 = HasDebugCallStack => Kind -> Kind -> Kind
Kind -> Kind -> Kind
piResultTy Kind
seq_id_ty Kind
rhs_rep
res2_ty :: Kind
res2_ty = HasDebugCallStack => Kind -> Kind -> Kind
Kind -> Kind -> Kind
piResultTy Kind
res1_ty Kind
scrut_ty
res3_ty :: Kind
res3_ty = HasDebugCallStack => Kind -> Kind -> Kind
Kind -> Kind -> Kind
piResultTy Kind
res2_ty Kind
rhs_ty
res4_ty :: Kind
res4_ty = HasDebugCallStack => Kind -> Kind
Kind -> Kind
funResultTy Kind
res3_ty
rhs_ty :: Kind
rhs_ty = HasDebugCallStack => SimplEnv -> Kind -> Kind
SimplEnv -> Kind -> Kind
substTy SimplEnv
in_env (HasDebugCallStack => CoreExpr -> Kind
CoreExpr -> Kind
exprType CoreExpr
rhs)
rhs_rep :: Kind
rhs_rep = HasDebugCallStack => 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 CoercionR
_) = 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)
<- HasDebugCallStack =>
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 { (floats1, env') <- String
-> SimplEnv
-> CoreBndr
-> CoreExpr
-> SimplM (SimplFloats, SimplEnv)
simplAuxBind String
"rebuildCase" SimplEnv
env CoreBndr
case_bndr CoreExpr
case_bndr_rhs
; (floats2, expr') <- simplExprF env' rhs cont
; case 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` HasDebugCallStack => CoreBndr -> Kind
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
exprOkToDiscard 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)
; (floats1, env') <- String
-> SimplEnv
-> CoreBndr
-> CoreExpr
-> SimplM (SimplFloats, SimplEnv)
simplAuxBind String
"rebuildCaseAlt1" SimplEnv
env CoreBndr
case_bndr CoreExpr
scrut
; (floats2, expr') <- simplExprF env' rhs cont
; return (floats1 `addFloats` floats2, expr') }
| Bool
is_plain_seq
= do { mb_rule <- SimplEnv
-> CoreExpr
-> CoreExpr
-> SimplCont
-> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont))
trySeqRules SimplEnv
env CoreExpr
scrut CoreExpr
rhs SimplCont
cont
; case 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 }
|Just (CoreExpr
scrut', CoreBndr
case_bndr', [Alt CoreBndr]
alts') <- CoreExpr
-> CoreBndr
-> [Alt CoreBndr]
-> Maybe (CoreExpr, CoreBndr, [Alt CoreBndr])
caseRules2 CoreExpr
scrut CoreBndr
case_bndr [Alt CoreBndr]
alts
= 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
| HasDebugCallStack => Kind -> Bool
Kind -> Bool
isUnliftedType (HasDebugCallStack => CoreExpr -> Kind
CoreExpr -> Kind
exprType CoreExpr
scrut)
= CoreExpr -> Bool
exprOkForSpeculation CoreExpr
scrut
| Bool
otherwise
= CoreExpr -> Bool
exprIsHNF CoreExpr
scrut
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 { 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))
; rebuild env case_expr cont }
| Bool
otherwise
= do { (floats, env', cont') <- SimplEnv
-> [Alt CoreBndr]
-> SimplCont
-> SimplM (SimplFloats, SimplEnv, SimplCont)
mkDupableCaseCont SimplEnv
env [Alt CoreBndr]
alts SimplCont
cont
; case_expr <- simplAlts env' scrut
(scaleIdBy holeScaling case_bndr)
(scaleAltsBy holeScaling alts)
cont'
; return (floats, 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) ])
; (env1, case_bndr1) <- SimplEnv -> CoreBndr -> SimplM (SimplEnv, CoreBndr)
simplBinder SimplEnv
env0 CoreBndr
case_bndr
; let case_bndr2 = CoreBndr
case_bndr1 CoreBndr -> Unfolding -> CoreBndr
`setIdUnfolding` Unfolding
evaldUnfolding
env2 = SimplEnv -> CoreBndr -> SimplEnv
modifyInScope SimplEnv
env1 CoreBndr
case_bndr2
fam_envs = SimplEnv -> (FamInstEnv, FamInstEnv)
seFamEnvs SimplEnv
env0
; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env2 scrut
case_bndr case_bndr2 alts
; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr alts
; alts' <- forM in_alts $
simplAlt alt_env' (Just scrut') imposs_deflt_cons
case_bndr' (scrutOkForBinderSwap scrut) cont'
; let alts_ty' = SimplCont -> Kind
contResultType SimplCont
cont'
; seqType alts_ty' `seq`
mkCase (seMode env0) scrut' case_bndr' alts_ty' 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 CoercionR
co Kind
ty2) <- (FamInstEnv, FamInstEnv) -> Kind -> Maybe Reduction
topNormaliseType_maybe (FamInstEnv, FamInstEnv)
fam_envs (CoreBndr -> Kind
idType CoreBndr
case_bndr1)
= do { case_bndr2 <- FastString -> Kind -> Kind -> SimplM CoreBndr
newId (String -> FastString
fsLit String
"nt") Kind
ManyTy Kind
ty2
; let rhs = CoreExpr -> JoinPointHood -> SimplSR
DoneEx (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
case_bndr2 CoreExpr -> CoercionR -> CoreExpr
forall b. Expr b -> CoercionR -> Expr b
`Cast` CoercionR -> CoercionR
mkSymCo CoercionR
co) JoinPointHood
NotJoinPoint
env2 = SimplEnv -> CoreBndr -> SimplSR -> SimplEnv
extendIdSubst SimplEnv
env CoreBndr
case_bndr SimplSR
rhs
; return (env2, scrut `Cast` co, 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
-> BinderSwapDecision
-> SimplCont
-> InAlt
-> SimplM OutAlt
simplAlt :: SimplEnv
-> Maybe CoreExpr
-> [AltCon]
-> CoreBndr
-> BinderSwapDecision
-> SimplCont
-> Alt CoreBndr
-> SimplM (Alt CoreBndr)
simplAlt SimplEnv
env Maybe CoreExpr
_scrut' [AltCon]
imposs_deflt_cons CoreBndr
case_bndr' BinderSwapDecision
bndr_swap' 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 -> BinderSwapDecision -> [AltCon] -> SimplEnv
addDefaultUnfoldings SimplEnv
env CoreBndr
case_bndr' BinderSwapDecision
bndr_swap' [AltCon]
imposs_deflt_cons
; rhs' <- SimplEnv -> CoreExpr -> SimplCont -> SimplM CoreExpr
simplExprC SimplEnv
env' CoreExpr
rhs SimplCont
cont'
; return (Alt DEFAULT [] rhs') }
simplAlt SimplEnv
env Maybe CoreExpr
_scrut' [AltCon]
_ CoreBndr
case_bndr' BinderSwapDecision
bndr_swap' 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 { let env' :: SimplEnv
env' = SimplEnv -> CoreBndr -> BinderSwapDecision -> CoreExpr -> SimplEnv
addAltUnfoldings SimplEnv
env CoreBndr
case_bndr' BinderSwapDecision
bndr_swap' (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
lit)
; rhs' <- SimplEnv -> CoreExpr -> SimplCont -> SimplM CoreExpr
simplExprC SimplEnv
env' CoreExpr
rhs SimplCont
cont'
; return (Alt (LitAlt lit) [] rhs') }
simplAlt SimplEnv
env Maybe CoreExpr
scrut' [AltCon]
_ CoreBndr
case_bndr' BinderSwapDecision
bndr_swap' SimplCont
cont' (Alt (DataAlt DataCon
con) [CoreBndr]
vs CoreExpr
rhs)
= do {
; let vs_with_info :: [CoreBndr]
vs_with_info = Maybe CoreExpr
-> CoreBndr
-> BinderSwapDecision
-> DataCon
-> [CoreBndr]
-> [CoreBndr]
adjustFieldsIdInfo Maybe CoreExpr
scrut' CoreBndr
case_bndr' BinderSwapDecision
bndr_swap' DataCon
con [CoreBndr]
vs
; (env', vs') <- SimplEnv -> [CoreBndr] -> SimplM (SimplEnv, [CoreBndr])
simplBinders SimplEnv
env [CoreBndr]
vs_with_info
; let inst_tys' = HasDebugCallStack => Kind -> [Kind]
Kind -> [Kind]
tyConAppArgs (CoreBndr -> Kind
idType CoreBndr
case_bndr')
con_app :: OutExpr
con_app = DataCon -> [Kind] -> [CoreBndr] -> CoreExpr
forall b. DataCon -> [Kind] -> [CoreBndr] -> Expr b
mkConApp2 DataCon
con [Kind]
inst_tys' [CoreBndr]
vs'
env'' = SimplEnv -> CoreBndr -> BinderSwapDecision -> CoreExpr -> SimplEnv
addAltUnfoldings SimplEnv
env' CoreBndr
case_bndr' BinderSwapDecision
bndr_swap' CoreExpr
con_app
; rhs' <- simplExprC env'' rhs cont'
; return (Alt (DataAlt con) vs' rhs') }
adjustFieldsIdInfo :: Maybe OutExpr -> OutId -> BinderSwapDecision -> DataCon -> [Id] -> [Id]
adjustFieldsIdInfo :: Maybe CoreExpr
-> CoreBndr
-> BinderSwapDecision
-> DataCon
-> [CoreBndr]
-> [CoreBndr]
adjustFieldsIdInfo Maybe CoreExpr
scrut CoreBndr
case_bndr BinderSwapDecision
bndr_swap 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
, CoreBndr
f CoreBndr -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
seqHashKey
, let x' :: CoreBndr
x' = StrictnessMark -> CoreBndr -> CoreBndr
setCaseBndrEvald StrictnessMark
MarkedStrict CoreBndr
x
= (CoreBndr -> CoreBndr) -> [CoreBndr] -> [CoreBndr]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr -> BinderSwapDecision -> CoreBndr -> CoreBndr
adjustFieldOccInfo CoreBndr
case_bndr BinderSwapDecision
bndr_swap) [CoreBndr
s, CoreBndr
x']
adjustFieldsIdInfo Maybe CoreExpr
_scrut CoreBndr
case_bndr BinderSwapDecision
bndr_swap DataCon
con [CoreBndr]
vs
| Maybe CoreBndr
Nothing <- DataCon -> Maybe CoreBndr
dataConWrapId_maybe DataCon
con
= (CoreBndr -> CoreBndr) -> [CoreBndr] -> [CoreBndr]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr -> BinderSwapDecision -> CoreBndr -> CoreBndr
adjustFieldOccInfo CoreBndr
case_bndr BinderSwapDecision
bndr_swap) [CoreBndr]
vs
| Bool
otherwise
= [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) = CoreBndr -> BinderSwapDecision -> CoreBndr -> CoreBndr
adjustFieldOccInfo CoreBndr
case_bndr BinderSwapDecision
bndr_swap (StrictnessMark -> CoreBndr -> CoreBndr
setCaseBndrEvald 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.adjustFieldsIdInfo"
(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"
adjustFieldOccInfo :: OutId -> BinderSwapDecision -> CoreBndr -> CoreBndr
adjustFieldOccInfo :: CoreBndr -> BinderSwapDecision -> CoreBndr -> CoreBndr
adjustFieldOccInfo CoreBndr
case_bndr BinderSwapDecision
bndr_swap CoreBndr
field_bndr
| CoreBndr -> Bool
isTyVar CoreBndr
field_bndr
= CoreBndr
field_bndr
| Bool -> Bool
not (CoreBndr -> Bool
isDeadBinder CoreBndr
case_bndr)
= CoreBndr -> CoreBndr
zapIdOccInfo CoreBndr
field_bndr
| DoBinderSwap{} <- BinderSwapDecision
bndr_swap
= CoreBndr -> CoreBndr
zapIdOccInfo CoreBndr
field_bndr
| Bool
otherwise
= CoreBndr
field_bndr
addDefaultUnfoldings :: SimplEnv -> OutId -> BinderSwapDecision -> [AltCon] -> SimplEnv
addDefaultUnfoldings :: SimplEnv -> CoreBndr -> BinderSwapDecision -> [AltCon] -> SimplEnv
addDefaultUnfoldings SimplEnv
env CoreBndr
case_bndr BinderSwapDecision
bndr_swap [AltCon]
imposs_deflt_cons
= SimplEnv
env2
where
unf :: Unfolding
unf = [AltCon] -> Unfolding
mkOtherCon [AltCon]
imposs_deflt_cons
env1 :: SimplEnv
env1 = SimplEnv -> CoreBndr -> Unfolding -> SimplEnv
addBinderUnfolding SimplEnv
env CoreBndr
case_bndr Unfolding
unf
env2 :: SimplEnv
env2 | DoBinderSwap CoreBndr
v MOutCoercion
_mco <- BinderSwapDecision
bndr_swap
= SimplEnv -> CoreBndr -> Unfolding -> SimplEnv
addBinderUnfolding SimplEnv
env1 CoreBndr
v Unfolding
unf
| Bool
otherwise = SimplEnv
env1
addAltUnfoldings :: SimplEnv -> OutId -> BinderSwapDecision -> OutExpr -> SimplEnv
addAltUnfoldings :: SimplEnv -> CoreBndr -> BinderSwapDecision -> CoreExpr -> SimplEnv
addAltUnfoldings SimplEnv
env CoreBndr
case_bndr BinderSwapDecision
bndr_swap CoreExpr
con_app
= SimplEnv
env2
where
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 | DoBinderSwap CoreBndr
v MOutCoercion
mco <- BinderSwapDecision
bndr_swap
= 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
!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 (HasCallStack => Kind -> Kind -> Bool
Kind -> Kind -> Bool
eqType (CoreBndr -> Kind
idType CoreBndr
bndr) (HasDebugCallStack => 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 (HasDebugCallStack => 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 { (floats1, env1) <- SimplEnv
-> [CoreBndr] -> [CoreExpr] -> SimplM (SimplFloats, SimplEnv)
bind_args SimplEnv
env [CoreBndr]
bs [CoreExpr]
dc_args
; (floats2, env2) <- bind_case_bndr env1
; (floats3, expr') <- simplExprF env2 rhs cont
; case 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 CoercionR
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 -> CoercionR -> SimplEnv
extendCvSubst SimplEnv
env' CoreBndr
b CoercionR
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
; (floats1, env2) <- String
-> SimplEnv
-> CoreBndr
-> CoreExpr
-> SimplM (SimplFloats, SimplEnv)
simplAuxBind String
"knownCon" SimplEnv
env' CoreBndr
b' CoreExpr
arg
; (floats2, env3) <- bind_args env2 bs' args
; return (floats1 `addFloats` floats2, 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 -> JoinPointHood -> SimplSR
DoneEx CoreExpr
scrut JoinPointHood
NotJoinPoint))
| Bool
otherwise = do { 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 = 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
; simplAuxBind "case-bndr" env bndr 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 { (floats, cont) <- SimplEnv -> SimplCont -> SimplM (SimplFloats, SimplCont)
mkDupableCont SimplEnv
env SimplCont
cont
; let env' = SimplEnv -> SimplEnv
bumpCaseDepth (SimplEnv -> SimplEnv) -> SimplEnv -> SimplEnv
forall a b. (a -> b) -> a -> b
$
SimplEnv
env SimplEnv -> SimplFloats -> SimplEnv
`setInScopeFromF` SimplFloats
floats
; return (floats, env', 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 { sc_co :: SimplCont -> CoercionR
sc_co = CoercionR
co, sc_opt :: SimplCont -> Bool
sc_opt = Bool
opt, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont })
= do { (floats, cont') <- SimplEnv
-> [Demand] -> SimplCont -> SimplM (SimplFloats, SimplCont)
mkDupableContWithDmds SimplEnv
env [Demand]
dmds SimplCont
cont
; return (floats, CastIt { sc_co = optOutCoercion env co opt
, sc_opt = True, sc_cont = cont' }) }
mkDupableContWithDmds SimplEnv
env [Demand]
dmds (TickIt CoreTickish
t SimplCont
cont)
= do { (floats, cont') <- SimplEnv
-> [Demand] -> SimplCont -> SimplM (SimplFloats, SimplCont)
mkDupableContWithDmds SimplEnv
env [Demand]
dmds SimplCont
cont
; return (floats, TickIt t 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
; (sb_env1, bndr') <- SimplEnv -> CoreBndr -> SimplM (SimplEnv, CoreBndr)
simplBinder SimplEnv
sb_env CoreBndr
bndr
; (floats1, join_inner) <- simplNonRecBody sb_env1 from_what body cont
; let join_body = SimplFloats -> CoreExpr -> CoreExpr
wrapFloats SimplFloats
floats1 CoreExpr
join_inner
res_ty = SimplCont -> Kind
contResultType SimplCont
cont
; mkDupableStrictBind env bndr' join_body 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
; (floats1, cont') <- SimplEnv
-> [Demand] -> SimplCont -> SimplM (SimplFloats, SimplCont)
mkDupableContWithDmds SimplEnv
env [Demand]
dmds SimplCont
cont
; (floats_s, args') <- mapAndUnzipM (makeTrivialArg env)
(ai_args fun)
; return ( foldl' addLetFloats floats1 floats_s
, StrictArg { sc_fun = fun { ai_args = args' }
, sc_cont = cont'
, sc_fun_ty = fun_ty
, sc_dup = 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
; arg_bndr <- FastString -> Kind -> Kind -> SimplM CoreBndr
newId (String -> FastString
fsLit String
"arg") Kind
m Kind
arg_ty
; let env' = SimplEnv
env SimplEnv -> [CoreBndr] -> SimplEnv
`addNewInScopeIds` [CoreBndr
arg_bndr]
; (floats, join_rhs) <- rebuildCall env' (addValArgTo fun (Var arg_bndr) fun_ty) cont
; mkDupableStrictBind env' arg_bndr (wrapFloats floats join_rhs) rhs_ty }
where
thumbsUpPlanA :: SimplCont -> Bool
thumbsUpPlanA (StrictArg {}) = Bool
False
thumbsUpPlanA (StrictBind {}) = Bool
True
thumbsUpPlanA (Stop {}) = Bool
True
thumbsUpPlanA (Select {}) = Bool
True
thumbsUpPlanA (CastIt { sc_cont :: SimplCont -> SimplCont
sc_cont = 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
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 { (floats, cont') <- SimplEnv
-> [Demand] -> SimplCont -> SimplM (SimplFloats, SimplCont)
mkDupableContWithDmds SimplEnv
env [Demand]
dmds SimplCont
cont
; return (floats, ApplyToTy { sc_cont = cont'
, sc_arg_ty = arg_ty, sc_hole_ty = 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
; (floats1, cont') <- SimplEnv
-> [Demand] -> SimplCont -> SimplM (SimplFloats, SimplCont)
mkDupableContWithDmds SimplEnv
env [Demand]
cont_dmds SimplCont
cont
; let env' = SimplEnv
env SimplEnv -> SimplFloats -> SimplEnv
`setInScopeFromF` SimplFloats
floats1
; (_, se', arg') <- simplLazyArg env' dup hole_ty Nothing se arg
; (let_floats2, arg'') <- makeTrivial env NotTopLevel dmd (fsLit "karg") arg'
; let all_floats = SimplFloats
floats1 SimplFloats -> LetFloats -> SimplFloats
`addLetFloats` LetFloats
let_floats2
; return ( all_floats
, ApplyToVal { sc_arg = arg''
, sc_env = se' `setInScopeFromF` all_floats
, sc_dup = OkToDup, sc_cont = cont'
, sc_hole_ty = 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)
; (floats, alt_env, 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 = SimplCont -> Kind
contHoleScaling SimplCont
cont
; (alt_env', case_bndr') <- simplBinder alt_env (scaleIdBy cont_scaling case_bndr)
; alts' <- forM (scaleAltsBy cont_scaling alts) $
simplAlt alt_env' Nothing [] case_bndr' NoBinderSwap alt_cont
; (join_floats, alts'') <- mapAccumLM (mkDupableAlt env case_bndr')
emptyJoinFloats alts'
; let all_floats = SimplFloats
floats SimplFloats -> JoinFloats -> SimplFloats
`addJoinFloats` JoinFloats
join_floats
; return (all_floats
, Select { sc_dup = OkToDup
, sc_bndr = case_bndr'
, sc_alts = alts''
, sc_env = zapSubstEnv se `setInScopeFromF` all_floats
, sc_cont = mkBoringStop (contResultType 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
| [CoreBndr] -> CoreExpr -> Bool
uncondInlineJoin [CoreBndr
arg_bndr] 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 { join_bndr <- [CoreBndr] -> Kind -> SimplM CoreBndr
newJoinId [CoreBndr
arg_bndr] Kind
res_ty
; let 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 }
; return ( addJoinFloats (emptyFloats env) $
unitJoinFloat $
NonRec join_bndr $
Lam (setOneShotLambda arg_bndr) join_rhs
, StrictArg { sc_dup = OkToDup
, sc_fun = arg_info
, sc_fun_ty = idType join_bndr
, sc_cont = mkBoringStop res_ty
} ) }
mkDupableAlt :: SimplEnv -> OutId
-> JoinFloats -> OutAlt
-> SimplM (JoinFloats, OutAlt)
mkDupableAlt :: SimplEnv
-> CoreBndr
-> JoinFloats
-> Alt CoreBndr
-> SimplM (JoinFloats, Alt CoreBndr)
mkDupableAlt SimplEnv
_env CoreBndr
case_bndr JoinFloats
jfloats (Alt AltCon
con [CoreBndr]
alt_bndrs CoreExpr
alt_rhs_in)
| [CoreBndr] -> CoreExpr -> Bool
uncondInlineJoin [CoreBndr]
alt_bndrs 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' = HasDebugCallStack => 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
rhs_with_seqs :: 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
; join_bndr <- [CoreBndr] -> Kind -> SimplM CoreBndr
newJoinId [CoreBndr]
filtered_binders Kind
rhs_ty'
; let
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' = AltCon -> [CoreBndr] -> CoreExpr -> Alt CoreBndr
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [CoreBndr]
alt_bndrs CoreExpr
join_call
; return ( jfloats `addJoinFlts` unitJoinFloat (NonRec join_bndr join_rhs)
, 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
freshly_born_join_point CoreBndr
id
=
Unfolding -> SimplM Unfolding
forall a. a -> SimplM a
forall (m :: * -> *) a. Monad m => a -> m a
return Unfolding
noUnfolding
| 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
= SimplEnv
-> TopLevelFlag
-> UnfoldingSource
-> CoreBndr
-> Bool
-> CoreExpr
-> SimplM Unfolding
mkLetUnfolding SimplEnv
env (BindContext -> TopLevelFlag
bindContextLevel BindContext
bind_cxt) UnfoldingSource
VanillaSrc CoreBndr
id Bool
is_join_point CoreExpr
new_rhs
where
is_join_point :: Bool
is_join_point = CoreBndr -> Bool
isJoinId CoreBndr
id
freshly_born_join_point :: CoreBndr -> Bool
freshly_born_join_point CoreBndr
id = Bool
is_join_point Bool -> Bool -> Bool
&& OccInfo -> Bool
isManyOccs (CoreBndr -> OccInfo
idOccInfo CoreBndr
id)
mkLetUnfolding :: SimplEnv -> TopLevelFlag -> UnfoldingSource
-> InId -> Bool
-> OutExpr -> SimplM Unfolding
mkLetUnfolding :: SimplEnv
-> TopLevelFlag
-> UnfoldingSource
-> CoreBndr
-> Bool
-> CoreExpr
-> SimplM Unfolding
mkLetUnfolding SimplEnv
env TopLevelFlag
top_lvl UnfoldingSource
src CoreBndr
id Bool
is_join CoreExpr
new_rhs
= Unfolding -> SimplM Unfolding
forall a. a -> SimplM a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnfoldingOpts
-> UnfoldingSource
-> Bool
-> Bool
-> Bool
-> CoreExpr
-> Maybe UnfoldingCache
-> Unfolding
mkUnfolding UnfoldingOpts
uf_opts UnfoldingSource
src Bool
is_top_lvl Bool
is_bottoming Bool
is_join CoreExpr
new_rhs Maybe UnfoldingCache
forall a. Maybe a
Nothing)
where
!uf_opts :: UnfoldingOpts
uf_opts = SimplEnv -> UnfoldingOpts
seUnfoldingOpts SimplEnv
env
!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 { (env', bndrs') <- SimplEnv -> [CoreBndr] -> SimplM (SimplEnv, [CoreBndr])
simplBinders SimplEnv
unf_env [CoreBndr]
bndrs
; args' <- mapM (simplExpr env') args
; return (mkDFunUnfolding bndrs' con 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 { 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
; expr' <- SimplEnv -> CoreExpr -> SimplCont -> SimplM CoreExpr
simplExprC SimplEnv
unf_env CoreExpr
expr SimplCont
cont
; return (eta_expand expr') }
; case 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
-> SimplEnv
-> TopLevelFlag
-> UnfoldingSource
-> CoreBndr
-> Bool
-> CoreExpr
-> SimplM Unfolding
mkLetUnfolding SimplEnv
env TopLevelFlag
top_lvl UnfoldingSource
src CoreBndr
id Bool
False CoreExpr
expr' }
| Bool
otherwise -> Unfolding -> SimplM Unfolding
forall a. a -> SimplM a
forall (m :: * -> *) a. Monad m => a -> m a
return Unfolding
noUnfolding
where
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 { 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
out_id CoreBndr -> RuleInfo -> CoreBndr
`setIdSpecialisation` [CoreRule] -> RuleInfo
mkRuleInfo [CoreRule]
new_rules
; return (modifyInScope env final_id, 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 { (env', bndrs') <- SimplEnv -> [CoreBndr] -> SimplM (SimplEnv, [CoreBndr])
simplBinders SimplEnv
env [CoreBndr]
bndrs
; let rhs_ty = HasDebugCallStack => SimplEnv -> Kind -> Kind
SimplEnv -> Kind -> Kind
substTy SimplEnv
env' (HasDebugCallStack => CoreExpr -> Kind
CoreExpr -> Kind
exprType CoreExpr
rhs)
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 = (SimplMode -> SimplMode) -> SimplEnv -> SimplEnv
updMode SimplMode -> SimplMode
updModeForRules SimplEnv
env'
rhs_env = (SimplMode -> SimplMode) -> SimplEnv -> SimplEnv
updMode (Activation -> SimplMode -> SimplMode
updModeForStableUnfoldings Activation
act) SimplEnv
env'
!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 = case Maybe CoreBndr
mb_new_id of
Just CoreBndr
id | JoinPoint Int
join_arity <- CoreBndr -> JoinPointHood
idJoinPointHood 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] -> 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 JoinPointHood -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((CoreBndr -> JoinPointHood)
-> Maybe CoreBndr -> Maybe JoinPointHood
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CoreBndr -> JoinPointHood
idJoinPointHood Maybe CoreBndr
mb_new_id) ]
; args' <- mapM (simplExpr lhs_env) args
; rhs' <- simplExprC rhs_env rhs rhs_cont
; return (rule { ru_bndrs = bndrs'
, ru_fn = fn_name'
, ru_args = args'
, ru_rhs = occurAnalyseExpr rhs' }) }