{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fprof-auto #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Core.Opt.FloatIn ( floatInwards ) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Platform
import GHC.Driver.Session
import GHC.Core
import GHC.Core.Make hiding ( wrapFloats )
import GHC.Core.Utils
import GHC.Core.FVs
import GHC.Core.Opt.Monad ( CoreM )
import GHC.Core.Type
import GHC.Types.Basic ( RecFlag(..), isRec )
import GHC.Types.Id ( isOneShotBndr, idType, isJoinId, isJoinId_maybe )
import GHC.Types.Tickish
import GHC.Types.Var
import GHC.Types.Var.Set
import GHC.Unit.Module.ModGuts
import GHC.Utils.Misc
import GHC.Utils.Panic
floatInwards :: ModGuts -> CoreM ModGuts
floatInwards :: ModGuts -> CoreM ModGuts
floatInwards pgm :: ModGuts
pgm@(ModGuts { mg_binds :: ModGuts -> CoreProgram
mg_binds = CoreProgram
binds })
= do { DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
; forall (m :: * -> *) a. Monad m => a -> m a
return (ModGuts
pgm { mg_binds :: CoreProgram
mg_binds = 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)
= forall b. b -> Expr b -> Bind b
NonRec CoreBndr
binder (Platform -> FloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
fiExpr Platform
platform [] (Expr CoreBndr -> CoreExprWithFVs
freeVars Expr CoreBndr
rhs))
fi_top_bind Platform
platform (Rec [(CoreBndr, Expr CoreBndr)]
pairs)
= forall b. [(b, Expr b)] -> Bind b
Rec [ (CoreBndr
b, Platform -> FloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
fiExpr Platform
platform [] (Expr CoreBndr -> CoreExprWithFVs
freeVars Expr CoreBndr
rhs)) | (CoreBndr
b, Expr CoreBndr
rhs) <- [(CoreBndr, Expr CoreBndr)]
pairs ]
type FreeVarSet = DIdSet
type BoundVarSet = DIdSet
data FloatInBind = FB BoundVarSet FreeVarSet FloatBind
type FloatInBinds = [FloatInBind]
fiExpr :: Platform
-> FloatInBinds
-> CoreExprWithFVs
-> CoreExpr
fiExpr :: Platform -> FloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
fiExpr Platform
_ FloatInBinds
to_drop (FVAnn
_, AnnLit Literal
lit) = FloatInBinds -> Expr CoreBndr -> Expr CoreBndr
wrapFloats FloatInBinds
to_drop (forall b. Literal -> Expr b
Lit Literal
lit)
fiExpr Platform
_ FloatInBinds
to_drop (FVAnn
_, AnnType Type
ty) = ASSERT( null to_drop ) Type ty
fiExpr Platform
_ FloatInBinds
to_drop (FVAnn
_, AnnVar CoreBndr
v) = FloatInBinds -> Expr CoreBndr -> Expr CoreBndr
wrapFloats FloatInBinds
to_drop (forall b. CoreBndr -> Expr b
Var CoreBndr
v)
fiExpr Platform
_ FloatInBinds
to_drop (FVAnn
_, AnnCoercion Coercion
co) = FloatInBinds -> Expr CoreBndr -> Expr CoreBndr
wrapFloats FloatInBinds
to_drop (forall b. Coercion -> Expr b
Coercion Coercion
co)
fiExpr Platform
platform FloatInBinds
to_drop (FVAnn
_, AnnCast CoreExprWithFVs
expr (FVAnn
co_ann, Coercion
co))
= FloatInBinds -> Expr CoreBndr -> Expr CoreBndr
wrapFloats (FloatInBinds
drop_here forall a. [a] -> [a] -> [a]
++ FloatInBinds
co_drop) forall a b. (a -> b) -> a -> b
$
forall b. Expr b -> Coercion -> Expr b
Cast (Platform -> FloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
fiExpr Platform
platform FloatInBinds
e_drop CoreExprWithFVs
expr) Coercion
co
where
[FloatInBinds
drop_here, FloatInBinds
e_drop, FloatInBinds
co_drop]
= Platform -> Bool -> [FVAnn] -> FloatInBinds -> [FloatInBinds]
sepBindsByDropPoint Platform
platform Bool
False
[CoreExprWithFVs -> FVAnn
freeVarsOf CoreExprWithFVs
expr, FVAnn -> FVAnn
freeVarsOfAnn FVAnn
co_ann]
FloatInBinds
to_drop
fiExpr Platform
platform FloatInBinds
to_drop ann_expr :: CoreExprWithFVs
ann_expr@(FVAnn
_,AnnApp {})
= FloatInBinds -> Expr CoreBndr -> Expr CoreBndr
wrapFloats FloatInBinds
drop_here forall a b. (a -> b) -> a -> b
$ FloatInBinds -> Expr CoreBndr -> Expr CoreBndr
wrapFloats FloatInBinds
extra_drop forall a b. (a -> b) -> a -> b
$
[CoreTickish] -> Expr CoreBndr -> Expr CoreBndr
mkTicks [CoreTickish]
ticks forall a b. (a -> b) -> a -> b
$
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Platform -> FloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
fiExpr Platform
platform FloatInBinds
fun_drop CoreExprWithFVs
ann_fun)
(forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"fiExpr" (Platform -> FloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
fiExpr Platform
platform) [FloatInBinds]
arg_drops [CoreExprWithFVs]
ann_args)
where
(CoreExprWithFVs
ann_fun, [CoreExprWithFVs]
ann_args, [CoreTickish]
ticks) = forall b a.
(CoreTickish -> Bool)
-> AnnExpr b a -> (AnnExpr b a, [AnnExpr b a], [CoreTickish])
collectAnnArgsTicks forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable CoreExprWithFVs
ann_expr
fun_ty :: Type
fun_ty = Expr CoreBndr -> Type
exprType (forall bndr annot. AnnExpr bndr annot -> Expr bndr
deAnnotate CoreExprWithFVs
ann_fun)
fun_fvs :: FVAnn
fun_fvs = CoreExprWithFVs -> FVAnn
freeVarsOf CoreExprWithFVs
ann_fun
arg_fvs :: [FVAnn]
arg_fvs = forall a b. (a -> b) -> [a] -> [b]
map CoreExprWithFVs -> FVAnn
freeVarsOf [CoreExprWithFVs]
ann_args
(FloatInBinds
drop_here : FloatInBinds
extra_drop : FloatInBinds
fun_drop : [FloatInBinds]
arg_drops)
= Platform -> Bool -> [FVAnn] -> FloatInBinds -> [FloatInBinds]
sepBindsByDropPoint Platform
platform Bool
False
(FVAnn
extra_fvs forall a. a -> [a] -> [a]
: FVAnn
fun_fvs forall a. a -> [a] -> [a]
: [FVAnn]
arg_fvs)
FloatInBinds
to_drop
(Type
_, FVAnn
extra_fvs) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Type, FVAnn) -> CoreExprWithFVs -> (Type, FVAnn)
add_arg (Type
fun_ty, FVAnn
extra_fvs0) [CoreExprWithFVs]
ann_args
extra_fvs0 :: FVAnn
extra_fvs0 = case CoreExprWithFVs
ann_fun of
(FVAnn
_, AnnVar CoreBndr
_) -> FVAnn
fun_fvs
CoreExprWithFVs
_ -> FVAnn
emptyDVarSet
add_arg :: (Type,FreeVarSet) -> CoreExprWithFVs -> (Type,FreeVarSet)
add_arg :: (Type, FVAnn) -> CoreExprWithFVs -> (Type, FVAnn)
add_arg (Type
fun_ty, FVAnn
extra_fvs) (FVAnn
_, AnnType Type
ty)
= (HasDebugCallStack => Type -> Type -> Type
piResultTy Type
fun_ty Type
ty, FVAnn
extra_fvs)
add_arg (Type
fun_ty, FVAnn
extra_fvs) (FVAnn
arg_fvs, AnnExpr' CoreBndr FVAnn
arg)
| AnnExpr' CoreBndr FVAnn -> Type -> Bool
noFloatIntoArg AnnExpr' CoreBndr FVAnn
arg Type
arg_ty
= (Type
res_ty, FVAnn
extra_fvs FVAnn -> FVAnn -> FVAnn
`unionDVarSet` FVAnn
arg_fvs)
| Bool
otherwise
= (Type
res_ty, FVAnn
extra_fvs)
where
(Type
_, Type
arg_ty, Type
res_ty) = Type -> (Type, Type, Type)
splitFunTy Type
fun_ty
fiExpr Platform
platform FloatInBinds
to_drop lam :: CoreExprWithFVs
lam@(FVAnn
_, AnnLam CoreBndr
_ CoreExprWithFVs
_)
| [CoreBndr] -> Bool
noFloatIntoLam [CoreBndr]
bndrs
= FloatInBinds -> Expr CoreBndr -> Expr CoreBndr
wrapFloats FloatInBinds
to_drop (forall b. [b] -> Expr b -> Expr b
mkLams [CoreBndr]
bndrs (Platform -> FloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
fiExpr Platform
platform [] CoreExprWithFVs
body))
| Bool
otherwise
= forall b. [b] -> Expr b -> Expr b
mkLams [CoreBndr]
bndrs (Platform -> FloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
fiExpr Platform
platform FloatInBinds
to_drop CoreExprWithFVs
body)
where
([CoreBndr]
bndrs, CoreExprWithFVs
body) = forall bndr annot.
AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
collectAnnBndrs CoreExprWithFVs
lam
fiExpr Platform
platform FloatInBinds
to_drop (FVAnn
_, AnnTick CoreTickish
tickish CoreExprWithFVs
expr)
| CoreTickish
tickish forall (pass :: TickishPass).
GenTickish pass -> TickishScoping -> Bool
`tickishScopesLike` TickishScoping
SoftScope
= forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
tickish (Platform -> FloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
fiExpr Platform
platform FloatInBinds
to_drop CoreExprWithFVs
expr)
| Bool
otherwise
= FloatInBinds -> Expr CoreBndr -> Expr CoreBndr
wrapFloats FloatInBinds
to_drop (forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
tickish (Platform -> FloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
fiExpr Platform
platform [] CoreExprWithFVs
expr))
fiExpr Platform
platform FloatInBinds
to_drop (FVAnn
_,AnnLet AnnBind CoreBndr FVAnn
bind CoreExprWithFVs
body)
= Platform -> FloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
fiExpr Platform
platform (FloatInBinds
after forall a. [a] -> [a] -> [a]
++ FloatInBind
new_float forall a. a -> [a] -> [a]
: FloatInBinds
before) CoreExprWithFVs
body
where
(FloatInBinds
before, FloatInBind
new_float, FloatInBinds
after) = Platform
-> FloatInBinds
-> AnnBind CoreBndr FVAnn
-> FVAnn
-> (FloatInBinds, FloatInBind, FloatInBinds)
fiBind Platform
platform FloatInBinds
to_drop AnnBind CoreBndr FVAnn
bind FVAnn
body_fvs
body_fvs :: FVAnn
body_fvs = CoreExprWithFVs -> FVAnn
freeVarsOf CoreExprWithFVs
body
fiExpr Platform
platform FloatInBinds
to_drop (FVAnn
_, AnnCase CoreExprWithFVs
scrut CoreBndr
case_bndr Type
_ [AnnAlt AltCon
con [CoreBndr]
alt_bndrs CoreExprWithFVs
rhs])
| HasDebugCallStack => Type -> Bool
isUnliftedType (CoreBndr -> Type
idType CoreBndr
case_bndr)
, Expr CoreBndr -> Bool
exprOkForSideEffects (forall bndr annot. AnnExpr bndr annot -> Expr bndr
deAnnotate CoreExprWithFVs
scrut)
= FloatInBinds -> Expr CoreBndr -> Expr CoreBndr
wrapFloats FloatInBinds
shared_binds forall a b. (a -> b) -> a -> b
$
Platform -> FloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
fiExpr Platform
platform (FloatInBind
case_float forall a. a -> [a] -> [a]
: FloatInBinds
rhs_binds) CoreExprWithFVs
rhs
where
case_float :: FloatInBind
case_float = FVAnn -> FVAnn -> FloatBind -> FloatInBind
FB ([CoreBndr] -> FVAnn
mkDVarSet (CoreBndr
case_bndr forall a. a -> [a] -> [a]
: [CoreBndr]
alt_bndrs)) FVAnn
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 -> FloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
fiExpr Platform
platform FloatInBinds
scrut_binds CoreExprWithFVs
scrut
rhs_fvs :: FVAnn
rhs_fvs = CoreExprWithFVs -> FVAnn
freeVarsOf CoreExprWithFVs
rhs FVAnn -> [CoreBndr] -> FVAnn
`delDVarSetList` (CoreBndr
case_bndr forall a. a -> [a] -> [a]
: [CoreBndr]
alt_bndrs)
scrut_fvs :: FVAnn
scrut_fvs = CoreExprWithFVs -> FVAnn
freeVarsOf CoreExprWithFVs
scrut
[FloatInBinds
shared_binds, FloatInBinds
scrut_binds, FloatInBinds
rhs_binds]
= Platform -> Bool -> [FVAnn] -> FloatInBinds -> [FloatInBinds]
sepBindsByDropPoint Platform
platform Bool
False
[FVAnn
scrut_fvs, FVAnn
rhs_fvs]
FloatInBinds
to_drop
fiExpr Platform
platform FloatInBinds
to_drop (FVAnn
_, AnnCase CoreExprWithFVs
scrut CoreBndr
case_bndr Type
ty [AnnAlt CoreBndr FVAnn]
alts)
= FloatInBinds -> Expr CoreBndr -> Expr CoreBndr
wrapFloats FloatInBinds
drop_here1 forall a b. (a -> b) -> a -> b
$
FloatInBinds -> Expr CoreBndr -> Expr CoreBndr
wrapFloats FloatInBinds
drop_here2 forall a b. (a -> b) -> a -> b
$
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (Platform -> FloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
fiExpr Platform
platform FloatInBinds
scrut_drops CoreExprWithFVs
scrut) CoreBndr
case_bndr Type
ty
(forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"fiExpr" FloatInBinds -> AnnAlt CoreBndr FVAnn -> Alt CoreBndr
fi_alt [FloatInBinds]
alts_drops_s [AnnAlt CoreBndr FVAnn]
alts)
where
[FloatInBinds
drop_here1, FloatInBinds
scrut_drops, FloatInBinds
alts_drops]
= Platform -> Bool -> [FVAnn] -> FloatInBinds -> [FloatInBinds]
sepBindsByDropPoint Platform
platform Bool
False
[FVAnn
scrut_fvs, FVAnn
all_alts_fvs]
FloatInBinds
to_drop
(FloatInBinds
drop_here2 : [FloatInBinds]
alts_drops_s)
| [ AnnAlt CoreBndr FVAnn
_ ] <- [AnnAlt CoreBndr FVAnn]
alts = [] forall a. a -> [a] -> [a]
: [FloatInBinds
alts_drops]
| Bool
otherwise = Platform -> Bool -> [FVAnn] -> FloatInBinds -> [FloatInBinds]
sepBindsByDropPoint Platform
platform Bool
True [FVAnn]
alts_fvs FloatInBinds
alts_drops
scrut_fvs :: FVAnn
scrut_fvs = CoreExprWithFVs -> FVAnn
freeVarsOf CoreExprWithFVs
scrut
alts_fvs :: [FVAnn]
alts_fvs = forall a b. (a -> b) -> [a] -> [b]
map AnnAlt CoreBndr FVAnn -> FVAnn
alt_fvs [AnnAlt CoreBndr FVAnn]
alts
all_alts_fvs :: FVAnn
all_alts_fvs = [FVAnn] -> FVAnn
unionDVarSets [FVAnn]
alts_fvs
alt_fvs :: AnnAlt CoreBndr FVAnn -> FVAnn
alt_fvs (AnnAlt AltCon
_con [CoreBndr]
args CoreExprWithFVs
rhs)
= forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' FVAnn -> CoreBndr -> FVAnn
delDVarSet (CoreExprWithFVs -> FVAnn
freeVarsOf CoreExprWithFVs
rhs) (CoreBndr
case_bndrforall a. a -> [a] -> [a]
:[CoreBndr]
args)
fi_alt :: FloatInBinds -> AnnAlt CoreBndr FVAnn -> Alt CoreBndr
fi_alt FloatInBinds
to_drop (AnnAlt AltCon
con [CoreBndr]
args CoreExprWithFVs
rhs) = forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [CoreBndr]
args (Platform -> FloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
fiExpr Platform
platform FloatInBinds
to_drop CoreExprWithFVs
rhs)
fiBind :: Platform
-> FloatInBinds
-> CoreBindWithFVs
-> DVarSet
-> ( FloatInBinds
, FloatInBind
, FloatInBinds)
fiBind :: Platform
-> FloatInBinds
-> AnnBind CoreBndr FVAnn
-> FVAnn
-> (FloatInBinds, FloatInBind, FloatInBinds)
fiBind Platform
platform FloatInBinds
to_drop (AnnNonRec CoreBndr
id ann_rhs :: CoreExprWithFVs
ann_rhs@(FVAnn
rhs_fvs, AnnExpr' CoreBndr FVAnn
rhs)) FVAnn
body_fvs
= ( FloatInBinds
extra_binds forall a. [a] -> [a] -> [a]
++ FloatInBinds
shared_binds
, FVAnn -> FVAnn -> FloatBind -> FloatInBind
FB (CoreBndr -> FVAnn
unitDVarSet CoreBndr
id) FVAnn
rhs_fvs'
(Bind CoreBndr -> FloatBind
FloatLet (forall b. b -> Expr b -> Bind b
NonRec CoreBndr
id Expr CoreBndr
rhs'))
, FloatInBinds
body_binds )
where
body_fvs2 :: FVAnn
body_fvs2 = FVAnn
body_fvs FVAnn -> CoreBndr -> FVAnn
`delDVarSet` CoreBndr
id
rule_fvs :: FVAnn
rule_fvs = CoreBndr -> FVAnn
bndrRuleAndUnfoldingVarsDSet CoreBndr
id
extra_fvs :: FVAnn
extra_fvs | RecFlag -> CoreBndr -> AnnExpr' CoreBndr FVAnn -> Bool
noFloatIntoRhs RecFlag
NonRecursive CoreBndr
id AnnExpr' CoreBndr FVAnn
rhs
= FVAnn
rule_fvs FVAnn -> FVAnn -> FVAnn
`unionDVarSet` FVAnn
rhs_fvs
| Bool
otherwise
= FVAnn
rule_fvs
[FloatInBinds
shared_binds, FloatInBinds
extra_binds, FloatInBinds
rhs_binds, FloatInBinds
body_binds]
= Platform -> Bool -> [FVAnn] -> FloatInBinds -> [FloatInBinds]
sepBindsByDropPoint Platform
platform Bool
False
[FVAnn
extra_fvs, FVAnn
rhs_fvs, FVAnn
body_fvs2]
FloatInBinds
to_drop
rhs' :: Expr CoreBndr
rhs' = Platform
-> FloatInBinds -> CoreBndr -> CoreExprWithFVs -> Expr CoreBndr
fiRhs Platform
platform FloatInBinds
rhs_binds CoreBndr
id CoreExprWithFVs
ann_rhs
rhs_fvs' :: FVAnn
rhs_fvs' = FVAnn
rhs_fvs FVAnn -> FVAnn -> FVAnn
`unionDVarSet` FloatInBinds -> FVAnn
floatedBindsFVs FloatInBinds
rhs_binds FVAnn -> FVAnn -> FVAnn
`unionDVarSet` FVAnn
rule_fvs
fiBind Platform
platform FloatInBinds
to_drop (AnnRec [(CoreBndr, CoreExprWithFVs)]
bindings) FVAnn
body_fvs
= ( FloatInBinds
extra_binds forall a. [a] -> [a] -> [a]
++ FloatInBinds
shared_binds
, FVAnn -> FVAnn -> FloatBind -> FloatInBind
FB ([CoreBndr] -> FVAnn
mkDVarSet [CoreBndr]
ids) FVAnn
rhs_fvs'
(Bind CoreBndr -> FloatBind
FloatLet (forall b. [(b, Expr b)] -> Bind b
Rec ([FloatInBinds]
-> [(CoreBndr, CoreExprWithFVs)] -> [(CoreBndr, Expr CoreBndr)]
fi_bind [FloatInBinds]
rhss_binds [(CoreBndr, CoreExprWithFVs)]
bindings)))
, FloatInBinds
body_binds )
where
([CoreBndr]
ids, [CoreExprWithFVs]
rhss) = forall a b. [(a, b)] -> ([a], [b])
unzip [(CoreBndr, CoreExprWithFVs)]
bindings
rhss_fvs :: [FVAnn]
rhss_fvs = forall a b. (a -> b) -> [a] -> [b]
map CoreExprWithFVs -> FVAnn
freeVarsOf [CoreExprWithFVs]
rhss
rule_fvs :: FVAnn
rule_fvs = forall a. (a -> FVAnn) -> [a] -> FVAnn
mapUnionDVarSet CoreBndr -> FVAnn
bndrRuleAndUnfoldingVarsDSet [CoreBndr]
ids
extra_fvs :: FVAnn
extra_fvs = FVAnn
rule_fvs FVAnn -> FVAnn -> FVAnn
`unionDVarSet`
[FVAnn] -> FVAnn
unionDVarSets [ FVAnn
rhs_fvs | (CoreBndr
bndr, (FVAnn
rhs_fvs, AnnExpr' CoreBndr FVAnn
rhs)) <- [(CoreBndr, CoreExprWithFVs)]
bindings
, RecFlag -> CoreBndr -> AnnExpr' CoreBndr FVAnn -> Bool
noFloatIntoRhs RecFlag
Recursive CoreBndr
bndr AnnExpr' CoreBndr FVAnn
rhs ]
(FloatInBinds
shared_binds:FloatInBinds
extra_binds:FloatInBinds
body_binds:[FloatInBinds]
rhss_binds)
= Platform -> Bool -> [FVAnn] -> FloatInBinds -> [FloatInBinds]
sepBindsByDropPoint Platform
platform Bool
False
(FVAnn
extra_fvsforall a. a -> [a] -> [a]
:FVAnn
body_fvsforall a. a -> [a] -> [a]
:[FVAnn]
rhss_fvs)
FloatInBinds
to_drop
rhs_fvs' :: FVAnn
rhs_fvs' = [FVAnn] -> FVAnn
unionDVarSets [FVAnn]
rhss_fvs FVAnn -> FVAnn -> FVAnn
`unionDVarSet`
[FVAnn] -> FVAnn
unionDVarSets (forall a b. (a -> b) -> [a] -> [b]
map FloatInBinds -> FVAnn
floatedBindsFVs [FloatInBinds]
rhss_binds) FVAnn -> FVAnn -> FVAnn
`unionDVarSet`
FVAnn
rule_fvs
fi_bind :: [FloatInBinds]
-> [(Id, CoreExprWithFVs)]
-> [(Id, CoreExpr)]
fi_bind :: [FloatInBinds]
-> [(CoreBndr, CoreExprWithFVs)] -> [(CoreBndr, Expr CoreBndr)]
fi_bind [FloatInBinds]
to_drops [(CoreBndr, CoreExprWithFVs)]
pairs
= [ (CoreBndr
binder, Platform
-> FloatInBinds -> CoreBndr -> CoreExprWithFVs -> Expr CoreBndr
fiRhs Platform
platform FloatInBinds
to_drop CoreBndr
binder CoreExprWithFVs
rhs)
| ((CoreBndr
binder, CoreExprWithFVs
rhs), FloatInBinds
to_drop) <- forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"fi_bind" [(CoreBndr, CoreExprWithFVs)]
pairs [FloatInBinds]
to_drops ]
fiRhs :: Platform -> FloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr
fiRhs :: Platform
-> FloatInBinds -> CoreBndr -> CoreExprWithFVs -> Expr CoreBndr
fiRhs Platform
platform FloatInBinds
to_drop CoreBndr
bndr CoreExprWithFVs
rhs
| Just Int
join_arity <- CoreBndr -> Maybe Int
isJoinId_maybe CoreBndr
bndr
, let ([CoreBndr]
bndrs, CoreExprWithFVs
body) = forall bndr annot.
Int -> AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
collectNAnnBndrs Int
join_arity CoreExprWithFVs
rhs
= forall b. [b] -> Expr b -> Expr b
mkLams [CoreBndr]
bndrs (Platform -> FloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
fiExpr Platform
platform FloatInBinds
to_drop CoreExprWithFVs
body)
| Bool
otherwise
= Platform -> FloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
fiExpr Platform
platform FloatInBinds
to_drop CoreExprWithFVs
rhs
noFloatIntoLam :: [Var] -> Bool
noFloatIntoLam :: [CoreBndr] -> Bool
noFloatIntoLam [CoreBndr]
bndrs = 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 FVAnn -> Bool
noFloatIntoRhs RecFlag
is_rec CoreBndr
bndr AnnExpr' CoreBndr FVAnn
rhs
| CoreBndr -> Bool
isJoinId CoreBndr
bndr
= RecFlag -> Bool
isRec RecFlag
is_rec
| Bool
otherwise
= AnnExpr' CoreBndr FVAnn -> Type -> Bool
noFloatIntoArg AnnExpr' CoreBndr FVAnn
rhs (CoreBndr -> Type
idType CoreBndr
bndr)
noFloatIntoArg :: CoreExprWithFVs' -> Type -> Bool
noFloatIntoArg :: AnnExpr' CoreBndr FVAnn -> Type -> Bool
noFloatIntoArg AnnExpr' CoreBndr FVAnn
expr Type
expr_ty
| HasDebugCallStack => Type -> Bool
isUnliftedType Type
expr_ty
= Bool
True
| AnnLam CoreBndr
bndr CoreExprWithFVs
e <- AnnExpr' CoreBndr FVAnn
expr
, ([CoreBndr]
bndrs, CoreExprWithFVs
_) <- forall bndr annot.
AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
collectAnnBndrs CoreExprWithFVs
e
= [CoreBndr] -> Bool
noFloatIntoLam (CoreBndr
bndrforall a. a -> [a] -> [a]
:[CoreBndr]
bndrs)
Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all CoreBndr -> Bool
isTyVar (CoreBndr
bndrforall 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 = forall bndr annot. AnnExpr' bndr annot -> Expr bndr
deAnnotate' AnnExpr' CoreBndr FVAnn
expr
sepBindsByDropPoint
:: Platform
-> Bool
-> [FreeVarSet]
-> FloatInBinds
-> [FloatInBinds]
type DropBox = (FreeVarSet, FloatInBinds)
sepBindsByDropPoint :: Platform -> Bool -> [FVAnn] -> FloatInBinds -> [FloatInBinds]
sepBindsByDropPoint Platform
platform Bool
is_case [FVAnn]
drop_pts FloatInBinds
floaters
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null FloatInBinds
floaters
= [] forall a. a -> [a] -> [a]
: [[] | FVAnn
_ <- [FVAnn]
drop_pts]
| Bool
otherwise
= ASSERT( drop_pts `lengthAtLeast` 2 )
FloatInBinds -> [DropBox] -> [FloatInBinds]
go FloatInBinds
floaters (forall a b. (a -> b) -> [a] -> [b]
map (\FVAnn
fvs -> (FVAnn
fvs, [])) (FVAnn
emptyDVarSet forall a. a -> [a] -> [a]
: [FVAnn]
drop_pts))
where
n_alts :: Int
n_alts = forall (t :: * -> *) a. Foldable t => t a -> Int
length [FVAnn]
drop_pts
go :: FloatInBinds -> [DropBox] -> [FloatInBinds]
go :: FloatInBinds -> [DropBox] -> [FloatInBinds]
go [] [DropBox]
drop_boxes = forall a b. (a -> b) -> [a] -> [b]
map (forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [DropBox]
drop_boxes
go (bind_w_fvs :: FloatInBind
bind_w_fvs@(FB FVAnn
bndrs FVAnn
bind_fvs FloatBind
bind) : FloatInBinds
binds) drop_boxes :: [DropBox]
drop_boxes@(DropBox
here_box : [DropBox]
fork_boxes)
= FloatInBinds -> [DropBox] -> [FloatInBinds]
go FloatInBinds
binds [DropBox]
new_boxes
where
(Bool
used_here : [Bool]
used_in_flags) = [ FVAnn
fvs FVAnn -> FVAnn -> Bool
`intersectsDVarSet` FVAnn
bndrs
| (FVAnn
fvs, FloatInBinds
_) <- [DropBox]
drop_boxes]
drop_here :: Bool
drop_here = Bool
used_here Bool -> Bool -> Bool
|| Bool
cant_push
n_used_alts :: Int
n_used_alts = forall a. (a -> Bool) -> [a] -> Int
count forall a. a -> a
id [Bool]
used_in_flags
cant_push :: Bool
cant_push
| Bool
is_case = Int
n_used_alts forall a. Eq a => a -> a -> Bool
== Int
n_alts
Bool -> Bool -> Bool
|| (Int
n_used_alts 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 forall a. Ord a => a -> a -> Bool
> Int
1
new_boxes :: [DropBox]
new_boxes | Bool
drop_here = (DropBox -> DropBox
insert DropBox
here_box forall a. a -> [a] -> [a]
: [DropBox]
fork_boxes)
| Bool
otherwise = (DropBox
here_box forall a. a -> [a] -> [a]
: [DropBox]
new_fork_boxes)
new_fork_boxes :: [DropBox]
new_fork_boxes = forall a b c. 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 (FVAnn
fvs,FloatInBinds
drops) = (FVAnn
fvs FVAnn -> FVAnn -> FVAnn
`unionDVarSet` FVAnn
bind_fvs, FloatInBind
bind_w_fvsforall a. a -> [a] -> [a]
:FloatInBinds
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
go FloatInBinds
_ [DropBox]
_ = forall a. String -> a
panic String
"sepBindsByDropPoint/go"
floatedBindsFVs :: FloatInBinds -> FreeVarSet
floatedBindsFVs :: FloatInBinds -> FVAnn
floatedBindsFVs FloatInBinds
binds = forall a. (a -> FVAnn) -> [a] -> FVAnn
mapUnionDVarSet FloatInBind -> FVAnn
fbFVs FloatInBinds
binds
fbFVs :: FloatInBind -> DVarSet
fbFVs :: FloatInBind -> FVAnn
fbFVs (FB FVAnn
_ FVAnn
fvs FloatBind
_) = FVAnn
fvs
wrapFloats :: FloatInBinds -> CoreExpr -> CoreExpr
wrapFloats :: FloatInBinds -> Expr CoreBndr -> Expr CoreBndr
wrapFloats [] Expr CoreBndr
e = Expr CoreBndr
e
wrapFloats (FB FVAnn
_ FVAnn
_ FloatBind
fl : FloatInBinds
bs) Expr CoreBndr
e = FloatInBinds -> Expr CoreBndr -> Expr CoreBndr
wrapFloats FloatInBinds
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)) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Platform -> Expr CoreBndr -> Bool
exprIsDupable Platform
platform forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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