{-# OPTIONS_GHC -fprof-auto #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Core.Opt.FloatIn ( floatInwards ) where
import GHC.Prelude
import GHC.Platform
import GHC.Core
import GHC.Core.Opt.Arity( isOneShotBndr )
import GHC.Core.Make hiding ( wrapFloats )
import GHC.Core.Utils
import GHC.Core.FVs
import GHC.Core.Type
import GHC.Types.Basic ( RecFlag(..), isRec )
import GHC.Types.Id ( idType, isJoinId, idJoinPointHood )
import GHC.Types.Tickish
import GHC.Types.Var
import GHC.Types.Var.Set
import GHC.Utils.Misc
import GHC.Utils.Panic.Plain
import GHC.Utils.Outputable
import Data.List ( mapAccumL )
floatInwards :: Platform -> CoreProgram -> CoreProgram
floatInwards :: Platform -> CoreProgram -> CoreProgram
floatInwards Platform
platform CoreProgram
binds = (Bind CoreBndr -> Bind CoreBndr) -> CoreProgram -> CoreProgram
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> Bind CoreBndr -> Bind CoreBndr
fi_top_bind Platform
platform) CoreProgram
binds
where
fi_top_bind :: Platform -> Bind CoreBndr -> Bind CoreBndr
fi_top_bind Platform
platform (NonRec CoreBndr
binder Expr CoreBndr
rhs)
= CoreBndr -> Expr CoreBndr -> Bind CoreBndr
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
binder (Platform -> RevFloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
fiExpr Platform
platform [] (Expr CoreBndr -> CoreExprWithFVs
freeVars Expr CoreBndr
rhs))
fi_top_bind Platform
platform (Rec [(CoreBndr, Expr CoreBndr)]
pairs)
= [(CoreBndr, Expr CoreBndr)] -> Bind CoreBndr
forall b. [(b, Expr b)] -> Bind b
Rec [ (CoreBndr
b, Platform -> RevFloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
fiExpr Platform
platform [] (Expr CoreBndr -> CoreExprWithFVs
freeVars Expr CoreBndr
rhs)) | (CoreBndr
b, Expr CoreBndr
rhs) <- [(CoreBndr, Expr CoreBndr)]
pairs ]
type FreeVarSet = DVarSet
type BoundVarSet = DIdSet
data FloatInBind = FB BoundVarSet FreeVarSet FloatBind
type FloatInBinds = [FloatInBind]
type RevFloatInBinds = [FloatInBind]
instance Outputable FloatInBind where
ppr :: FloatInBind -> SDoc
ppr (FB BoundVarSet
bvs BoundVarSet
fvs FloatBind
_) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"FB" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"bndrs =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> BoundVarSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr BoundVarSet
bvs
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"fvs =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> BoundVarSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr BoundVarSet
fvs ])
fiExpr :: Platform
-> RevFloatInBinds
-> CoreExprWithFVs
-> CoreExpr
fiExpr :: Platform -> RevFloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
fiExpr Platform
_ RevFloatInBinds
to_drop (BoundVarSet
_, AnnLit Literal
lit) = RevFloatInBinds -> Expr CoreBndr -> Expr CoreBndr
wrapFloats RevFloatInBinds
to_drop (Literal -> Expr CoreBndr
forall b. Literal -> Expr b
Lit Literal
lit)
fiExpr Platform
_ RevFloatInBinds
to_drop (BoundVarSet
_, AnnType Type
ty) = Bool -> Expr CoreBndr -> Expr CoreBndr
forall a. HasCallStack => Bool -> a -> a
assert (RevFloatInBinds -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null RevFloatInBinds
to_drop) (Expr CoreBndr -> Expr CoreBndr) -> Expr CoreBndr -> Expr CoreBndr
forall a b. (a -> b) -> a -> b
$ Type -> Expr CoreBndr
forall b. Type -> Expr b
Type Type
ty
fiExpr Platform
_ RevFloatInBinds
to_drop (BoundVarSet
_, AnnVar CoreBndr
v) = RevFloatInBinds -> Expr CoreBndr -> Expr CoreBndr
wrapFloats RevFloatInBinds
to_drop (CoreBndr -> Expr CoreBndr
forall b. CoreBndr -> Expr b
Var CoreBndr
v)
fiExpr Platform
_ RevFloatInBinds
to_drop (BoundVarSet
_, AnnCoercion Coercion
co) = RevFloatInBinds -> Expr CoreBndr -> Expr CoreBndr
wrapFloats RevFloatInBinds
to_drop (Coercion -> Expr CoreBndr
forall b. Coercion -> Expr b
Coercion Coercion
co)
fiExpr Platform
platform RevFloatInBinds
to_drop (BoundVarSet
_, AnnCast CoreExprWithFVs
expr (BoundVarSet
co_ann, Coercion
co))
= RevFloatInBinds -> Expr CoreBndr -> Expr CoreBndr
wrapFloats RevFloatInBinds
drop_here (Expr CoreBndr -> Expr CoreBndr) -> Expr CoreBndr -> Expr CoreBndr
forall a b. (a -> b) -> a -> b
$
Expr CoreBndr -> Coercion -> Expr CoreBndr
forall b. Expr b -> Coercion -> Expr b
Cast (Platform -> RevFloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
fiExpr Platform
platform RevFloatInBinds
e_drop CoreExprWithFVs
expr) Coercion
co
where
(RevFloatInBinds
drop_here, [RevFloatInBinds
e_drop])
= Platform
-> Bool
-> RevFloatInBinds
-> BoundVarSet
-> [BoundVarSet]
-> (RevFloatInBinds, [RevFloatInBinds])
sepBindsByDropPoint Platform
platform Bool
False RevFloatInBinds
to_drop
(BoundVarSet -> BoundVarSet
freeVarsOfAnn BoundVarSet
co_ann) [CoreExprWithFVs -> BoundVarSet
freeVarsOf CoreExprWithFVs
expr]
fiExpr Platform
platform RevFloatInBinds
to_drop ann_expr :: CoreExprWithFVs
ann_expr@(BoundVarSet
_,AnnApp {})
= RevFloatInBinds -> Expr CoreBndr -> Expr CoreBndr
wrapFloats RevFloatInBinds
drop_here (Expr CoreBndr -> Expr CoreBndr) -> Expr CoreBndr -> Expr CoreBndr
forall a b. (a -> b) -> a -> b
$
[CoreTickish] -> Expr CoreBndr -> Expr CoreBndr
mkTicks [CoreTickish]
ticks (Expr CoreBndr -> Expr CoreBndr) -> Expr CoreBndr -> Expr CoreBndr
forall a b. (a -> b) -> a -> b
$
Expr CoreBndr -> [Expr CoreBndr] -> Expr CoreBndr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Platform -> RevFloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
fiExpr Platform
platform RevFloatInBinds
fun_drop CoreExprWithFVs
ann_fun)
(String
-> (RevFloatInBinds -> CoreExprWithFVs -> Expr CoreBndr)
-> [RevFloatInBinds]
-> [CoreExprWithFVs]
-> [Expr CoreBndr]
forall a b c.
HasDebugCallStack =>
String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"fiExpr" (Platform -> RevFloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
fiExpr Platform
platform) [RevFloatInBinds]
arg_drops [CoreExprWithFVs]
ann_args)
where
(CoreExprWithFVs
ann_fun, [CoreExprWithFVs]
ann_args, [CoreTickish]
ticks) = (CoreTickish -> Bool)
-> CoreExprWithFVs
-> (CoreExprWithFVs, [CoreExprWithFVs], [CoreTickish])
forall b a.
(CoreTickish -> Bool)
-> AnnExpr b a -> (AnnExpr b a, [AnnExpr b a], [CoreTickish])
collectAnnArgsTicks CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable CoreExprWithFVs
ann_expr
fun_fvs :: BoundVarSet
fun_fvs = CoreExprWithFVs -> BoundVarSet
freeVarsOf CoreExprWithFVs
ann_fun
(RevFloatInBinds
drop_here, RevFloatInBinds
fun_drop : [RevFloatInBinds]
arg_drops)
= Platform
-> Bool
-> RevFloatInBinds
-> BoundVarSet
-> [BoundVarSet]
-> (RevFloatInBinds, [RevFloatInBinds])
sepBindsByDropPoint Platform
platform Bool
False RevFloatInBinds
to_drop
BoundVarSet
here_fvs (BoundVarSet
fun_fvs BoundVarSet -> [BoundVarSet] -> [BoundVarSet]
forall a. a -> [a] -> [a]
: [BoundVarSet]
arg_fvs)
(BoundVarSet
here_fvs, [BoundVarSet]
arg_fvs) = (BoundVarSet -> CoreExprWithFVs -> (BoundVarSet, BoundVarSet))
-> BoundVarSet -> [CoreExprWithFVs] -> (BoundVarSet, [BoundVarSet])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL BoundVarSet -> CoreExprWithFVs -> (BoundVarSet, BoundVarSet)
add_arg BoundVarSet
here_fvs0 [CoreExprWithFVs]
ann_args
here_fvs0 :: BoundVarSet
here_fvs0 = case CoreExprWithFVs
ann_fun of
(BoundVarSet
_, AnnVar CoreBndr
_) -> BoundVarSet
fun_fvs
CoreExprWithFVs
_ -> BoundVarSet
emptyDVarSet
add_arg :: FreeVarSet -> CoreExprWithFVs -> (FreeVarSet,FreeVarSet)
add_arg :: BoundVarSet -> CoreExprWithFVs -> (BoundVarSet, BoundVarSet)
add_arg BoundVarSet
here_fvs (BoundVarSet
arg_fvs, AnnExpr' CoreBndr BoundVarSet
arg)
| AnnExpr' CoreBndr BoundVarSet -> Bool
noFloatIntoArg AnnExpr' CoreBndr BoundVarSet
arg = (BoundVarSet
here_fvs BoundVarSet -> BoundVarSet -> BoundVarSet
`unionDVarSet` BoundVarSet
arg_fvs, BoundVarSet
emptyDVarSet)
| Bool
otherwise = (BoundVarSet
here_fvs, BoundVarSet
arg_fvs)
fiExpr Platform
platform RevFloatInBinds
to_drop lam :: CoreExprWithFVs
lam@(BoundVarSet
_, AnnLam CoreBndr
_ CoreExprWithFVs
_)
| [CoreBndr] -> Bool
noFloatIntoLam [CoreBndr]
bndrs
= RevFloatInBinds -> Expr CoreBndr -> Expr CoreBndr
wrapFloats RevFloatInBinds
to_drop ([CoreBndr] -> Expr CoreBndr -> Expr CoreBndr
forall b. [b] -> Expr b -> Expr b
mkLams [CoreBndr]
bndrs (Platform -> RevFloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
fiExpr Platform
platform [] CoreExprWithFVs
body))
| Bool
otherwise
= RevFloatInBinds -> Expr CoreBndr -> Expr CoreBndr
wrapFloats RevFloatInBinds
drop_here (Expr CoreBndr -> Expr CoreBndr) -> Expr CoreBndr -> Expr CoreBndr
forall a b. (a -> b) -> a -> b
$
[CoreBndr] -> Expr CoreBndr -> Expr CoreBndr
forall b. [b] -> Expr b -> Expr b
mkLams [CoreBndr]
bndrs (Platform -> RevFloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
fiExpr Platform
platform RevFloatInBinds
body_drop CoreExprWithFVs
body)
where
([CoreBndr]
bndrs, CoreExprWithFVs
body) = CoreExprWithFVs -> ([CoreBndr], CoreExprWithFVs)
forall bndr annot.
AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
collectAnnBndrs CoreExprWithFVs
lam
body_fvs :: BoundVarSet
body_fvs = CoreExprWithFVs -> BoundVarSet
freeVarsOf CoreExprWithFVs
body
(RevFloatInBinds
drop_here, [RevFloatInBinds
body_drop]) = Platform
-> Bool
-> RevFloatInBinds
-> BoundVarSet
-> [BoundVarSet]
-> (RevFloatInBinds, [RevFloatInBinds])
sepBindsByDropPoint Platform
platform Bool
False RevFloatInBinds
to_drop
([CoreBndr] -> BoundVarSet
mkDVarSet [CoreBndr]
bndrs) [BoundVarSet
body_fvs]
fiExpr Platform
platform RevFloatInBinds
to_drop (BoundVarSet
_, AnnTick CoreTickish
tickish CoreExprWithFVs
expr)
| CoreTickish
tickish CoreTickish -> TickishScoping -> Bool
forall (pass :: TickishPass).
GenTickish pass -> TickishScoping -> Bool
`tickishScopesLike` TickishScoping
SoftScope
= CoreTickish -> Expr CoreBndr -> Expr CoreBndr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
tickish (Platform -> RevFloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
fiExpr Platform
platform RevFloatInBinds
to_drop CoreExprWithFVs
expr)
| Bool
otherwise
= RevFloatInBinds -> Expr CoreBndr -> Expr CoreBndr
wrapFloats RevFloatInBinds
to_drop (CoreTickish -> Expr CoreBndr -> Expr CoreBndr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
tickish (Platform -> RevFloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
fiExpr Platform
platform [] CoreExprWithFVs
expr))
fiExpr Platform
platform RevFloatInBinds
to_drop (BoundVarSet
_,AnnLet AnnBind CoreBndr BoundVarSet
bind CoreExprWithFVs
body)
= Platform -> RevFloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
fiExpr Platform
platform (RevFloatInBinds
after RevFloatInBinds -> RevFloatInBinds -> RevFloatInBinds
forall a. [a] -> [a] -> [a]
++ FloatInBind
new_float FloatInBind -> RevFloatInBinds -> RevFloatInBinds
forall a. a -> [a] -> [a]
: RevFloatInBinds
before) CoreExprWithFVs
body
where
(RevFloatInBinds
before, FloatInBind
new_float, RevFloatInBinds
after) = Platform
-> RevFloatInBinds
-> AnnBind CoreBndr BoundVarSet
-> BoundVarSet
-> (RevFloatInBinds, FloatInBind, RevFloatInBinds)
fiBind Platform
platform RevFloatInBinds
to_drop AnnBind CoreBndr BoundVarSet
bind BoundVarSet
body_fvs
body_fvs :: BoundVarSet
body_fvs = CoreExprWithFVs -> BoundVarSet
freeVarsOf CoreExprWithFVs
body
fiExpr Platform
platform RevFloatInBinds
to_drop (BoundVarSet
_, AnnCase CoreExprWithFVs
scrut CoreBndr
case_bndr Type
_ [AnnAlt AltCon
con [CoreBndr]
alt_bndrs CoreExprWithFVs
rhs])
| HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType (CoreBndr -> Type
idType CoreBndr
case_bndr)
, Expr CoreBndr -> Bool
exprOkToDiscard (CoreExprWithFVs -> Expr CoreBndr
forall bndr annot. AnnExpr bndr annot -> Expr bndr
deAnnotate CoreExprWithFVs
scrut)
= RevFloatInBinds -> Expr CoreBndr -> Expr CoreBndr
wrapFloats RevFloatInBinds
shared_binds (Expr CoreBndr -> Expr CoreBndr) -> Expr CoreBndr -> Expr CoreBndr
forall a b. (a -> b) -> a -> b
$
Platform -> RevFloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
fiExpr Platform
platform (FloatInBind
case_float FloatInBind -> RevFloatInBinds -> RevFloatInBinds
forall a. a -> [a] -> [a]
: RevFloatInBinds
rhs_binds) CoreExprWithFVs
rhs
where
case_float :: FloatInBind
case_float = BoundVarSet -> BoundVarSet -> FloatBind -> FloatInBind
FB BoundVarSet
all_bndrs BoundVarSet
scrut_fvs
(Expr CoreBndr -> CoreBndr -> AltCon -> [CoreBndr] -> FloatBind
FloatCase Expr CoreBndr
scrut' CoreBndr
case_bndr AltCon
con [CoreBndr]
alt_bndrs)
scrut' :: Expr CoreBndr
scrut' = Platform -> RevFloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
fiExpr Platform
platform RevFloatInBinds
scrut_binds CoreExprWithFVs
scrut
rhs_fvs :: BoundVarSet
rhs_fvs = CoreExprWithFVs -> BoundVarSet
freeVarsOf CoreExprWithFVs
rhs
scrut_fvs :: BoundVarSet
scrut_fvs = CoreExprWithFVs -> BoundVarSet
freeVarsOf CoreExprWithFVs
scrut
all_bndrs :: BoundVarSet
all_bndrs = [CoreBndr] -> BoundVarSet
mkDVarSet [CoreBndr]
alt_bndrs BoundVarSet -> CoreBndr -> BoundVarSet
`extendDVarSet` CoreBndr
case_bndr
(RevFloatInBinds
shared_binds, [RevFloatInBinds
scrut_binds, RevFloatInBinds
rhs_binds])
= Platform
-> Bool
-> RevFloatInBinds
-> BoundVarSet
-> [BoundVarSet]
-> (RevFloatInBinds, [RevFloatInBinds])
sepBindsByDropPoint Platform
platform Bool
False RevFloatInBinds
to_drop
BoundVarSet
all_bndrs [BoundVarSet
scrut_fvs, BoundVarSet
rhs_fvs]
fiExpr Platform
platform RevFloatInBinds
to_drop (BoundVarSet
_, AnnCase CoreExprWithFVs
scrut CoreBndr
case_bndr Type
ty [AnnAlt CoreBndr BoundVarSet]
alts)
= RevFloatInBinds -> Expr CoreBndr -> Expr CoreBndr
wrapFloats RevFloatInBinds
drop_here1 (Expr CoreBndr -> Expr CoreBndr) -> Expr CoreBndr -> Expr CoreBndr
forall a b. (a -> b) -> a -> b
$
RevFloatInBinds -> Expr CoreBndr -> Expr CoreBndr
wrapFloats RevFloatInBinds
drop_here2 (Expr CoreBndr -> Expr CoreBndr) -> Expr CoreBndr -> Expr CoreBndr
forall a b. (a -> b) -> a -> b
$
Expr CoreBndr
-> CoreBndr -> Type -> [Alt CoreBndr] -> Expr CoreBndr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (Platform -> RevFloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
fiExpr Platform
platform RevFloatInBinds
scrut_drops CoreExprWithFVs
scrut) CoreBndr
case_bndr Type
ty
(String
-> (RevFloatInBinds -> AnnAlt CoreBndr BoundVarSet -> Alt CoreBndr)
-> [RevFloatInBinds]
-> [AnnAlt CoreBndr BoundVarSet]
-> [Alt CoreBndr]
forall a b c.
HasDebugCallStack =>
String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"fiExpr" RevFloatInBinds -> AnnAlt CoreBndr BoundVarSet -> Alt CoreBndr
fi_alt [RevFloatInBinds]
alts_drops_s [AnnAlt CoreBndr BoundVarSet]
alts)
where
(RevFloatInBinds
drop_here1, [RevFloatInBinds
scrut_drops, RevFloatInBinds
alts_drops])
= Platform
-> Bool
-> RevFloatInBinds
-> BoundVarSet
-> [BoundVarSet]
-> (RevFloatInBinds, [RevFloatInBinds])
sepBindsByDropPoint Platform
platform Bool
False RevFloatInBinds
to_drop
BoundVarSet
all_alt_bndrs [BoundVarSet
scrut_fvs, BoundVarSet
all_alt_fvs]
(RevFloatInBinds
drop_here2, [RevFloatInBinds]
alts_drops_s)
= Platform
-> Bool
-> RevFloatInBinds
-> BoundVarSet
-> [BoundVarSet]
-> (RevFloatInBinds, [RevFloatInBinds])
sepBindsByDropPoint Platform
platform Bool
True RevFloatInBinds
alts_drops BoundVarSet
emptyDVarSet [BoundVarSet]
alts_fvs
scrut_fvs :: BoundVarSet
scrut_fvs = CoreExprWithFVs -> BoundVarSet
freeVarsOf CoreExprWithFVs
scrut
all_alt_bndrs :: BoundVarSet
all_alt_bndrs = (AnnAlt CoreBndr BoundVarSet -> BoundVarSet -> BoundVarSet)
-> BoundVarSet -> [AnnAlt CoreBndr BoundVarSet] -> BoundVarSet
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (BoundVarSet -> BoundVarSet -> BoundVarSet
unionDVarSet (BoundVarSet -> BoundVarSet -> BoundVarSet)
-> (AnnAlt CoreBndr BoundVarSet -> BoundVarSet)
-> AnnAlt CoreBndr BoundVarSet
-> BoundVarSet
-> BoundVarSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnnAlt CoreBndr BoundVarSet -> BoundVarSet
forall {annot}. AnnAlt CoreBndr annot -> BoundVarSet
ann_alt_bndrs) (CoreBndr -> BoundVarSet
unitDVarSet CoreBndr
case_bndr) [AnnAlt CoreBndr BoundVarSet]
alts
ann_alt_bndrs :: AnnAlt CoreBndr annot -> BoundVarSet
ann_alt_bndrs (AnnAlt AltCon
_ [CoreBndr]
bndrs AnnExpr CoreBndr annot
_) = [CoreBndr] -> BoundVarSet
mkDVarSet [CoreBndr]
bndrs
alts_fvs :: [DVarSet]
alts_fvs :: [BoundVarSet]
alts_fvs = [CoreExprWithFVs -> BoundVarSet
freeVarsOf CoreExprWithFVs
rhs | AnnAlt AltCon
_ [CoreBndr]
_ CoreExprWithFVs
rhs <- [AnnAlt CoreBndr BoundVarSet]
alts]
all_alt_fvs :: DVarSet
all_alt_fvs :: BoundVarSet
all_alt_fvs = (BoundVarSet -> BoundVarSet -> BoundVarSet)
-> BoundVarSet -> [BoundVarSet] -> BoundVarSet
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr BoundVarSet -> BoundVarSet -> BoundVarSet
unionDVarSet (CoreBndr -> BoundVarSet
unitDVarSet CoreBndr
case_bndr) [BoundVarSet]
alts_fvs
fi_alt :: RevFloatInBinds -> AnnAlt CoreBndr BoundVarSet -> Alt CoreBndr
fi_alt RevFloatInBinds
to_drop (AnnAlt AltCon
con [CoreBndr]
args CoreExprWithFVs
rhs) = AltCon -> [CoreBndr] -> Expr CoreBndr -> Alt CoreBndr
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [CoreBndr]
args (Platform -> RevFloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
fiExpr Platform
platform RevFloatInBinds
to_drop CoreExprWithFVs
rhs)
fiBind :: Platform
-> RevFloatInBinds
-> CoreBindWithFVs
-> DVarSet
-> ( RevFloatInBinds
, FloatInBind
, RevFloatInBinds)
fiBind :: Platform
-> RevFloatInBinds
-> AnnBind CoreBndr BoundVarSet
-> BoundVarSet
-> (RevFloatInBinds, FloatInBind, RevFloatInBinds)
fiBind Platform
platform RevFloatInBinds
to_drop (AnnNonRec CoreBndr
id ann_rhs :: CoreExprWithFVs
ann_rhs@(BoundVarSet
rhs_fvs, AnnExpr' CoreBndr BoundVarSet
rhs)) BoundVarSet
body_fvs
= ( RevFloatInBinds
shared_binds
, BoundVarSet -> BoundVarSet -> FloatBind -> FloatInBind
FB (CoreBndr -> BoundVarSet
unitDVarSet CoreBndr
id) BoundVarSet
rhs_fvs'
(Bind CoreBndr -> FloatBind
FloatLet (CoreBndr -> Expr CoreBndr -> Bind CoreBndr
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
id Expr CoreBndr
rhs'))
, RevFloatInBinds
body_binds )
where
body_fvs2 :: BoundVarSet
body_fvs2 = BoundVarSet
body_fvs BoundVarSet -> CoreBndr -> BoundVarSet
`delDVarSet` CoreBndr
id
rule_fvs :: BoundVarSet
rule_fvs = CoreBndr -> BoundVarSet
bndrRuleAndUnfoldingVarsDSet CoreBndr
id
extra_fvs :: BoundVarSet
extra_fvs | RecFlag -> CoreBndr -> AnnExpr' CoreBndr BoundVarSet -> Bool
noFloatIntoRhs RecFlag
NonRecursive CoreBndr
id AnnExpr' CoreBndr BoundVarSet
rhs
= BoundVarSet
rule_fvs BoundVarSet -> BoundVarSet -> BoundVarSet
`unionDVarSet` BoundVarSet
rhs_fvs
| Bool
otherwise
= BoundVarSet
rule_fvs
(RevFloatInBinds
shared_binds, [RevFloatInBinds
rhs_binds, RevFloatInBinds
body_binds])
= Platform
-> Bool
-> RevFloatInBinds
-> BoundVarSet
-> [BoundVarSet]
-> (RevFloatInBinds, [RevFloatInBinds])
sepBindsByDropPoint Platform
platform Bool
False RevFloatInBinds
to_drop
BoundVarSet
extra_fvs [BoundVarSet
rhs_fvs, BoundVarSet
body_fvs2]
rhs' :: Expr CoreBndr
rhs' = Platform
-> RevFloatInBinds -> CoreBndr -> CoreExprWithFVs -> Expr CoreBndr
fiRhs Platform
platform RevFloatInBinds
rhs_binds CoreBndr
id CoreExprWithFVs
ann_rhs
rhs_fvs' :: BoundVarSet
rhs_fvs' = BoundVarSet
rhs_fvs BoundVarSet -> BoundVarSet -> BoundVarSet
`unionDVarSet` RevFloatInBinds -> BoundVarSet
floatedBindsFVs RevFloatInBinds
rhs_binds BoundVarSet -> BoundVarSet -> BoundVarSet
`unionDVarSet` BoundVarSet
rule_fvs
fiBind Platform
platform RevFloatInBinds
to_drop (AnnRec [(CoreBndr, CoreExprWithFVs)]
bindings) BoundVarSet
body_fvs
= ( RevFloatInBinds
shared_binds
, BoundVarSet -> BoundVarSet -> FloatBind -> FloatInBind
FB ([CoreBndr] -> BoundVarSet
mkDVarSet [CoreBndr]
ids) BoundVarSet
rhs_fvs'
(Bind CoreBndr -> FloatBind
FloatLet ([(CoreBndr, Expr CoreBndr)] -> Bind CoreBndr
forall b. [(b, Expr b)] -> Bind b
Rec ([RevFloatInBinds]
-> [(CoreBndr, CoreExprWithFVs)] -> [(CoreBndr, Expr CoreBndr)]
fi_bind [RevFloatInBinds]
rhss_binds [(CoreBndr, CoreExprWithFVs)]
bindings)))
, RevFloatInBinds
body_binds )
where
([CoreBndr]
ids, [CoreExprWithFVs]
rhss) = [(CoreBndr, CoreExprWithFVs)] -> ([CoreBndr], [CoreExprWithFVs])
forall a b. [(a, b)] -> ([a], [b])
unzip [(CoreBndr, CoreExprWithFVs)]
bindings
rhss_fvs :: [BoundVarSet]
rhss_fvs = (CoreExprWithFVs -> BoundVarSet)
-> [CoreExprWithFVs] -> [BoundVarSet]
forall a b. (a -> b) -> [a] -> [b]
map CoreExprWithFVs -> BoundVarSet
freeVarsOf [CoreExprWithFVs]
rhss
rule_fvs :: BoundVarSet
rule_fvs = (CoreBndr -> BoundVarSet) -> [CoreBndr] -> BoundVarSet
forall a. (a -> BoundVarSet) -> [a] -> BoundVarSet
mapUnionDVarSet CoreBndr -> BoundVarSet
bndrRuleAndUnfoldingVarsDSet [CoreBndr]
ids
extra_fvs :: BoundVarSet
extra_fvs = BoundVarSet
rule_fvs BoundVarSet -> BoundVarSet -> BoundVarSet
`unionDVarSet`
[BoundVarSet] -> BoundVarSet
unionDVarSets [ BoundVarSet
rhs_fvs | (CoreBndr
bndr, (BoundVarSet
rhs_fvs, AnnExpr' CoreBndr BoundVarSet
rhs)) <- [(CoreBndr, CoreExprWithFVs)]
bindings
, RecFlag -> CoreBndr -> AnnExpr' CoreBndr BoundVarSet -> Bool
noFloatIntoRhs RecFlag
Recursive CoreBndr
bndr AnnExpr' CoreBndr BoundVarSet
rhs ]
(RevFloatInBinds
shared_binds, RevFloatInBinds
body_binds:[RevFloatInBinds]
rhss_binds)
= Platform
-> Bool
-> RevFloatInBinds
-> BoundVarSet
-> [BoundVarSet]
-> (RevFloatInBinds, [RevFloatInBinds])
sepBindsByDropPoint Platform
platform Bool
False RevFloatInBinds
to_drop
BoundVarSet
extra_fvs (BoundVarSet
body_fvsBoundVarSet -> [BoundVarSet] -> [BoundVarSet]
forall a. a -> [a] -> [a]
:[BoundVarSet]
rhss_fvs)
rhs_fvs' :: BoundVarSet
rhs_fvs' = [BoundVarSet] -> BoundVarSet
unionDVarSets [BoundVarSet]
rhss_fvs BoundVarSet -> BoundVarSet -> BoundVarSet
`unionDVarSet`
[BoundVarSet] -> BoundVarSet
unionDVarSets ((RevFloatInBinds -> BoundVarSet)
-> [RevFloatInBinds] -> [BoundVarSet]
forall a b. (a -> b) -> [a] -> [b]
map RevFloatInBinds -> BoundVarSet
floatedBindsFVs [RevFloatInBinds]
rhss_binds) BoundVarSet -> BoundVarSet -> BoundVarSet
`unionDVarSet`
BoundVarSet
rule_fvs
fi_bind :: [RevFloatInBinds]
-> [(Id, CoreExprWithFVs)]
-> [(Id, CoreExpr)]
fi_bind :: [RevFloatInBinds]
-> [(CoreBndr, CoreExprWithFVs)] -> [(CoreBndr, Expr CoreBndr)]
fi_bind [RevFloatInBinds]
to_drops [(CoreBndr, CoreExprWithFVs)]
pairs
= [ (CoreBndr
binder, Platform
-> RevFloatInBinds -> CoreBndr -> CoreExprWithFVs -> Expr CoreBndr
fiRhs Platform
platform RevFloatInBinds
to_drop CoreBndr
binder CoreExprWithFVs
rhs)
| ((CoreBndr
binder, CoreExprWithFVs
rhs), RevFloatInBinds
to_drop) <- String
-> [(CoreBndr, CoreExprWithFVs)]
-> [RevFloatInBinds]
-> [((CoreBndr, CoreExprWithFVs), RevFloatInBinds)]
forall a b. HasDebugCallStack => String -> [a] -> [b] -> [(a, b)]
zipEqual String
"fi_bind" [(CoreBndr, CoreExprWithFVs)]
pairs [RevFloatInBinds]
to_drops ]
fiRhs :: Platform -> RevFloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr
fiRhs :: Platform
-> RevFloatInBinds -> CoreBndr -> CoreExprWithFVs -> Expr CoreBndr
fiRhs Platform
platform RevFloatInBinds
to_drop CoreBndr
bndr CoreExprWithFVs
rhs
| JoinPoint Int
join_arity <- CoreBndr -> JoinPointHood
idJoinPointHood CoreBndr
bndr
, let ([CoreBndr]
bndrs, CoreExprWithFVs
body) = Int -> CoreExprWithFVs -> ([CoreBndr], CoreExprWithFVs)
forall bndr annot.
Int -> AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
collectNAnnBndrs Int
join_arity CoreExprWithFVs
rhs
= [CoreBndr] -> Expr CoreBndr -> Expr CoreBndr
forall b. [b] -> Expr b -> Expr b
mkLams [CoreBndr]
bndrs (Platform -> RevFloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
fiExpr Platform
platform RevFloatInBinds
to_drop CoreExprWithFVs
body)
| Bool
otherwise
= Platform -> RevFloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
fiExpr Platform
platform RevFloatInBinds
to_drop CoreExprWithFVs
rhs
noFloatIntoLam :: [Var] -> Bool
noFloatIntoLam :: [CoreBndr] -> Bool
noFloatIntoLam [CoreBndr]
bndrs = (CoreBndr -> Bool) -> [CoreBndr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any CoreBndr -> Bool
bad [CoreBndr]
bndrs
where
bad :: CoreBndr -> Bool
bad CoreBndr
b = CoreBndr -> Bool
isId CoreBndr
b Bool -> Bool -> Bool
&& Bool -> Bool
not (CoreBndr -> Bool
isOneShotBndr CoreBndr
b)
noFloatIntoRhs :: RecFlag -> Id -> CoreExprWithFVs' -> Bool
noFloatIntoRhs :: RecFlag -> CoreBndr -> AnnExpr' CoreBndr BoundVarSet -> Bool
noFloatIntoRhs RecFlag
is_rec CoreBndr
bndr AnnExpr' CoreBndr BoundVarSet
rhs
| CoreBndr -> Bool
isJoinId CoreBndr
bndr
= RecFlag -> Bool
isRec RecFlag
is_rec
| Type -> Bool
definitelyUnliftedType (CoreBndr -> Type
idType CoreBndr
bndr)
= Bool
True
| Bool
otherwise
= AnnExpr' CoreBndr BoundVarSet -> Bool
noFloatIntoArg AnnExpr' CoreBndr BoundVarSet
rhs
noFloatIntoArg :: CoreExprWithFVs' -> Bool
noFloatIntoArg :: AnnExpr' CoreBndr BoundVarSet -> Bool
noFloatIntoArg AnnExpr' CoreBndr BoundVarSet
expr
| AnnLam CoreBndr
bndr CoreExprWithFVs
e <- AnnExpr' CoreBndr BoundVarSet
expr
, ([CoreBndr]
bndrs, CoreExprWithFVs
_) <- CoreExprWithFVs -> ([CoreBndr], CoreExprWithFVs)
forall bndr annot.
AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
collectAnnBndrs CoreExprWithFVs
e
= [CoreBndr] -> Bool
noFloatIntoLam (CoreBndr
bndrCoreBndr -> [CoreBndr] -> [CoreBndr]
forall a. a -> [a] -> [a]
:[CoreBndr]
bndrs)
Bool -> Bool -> Bool
|| (CoreBndr -> Bool) -> [CoreBndr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all CoreBndr -> Bool
isTyVar (CoreBndr
bndrCoreBndr -> [CoreBndr] -> [CoreBndr]
forall a. a -> [a] -> [a]
:[CoreBndr]
bndrs)
| Bool
otherwise
= Expr CoreBndr -> Bool
exprIsTrivial Expr CoreBndr
deann_expr Bool -> Bool -> Bool
|| Expr CoreBndr -> Bool
exprIsHNF Expr CoreBndr
deann_expr
where
deann_expr :: Expr CoreBndr
deann_expr = AnnExpr' CoreBndr BoundVarSet -> Expr CoreBndr
forall bndr annot. AnnExpr' bndr annot -> Expr bndr
deAnnotate' AnnExpr' CoreBndr BoundVarSet
expr
sepBindsByDropPoint
:: Platform
-> Bool
-> RevFloatInBinds
-> FreeVarSet
-> [FreeVarSet]
-> ( RevFloatInBinds
, [RevFloatInBinds] )
type DropBox = (FreeVarSet, FloatInBinds)
dropBoxFloats :: DropBox -> RevFloatInBinds
dropBoxFloats :: DropBox -> RevFloatInBinds
dropBoxFloats (BoundVarSet
_, RevFloatInBinds
floats) = RevFloatInBinds -> RevFloatInBinds
forall a. [a] -> [a]
reverse RevFloatInBinds
floats
usedInDropBox :: DIdSet -> DropBox -> Bool
usedInDropBox :: BoundVarSet -> DropBox -> Bool
usedInDropBox BoundVarSet
bndrs (BoundVarSet
db_fvs, RevFloatInBinds
_) = BoundVarSet
db_fvs BoundVarSet -> BoundVarSet -> Bool
`intersectsDVarSet` BoundVarSet
bndrs
initDropBox :: DVarSet -> DropBox
initDropBox :: BoundVarSet -> DropBox
initDropBox BoundVarSet
fvs = (BoundVarSet
fvs, [])
sepBindsByDropPoint :: Platform
-> Bool
-> RevFloatInBinds
-> BoundVarSet
-> [BoundVarSet]
-> (RevFloatInBinds, [RevFloatInBinds])
sepBindsByDropPoint Platform
platform Bool
is_case RevFloatInBinds
floaters BoundVarSet
here_fvs [BoundVarSet]
fork_fvs
| RevFloatInBinds -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null RevFloatInBinds
floaters
= ([], [[] | BoundVarSet
_ <- [BoundVarSet]
fork_fvs])
| Bool
otherwise
= RevFloatInBinds
-> DropBox -> [DropBox] -> (RevFloatInBinds, [RevFloatInBinds])
go RevFloatInBinds
floaters (BoundVarSet -> DropBox
initDropBox BoundVarSet
here_fvs) ((BoundVarSet -> DropBox) -> [BoundVarSet] -> [DropBox]
forall a b. (a -> b) -> [a] -> [b]
map BoundVarSet -> DropBox
initDropBox [BoundVarSet]
fork_fvs)
where
n_alts :: Int
n_alts = [BoundVarSet] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BoundVarSet]
fork_fvs
go :: RevFloatInBinds -> DropBox -> [DropBox]
-> (RevFloatInBinds, [RevFloatInBinds])
go :: RevFloatInBinds
-> DropBox -> [DropBox] -> (RevFloatInBinds, [RevFloatInBinds])
go [] DropBox
here_box [DropBox]
fork_boxes
= (DropBox -> RevFloatInBinds
dropBoxFloats DropBox
here_box, (DropBox -> RevFloatInBinds) -> [DropBox] -> [RevFloatInBinds]
forall a b. (a -> b) -> [a] -> [b]
map DropBox -> RevFloatInBinds
dropBoxFloats [DropBox]
fork_boxes)
go (bind_w_fvs :: FloatInBind
bind_w_fvs@(FB BoundVarSet
bndrs BoundVarSet
bind_fvs FloatBind
bind) : RevFloatInBinds
binds) DropBox
here_box [DropBox]
fork_boxes
| Bool
drop_here = RevFloatInBinds
-> DropBox -> [DropBox] -> (RevFloatInBinds, [RevFloatInBinds])
go RevFloatInBinds
binds (DropBox -> DropBox
insert DropBox
here_box) [DropBox]
fork_boxes
| Bool
otherwise = RevFloatInBinds
-> DropBox -> [DropBox] -> (RevFloatInBinds, [RevFloatInBinds])
go RevFloatInBinds
binds DropBox
here_box [DropBox]
new_fork_boxes
where
used_here :: Bool
used_here = BoundVarSet
bndrs BoundVarSet -> DropBox -> Bool
`usedInDropBox` DropBox
here_box
used_in_flags :: [Bool]
used_in_flags = case [DropBox]
fork_boxes of
[] -> []
[DropBox
_] -> [Bool
True]
[DropBox]
_ -> (DropBox -> Bool) -> [DropBox] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (BoundVarSet
bndrs BoundVarSet -> DropBox -> Bool
`usedInDropBox`) [DropBox]
fork_boxes
drop_here :: Bool
drop_here = Bool
used_here Bool -> Bool -> Bool
|| Bool
cant_push
n_used_alts :: Int
n_used_alts = (Bool -> Bool) -> [Bool] -> Int
forall a. (a -> Bool) -> [a] -> Int
count Bool -> Bool
forall a. a -> a
id [Bool]
used_in_flags
cant_push :: Bool
cant_push
| Bool
is_case = (Int
n_alts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 Bool -> Bool -> Bool
&& Int
n_used_alts Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n_alts)
Bool -> Bool -> Bool
|| (Int
n_used_alts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 Bool -> Bool -> Bool
&& Bool -> Bool
not (Platform -> FloatBind -> Bool
floatIsDupable Platform
platform FloatBind
bind))
| Bool
otherwise = FloatBind -> Bool
floatIsCase FloatBind
bind Bool -> Bool -> Bool
|| Int
n_used_alts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
new_fork_boxes :: [DropBox]
new_fork_boxes = String
-> (DropBox -> Bool -> DropBox) -> [DropBox] -> [Bool] -> [DropBox]
forall a b c.
HasDebugCallStack =>
String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"FloatIn.sepBinds" DropBox -> Bool -> DropBox
insert_maybe
[DropBox]
fork_boxes [Bool]
used_in_flags
insert :: DropBox -> DropBox
insert :: DropBox -> DropBox
insert (BoundVarSet
fvs,RevFloatInBinds
drops) = (BoundVarSet
fvs BoundVarSet -> BoundVarSet -> BoundVarSet
`unionDVarSet` BoundVarSet
bind_fvs, FloatInBind
bind_w_fvsFloatInBind -> RevFloatInBinds -> RevFloatInBinds
forall a. a -> [a] -> [a]
:RevFloatInBinds
drops)
insert_maybe :: DropBox -> Bool -> DropBox
insert_maybe DropBox
box Bool
True = DropBox -> DropBox
insert DropBox
box
insert_maybe DropBox
box Bool
False = DropBox
box
floatedBindsFVs :: RevFloatInBinds -> FreeVarSet
floatedBindsFVs :: RevFloatInBinds -> BoundVarSet
floatedBindsFVs RevFloatInBinds
binds = (FloatInBind -> BoundVarSet) -> RevFloatInBinds -> BoundVarSet
forall a. (a -> BoundVarSet) -> [a] -> BoundVarSet
mapUnionDVarSet FloatInBind -> BoundVarSet
fbFVs RevFloatInBinds
binds
fbFVs :: FloatInBind -> DVarSet
fbFVs :: FloatInBind -> BoundVarSet
fbFVs (FB BoundVarSet
_ BoundVarSet
fvs FloatBind
_) = BoundVarSet
fvs
wrapFloats :: RevFloatInBinds -> CoreExpr -> CoreExpr
wrapFloats :: RevFloatInBinds -> Expr CoreBndr -> Expr CoreBndr
wrapFloats [] Expr CoreBndr
e = Expr CoreBndr
e
wrapFloats (FB BoundVarSet
_ BoundVarSet
_ FloatBind
fl : RevFloatInBinds
bs) Expr CoreBndr
e = RevFloatInBinds -> Expr CoreBndr -> Expr CoreBndr
wrapFloats RevFloatInBinds
bs (FloatBind -> Expr CoreBndr -> Expr CoreBndr
wrapFloat FloatBind
fl Expr CoreBndr
e)
floatIsDupable :: Platform -> FloatBind -> Bool
floatIsDupable :: Platform -> FloatBind -> Bool
floatIsDupable Platform
platform (FloatCase Expr CoreBndr
scrut CoreBndr
_ AltCon
_ [CoreBndr]
_) = Platform -> Expr CoreBndr -> Bool
exprIsDupable Platform
platform Expr CoreBndr
scrut
floatIsDupable Platform
platform (FloatLet (Rec [(CoreBndr, Expr CoreBndr)]
prs)) = ((CoreBndr, Expr CoreBndr) -> Bool)
-> [(CoreBndr, Expr CoreBndr)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Platform -> Expr CoreBndr -> Bool
exprIsDupable Platform
platform (Expr CoreBndr -> Bool)
-> ((CoreBndr, Expr CoreBndr) -> Expr CoreBndr)
-> (CoreBndr, Expr CoreBndr)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CoreBndr, Expr CoreBndr) -> Expr CoreBndr
forall a b. (a, b) -> b
snd) [(CoreBndr, Expr CoreBndr)]
prs
floatIsDupable Platform
platform (FloatLet (NonRec CoreBndr
_ Expr CoreBndr
r)) = Platform -> Expr CoreBndr -> Bool
exprIsDupable Platform
platform Expr CoreBndr
r
floatIsCase :: FloatBind -> Bool
floatIsCase :: FloatBind -> Bool
floatIsCase (FloatCase {}) = Bool
True
floatIsCase (FloatLet {}) = Bool
False