{-# LANGUAGE PatternSynonyms #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Core.Opt.SetLevels (
setLevels,
Level(..), tOP_LEVEL,
LevelledBind, LevelledExpr, LevelledBndr,
FloatSpec(..), floatSpecLevel,
incMinorLvl, ltMajLvl, ltLvl, isTopLvl
) where
import GHC.Prelude
import GHC.Core
import GHC.Core.Opt.Monad ( FloatOutSwitches(..) )
import GHC.Core.Utils
import GHC.Core.Opt.Arity ( exprBotStrictness_maybe, isOneShotBndr )
import GHC.Core.FVs
import GHC.Core.Subst
import GHC.Core.Make ( sortQuantVars )
import GHC.Core.Type ( Type, tyCoVarsOfType
, mightBeUnliftedType, closeOverKindsDSet
, typeHasFixedRuntimeRep
)
import GHC.Core.Multiplicity ( pattern ManyTy )
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Var
import GHC.Types.Var.Set
import GHC.Types.Unique.Set ( nonDetStrictFoldUniqSet )
import GHC.Types.Unique.DSet ( getUniqDSet )
import GHC.Types.Var.Env
import GHC.Types.Literal ( litIsTrivial )
import GHC.Types.Demand ( DmdSig, prependArgsDmdSig )
import GHC.Types.Cpr ( CprSig, prependArgsCprSig )
import GHC.Types.Name ( getOccName, mkSystemVarName )
import GHC.Types.Name.Occurrence ( occNameFS )
import GHC.Types.Unique ( hasKey )
import GHC.Types.Tickish ( tickishIsCode )
import GHC.Types.Unique.Supply
import GHC.Types.Unique.DFM
import GHC.Types.Basic ( Arity, RecFlag(..), isRec )
import GHC.Builtin.Types
import GHC.Builtin.Names ( runRWKey )
import GHC.Data.FastString
import GHC.Utils.FV
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import Data.Maybe
type LevelledExpr = TaggedExpr FloatSpec
type LevelledBind = TaggedBind FloatSpec
type LevelledBndr = TaggedBndr FloatSpec
data Level = Level Int
Int
data FloatSpec
= FloatMe Level
| StayPut Level
floatSpecLevel :: FloatSpec -> Level
floatSpecLevel :: FloatSpec -> Level
floatSpecLevel (FloatMe Level
l) = Level
l
floatSpecLevel (StayPut Level
l) = Level
l
instance Outputable FloatSpec where
ppr :: FloatSpec -> SDoc
ppr (FloatMe Level
l) = Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'F' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Level -> SDoc
forall a. Outputable a => a -> SDoc
ppr Level
l
ppr (StayPut Level
l) = Level -> SDoc
forall a. Outputable a => a -> SDoc
ppr Level
l
tOP_LEVEL :: Level
tOP_LEVEL :: Level
tOP_LEVEL = Int -> Int -> Level
Level Int
0 Int
0
incMajorLvl :: Level -> Level
incMajorLvl :: Level -> Level
incMajorLvl (Level Int
major Int
_) = Int -> Int -> Level
Level (Int
major Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
0
incMinorLvl :: Level -> Level
incMinorLvl :: Level -> Level
incMinorLvl (Level Int
major Int
minor) = Int -> Int -> Level
Level Int
major (Int
minorInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
maxLvl :: Level -> Level -> Level
maxLvl :: Level -> Level -> Level
maxLvl l1 :: Level
l1@(Level Int
maj1 Int
min1) l2 :: Level
l2@(Level Int
maj2 Int
min2)
| (Int
maj1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maj2) Bool -> Bool -> Bool
|| (Int
maj1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
maj2 Bool -> Bool -> Bool
&& Int
min1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
min2) = Level
l1
| Bool
otherwise = Level
l2
ltLvl :: Level -> Level -> Bool
ltLvl :: Level -> Level -> Bool
ltLvl (Level Int
maj1 Int
min1) (Level Int
maj2 Int
min2)
= (Int
maj1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
maj2) Bool -> Bool -> Bool
|| (Int
maj1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
maj2 Bool -> Bool -> Bool
&& Int
min1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
min2)
ltMajLvl :: Level -> Level -> Bool
ltMajLvl :: Level -> Level -> Bool
ltMajLvl (Level Int
maj1 Int
_) (Level Int
maj2 Int
_) = Int
maj1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
maj2
isTopLvl :: Level -> Bool
isTopLvl :: Level -> Bool
isTopLvl (Level Int
0 Int
0) = Bool
True
isTopLvl Level
_ = Bool
False
instance Outputable Level where
ppr :: Level -> SDoc
ppr (Level Int
maj Int
min)
= [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat [ Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'<', Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
maj, Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
',', Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
min, Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'>' ]
instance Eq Level where
(Level Int
maj1 Int
min1) == :: Level -> Level -> Bool
== (Level Int
maj2 Int
min2) = Int
maj1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
maj2 Bool -> Bool -> Bool
&& Int
min1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
min2
setLevels :: FloatOutSwitches
-> CoreProgram
-> UniqSupply
-> [LevelledBind]
setLevels :: FloatOutSwitches -> CoreProgram -> UniqSupply -> [LevelledBind]
setLevels FloatOutSwitches
float_lams CoreProgram
binds UniqSupply
us
= UniqSupply -> UniqSM [LevelledBind] -> [LevelledBind]
forall a. UniqSupply -> UniqSM a -> a
initLvl UniqSupply
us (CoreProgram -> UniqSM [LevelledBind]
do_them CoreProgram
binds)
where
env :: LevelEnv
env = FloatOutSwitches -> CoreProgram -> LevelEnv
initialEnv FloatOutSwitches
float_lams CoreProgram
binds
do_them :: [CoreBind] -> LvlM [LevelledBind]
do_them :: CoreProgram -> UniqSM [LevelledBind]
do_them [] = [LevelledBind] -> UniqSM [LevelledBind]
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return []
do_them (CoreBind
b:CoreProgram
bs)
= do { lvld_bind <- LevelEnv -> CoreBind -> LvlM LevelledBind
lvlTopBind LevelEnv
env CoreBind
b
; lvld_binds <- do_them bs
; return (lvld_bind : lvld_binds) }
lvlTopBind :: LevelEnv -> Bind Id -> LvlM LevelledBind
lvlTopBind :: LevelEnv -> CoreBind -> LvlM LevelledBind
lvlTopBind LevelEnv
env (NonRec Id
bndr Expr Id
rhs)
= do { (bndr', rhs') <- LevelEnv
-> RecFlag -> Id -> Expr Id -> LvlM (LevelledBndr, LevelledExpr)
lvl_top LevelEnv
env RecFlag
NonRecursive Id
bndr Expr Id
rhs
; return (NonRec bndr' rhs') }
lvlTopBind LevelEnv
env (Rec [(Id, Expr Id)]
pairs)
= do { prs' <- ((Id, Expr Id) -> LvlM (LevelledBndr, LevelledExpr))
-> [(Id, Expr Id)] -> UniqSM [(LevelledBndr, LevelledExpr)]
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 (\(Id
b,Expr Id
r) -> LevelEnv
-> RecFlag -> Id -> Expr Id -> LvlM (LevelledBndr, LevelledExpr)
lvl_top LevelEnv
env RecFlag
Recursive Id
b Expr Id
r) [(Id, Expr Id)]
pairs
; return (Rec prs') }
lvl_top :: LevelEnv -> RecFlag -> Id -> CoreExpr
-> LvlM (LevelledBndr, LevelledExpr)
lvl_top :: LevelEnv
-> RecFlag -> Id -> Expr Id -> LvlM (LevelledBndr, LevelledExpr)
lvl_top LevelEnv
env RecFlag
is_rec Id
bndr Expr Id
rhs
= do { rhs' <- LevelEnv
-> RecFlag
-> Bool
-> JoinPointHood
-> CoreExprWithFVs
-> LvlM LevelledExpr
lvlRhs LevelEnv
env RecFlag
is_rec (Id -> Bool
isDeadEndId Id
bndr)
JoinPointHood
NotJoinPoint
(Expr Id -> CoreExprWithFVs
freeVars Expr Id
rhs)
; return (stayPut tOP_LEVEL bndr, rhs') }
lvlExpr :: LevelEnv
-> CoreExprWithFVs
-> LvlM LevelledExpr
lvlExpr :: LevelEnv -> CoreExprWithFVs -> LvlM LevelledExpr
lvlExpr LevelEnv
env (FVAnn
_, AnnType Type
ty) = LevelledExpr -> LvlM LevelledExpr
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> LevelledExpr
forall b. Type -> Expr b
Type (Subst -> Type -> Type
substTyUnchecked (LevelEnv -> Subst
le_subst LevelEnv
env) Type
ty))
lvlExpr LevelEnv
env (FVAnn
_, AnnCoercion Coercion
co) = LevelledExpr -> LvlM LevelledExpr
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Coercion -> LevelledExpr
forall b. Coercion -> Expr b
Coercion (HasDebugCallStack => Subst -> Coercion -> Coercion
Subst -> Coercion -> Coercion
substCo (LevelEnv -> Subst
le_subst LevelEnv
env) Coercion
co))
lvlExpr LevelEnv
env (FVAnn
_, AnnVar Id
v) = LevelledExpr -> LvlM LevelledExpr
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LevelEnv -> Id -> LevelledExpr
lookupVar LevelEnv
env Id
v)
lvlExpr LevelEnv
_ (FVAnn
_, AnnLit Literal
lit) = LevelledExpr -> LvlM LevelledExpr
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> LevelledExpr
forall b. Literal -> Expr b
Lit Literal
lit)
lvlExpr LevelEnv
env (FVAnn
_, AnnCast CoreExprWithFVs
expr (FVAnn
_, Coercion
co)) = do
expr' <- LevelEnv -> CoreExprWithFVs -> LvlM LevelledExpr
lvlNonTailExpr LevelEnv
env CoreExprWithFVs
expr
return (Cast expr' (substCo (le_subst env) co))
lvlExpr LevelEnv
env (FVAnn
_, AnnTick CoreTickish
tickish CoreExprWithFVs
expr) = do
expr' <- LevelEnv -> CoreExprWithFVs -> LvlM LevelledExpr
lvlNonTailExpr LevelEnv
env CoreExprWithFVs
expr
let tickish' = Subst -> CoreTickish -> CoreTickish
substTickish (LevelEnv -> Subst
le_subst LevelEnv
env) CoreTickish
tickish
return (Tick tickish' expr')
lvlExpr LevelEnv
env expr :: CoreExprWithFVs
expr@(FVAnn
_, AnnApp CoreExprWithFVs
_ CoreExprWithFVs
_) = LevelEnv
-> CoreExprWithFVs
-> (CoreExprWithFVs, [CoreExprWithFVs])
-> LvlM LevelledExpr
lvlApp LevelEnv
env CoreExprWithFVs
expr (CoreExprWithFVs -> (CoreExprWithFVs, [CoreExprWithFVs])
forall b a. AnnExpr b a -> (AnnExpr b a, [AnnExpr b a])
collectAnnArgs CoreExprWithFVs
expr)
lvlExpr LevelEnv
env expr :: CoreExprWithFVs
expr@(FVAnn
_, AnnLam {})
= do { new_body <- LevelEnv -> Bool -> CoreExprWithFVs -> LvlM LevelledExpr
lvlNonTailMFE LevelEnv
new_env Bool
True CoreExprWithFVs
body
; return (mkLams new_bndrs new_body) }
where
([Id]
bndrs, CoreExprWithFVs
body) = CoreExprWithFVs -> ([Id], CoreExprWithFVs)
forall bndr annot.
AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
collectAnnBndrs CoreExprWithFVs
expr
(LevelEnv
env1, [Id]
bndrs1) = RecFlag -> LevelEnv -> [Id] -> (LevelEnv, [Id])
substBndrsSL RecFlag
NonRecursive LevelEnv
env [Id]
bndrs
(LevelEnv
new_env, [LevelledBndr]
new_bndrs) = LevelEnv -> Level -> [Id] -> (LevelEnv, [LevelledBndr])
lvlLamBndrs LevelEnv
env1 (LevelEnv -> Level
le_ctxt_lvl LevelEnv
env) [Id]
bndrs1
lvlExpr LevelEnv
env (FVAnn
_, AnnLet AnnBind Id FVAnn
bind CoreExprWithFVs
body)
= do { (bind', new_env) <- LevelEnv -> AnnBind Id FVAnn -> LvlM (LevelledBind, LevelEnv)
lvlBind LevelEnv
env AnnBind Id FVAnn
bind
; body' <- lvlExpr new_env body
; return (Let bind' body') }
lvlExpr LevelEnv
env (FVAnn
_, AnnCase CoreExprWithFVs
scrut Id
case_bndr Type
ty [AnnAlt Id FVAnn]
alts)
= do { scrut' <- LevelEnv -> Bool -> CoreExprWithFVs -> LvlM LevelledExpr
lvlNonTailMFE LevelEnv
env Bool
True CoreExprWithFVs
scrut
; lvlCase env (freeVarsOf scrut) scrut' case_bndr ty alts }
lvlNonTailExpr :: LevelEnv
-> CoreExprWithFVs
-> LvlM LevelledExpr
lvlNonTailExpr :: LevelEnv -> CoreExprWithFVs -> LvlM LevelledExpr
lvlNonTailExpr LevelEnv
env CoreExprWithFVs
expr
= LevelEnv -> CoreExprWithFVs -> LvlM LevelledExpr
lvlExpr LevelEnv
env CoreExprWithFVs
expr
lvlApp :: LevelEnv
-> CoreExprWithFVs
-> (CoreExprWithFVs, [CoreExprWithFVs])
-> LvlM LevelledExpr
lvlApp :: LevelEnv
-> CoreExprWithFVs
-> (CoreExprWithFVs, [CoreExprWithFVs])
-> LvlM LevelledExpr
lvlApp LevelEnv
env CoreExprWithFVs
orig_expr ((FVAnn
_,AnnVar Id
fn), [CoreExprWithFVs]
args)
| Id
fn Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
runRWKey
= do { args' <- (CoreExprWithFVs -> LvlM LevelledExpr)
-> [CoreExprWithFVs] -> UniqSM [LevelledExpr]
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 (LevelEnv -> CoreExprWithFVs -> LvlM LevelledExpr
lvlExpr LevelEnv
env) [CoreExprWithFVs]
args
; return (foldl' App (lookupVar env fn) args') }
| LevelEnv -> Bool
floatOverSat LevelEnv
env
, Int
arity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
, Int
arity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n_val_args
, Maybe Class
Nothing <- Id -> Maybe Class
isClassOpId_maybe Id
fn
= do { rargs' <- (CoreExprWithFVs -> LvlM LevelledExpr)
-> [CoreExprWithFVs] -> UniqSM [LevelledExpr]
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 (LevelEnv -> Bool -> CoreExprWithFVs -> LvlM LevelledExpr
lvlNonTailMFE LevelEnv
env Bool
False) [CoreExprWithFVs]
rargs
; lapp' <- lvlNonTailMFE env False lapp
; return (foldl' App lapp' rargs') }
| Bool
otherwise
= do { args' <- (CoreExprWithFVs -> LvlM LevelledExpr)
-> [CoreExprWithFVs] -> UniqSM [LevelledExpr]
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 (LevelEnv -> Bool -> CoreExprWithFVs -> LvlM LevelledExpr
lvlMFE LevelEnv
env Bool
False) [CoreExprWithFVs]
args
; return (foldl' App (lookupVar env fn) args') }
where
n_val_args :: Int
n_val_args = (CoreExprWithFVs -> Bool) -> [CoreExprWithFVs] -> Int
forall a. (a -> Bool) -> [a] -> Int
count (Expr Id -> Bool
forall b. Expr b -> Bool
isValArg (Expr Id -> Bool)
-> (CoreExprWithFVs -> Expr Id) -> CoreExprWithFVs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExprWithFVs -> Expr Id
forall bndr annot. AnnExpr bndr annot -> Expr bndr
deAnnotate) [CoreExprWithFVs]
args
arity :: Int
arity = Id -> Int
idArity Id
fn
(CoreExprWithFVs
lapp, [CoreExprWithFVs]
rargs) = Int
-> CoreExprWithFVs
-> [CoreExprWithFVs]
-> (CoreExprWithFVs, [CoreExprWithFVs])
forall {t} {b} {annot}.
(Eq t, Num t) =>
t
-> AnnExpr b annot
-> [AnnExpr b annot]
-> (AnnExpr b annot, [AnnExpr b annot])
left (Int
n_val_args Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
arity) CoreExprWithFVs
orig_expr []
left :: t
-> AnnExpr b annot
-> [AnnExpr b annot]
-> (AnnExpr b annot, [AnnExpr b annot])
left t
0 AnnExpr b annot
e [AnnExpr b annot]
rargs = (AnnExpr b annot
e, [AnnExpr b annot]
rargs)
left t
n (annot
_, AnnApp AnnExpr b annot
f AnnExpr b annot
a) [AnnExpr b annot]
rargs
| Expr b -> Bool
forall b. Expr b -> Bool
isValArg (AnnExpr b annot -> Expr b
forall bndr annot. AnnExpr bndr annot -> Expr bndr
deAnnotate AnnExpr b annot
a) = t
-> AnnExpr b annot
-> [AnnExpr b annot]
-> (AnnExpr b annot, [AnnExpr b annot])
left (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1) AnnExpr b annot
f (AnnExpr b annot
aAnnExpr b annot -> [AnnExpr b annot] -> [AnnExpr b annot]
forall a. a -> [a] -> [a]
:[AnnExpr b annot]
rargs)
| Bool
otherwise = t
-> AnnExpr b annot
-> [AnnExpr b annot]
-> (AnnExpr b annot, [AnnExpr b annot])
left t
n AnnExpr b annot
f (AnnExpr b annot
aAnnExpr b annot -> [AnnExpr b annot] -> [AnnExpr b annot]
forall a. a -> [a] -> [a]
:[AnnExpr b annot]
rargs)
left t
_ AnnExpr b annot
_ [AnnExpr b annot]
_ = String -> (AnnExpr b annot, [AnnExpr b annot])
forall a. HasCallStack => String -> a
panic String
"GHC.Core.Opt.SetLevels.lvlExpr.left"
lvlApp LevelEnv
env CoreExprWithFVs
_ (CoreExprWithFVs
fun, [CoreExprWithFVs]
args)
=
do { args' <- (CoreExprWithFVs -> LvlM LevelledExpr)
-> [CoreExprWithFVs] -> UniqSM [LevelledExpr]
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 (LevelEnv -> Bool -> CoreExprWithFVs -> LvlM LevelledExpr
lvlNonTailMFE LevelEnv
env Bool
False) [CoreExprWithFVs]
args
; fun' <- lvlNonTailExpr env fun
; return (foldl' App fun' args') }
lvlCase :: LevelEnv
-> DVarSet
-> LevelledExpr
-> Id -> Type
-> [CoreAltWithFVs]
-> LvlM LevelledExpr
lvlCase :: LevelEnv
-> FVAnn
-> LevelledExpr
-> Id
-> Type
-> [AnnAlt Id FVAnn]
-> LvlM LevelledExpr
lvlCase LevelEnv
env FVAnn
scrut_fvs LevelledExpr
scrut' Id
case_bndr Type
ty [AnnAlt Id FVAnn]
alts
| [AnnAlt con :: AltCon
con@(DataAlt {}) [Id]
bs CoreExprWithFVs
body] <- [AnnAlt Id FVAnn]
alts
, Expr Id -> Bool
exprIsHNF (LevelledExpr -> Expr Id
forall t. TaggedExpr t -> Expr Id
deTagExpr LevelledExpr
scrut')
, Bool -> Bool
not (Level -> Bool
isTopLvl Level
dest_lvl)
, Bool -> Bool
not (LevelEnv -> Bool
floatTopLvlOnly LevelEnv
env)
, Type
ManyTy <- HasDebugCallStack => Id -> Type
Id -> Type
idMult Id
case_bndr
=
do { (env1, (case_bndr' : bs')) <- LevelEnv -> Level -> [Id] -> LvlM (LevelEnv, [Id])
cloneCaseBndrs LevelEnv
env Level
dest_lvl (Id
case_bndr Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: [Id]
bs)
; let rhs_env = LevelEnv -> Id -> LevelledExpr -> LevelEnv
extendCaseBndrEnv LevelEnv
env1 Id
case_bndr LevelledExpr
scrut'
; body' <- lvlMFE rhs_env True body
; let alt' = AltCon -> [LevelledBndr] -> LevelledExpr -> Alt LevelledBndr
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con ((Id -> LevelledBndr) -> [Id] -> [LevelledBndr]
forall a b. (a -> b) -> [a] -> [b]
map (Level -> Id -> LevelledBndr
stayPut Level
dest_lvl) [Id]
bs') LevelledExpr
body'
; return (Case scrut' (TB case_bndr' (FloatMe dest_lvl)) ty' [alt']) }
| Bool
otherwise
= do { let (LevelEnv
alts_env1, [LevelledBndr
case_bndr']) = RecFlag -> LevelEnv -> Level -> [Id] -> (LevelEnv, [LevelledBndr])
substAndLvlBndrs RecFlag
NonRecursive LevelEnv
env Level
incd_lvl [Id
case_bndr]
alts_env :: LevelEnv
alts_env = LevelEnv -> Id -> LevelledExpr -> LevelEnv
extendCaseBndrEnv LevelEnv
alts_env1 Id
case_bndr LevelledExpr
scrut'
; alts' <- (AnnAlt Id FVAnn -> UniqSM (Alt LevelledBndr))
-> [AnnAlt Id FVAnn] -> UniqSM [Alt LevelledBndr]
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 (LevelEnv -> AnnAlt Id FVAnn -> UniqSM (Alt LevelledBndr)
lvl_alt LevelEnv
alts_env) [AnnAlt Id FVAnn]
alts
; return (Case scrut' case_bndr' ty' alts') }
where
ty' :: Type
ty' = Subst -> Type -> Type
substTyUnchecked (LevelEnv -> Subst
le_subst LevelEnv
env) Type
ty
incd_lvl :: Level
incd_lvl = Level -> Level
incMinorLvl (LevelEnv -> Level
le_ctxt_lvl LevelEnv
env)
dest_lvl :: Level
dest_lvl = (Id -> Bool) -> LevelEnv -> FVAnn -> Level
maxFvLevel (Bool -> Id -> Bool
forall a b. a -> b -> a
const Bool
True) LevelEnv
env FVAnn
scrut_fvs
lvl_alt :: LevelEnv -> AnnAlt Id FVAnn -> UniqSM (Alt LevelledBndr)
lvl_alt LevelEnv
alts_env (AnnAlt AltCon
con [Id]
bs CoreExprWithFVs
rhs)
= do { rhs' <- LevelEnv -> Bool -> CoreExprWithFVs -> LvlM LevelledExpr
lvlMFE LevelEnv
new_env Bool
True CoreExprWithFVs
rhs
; return (Alt con bs' rhs') }
where
(LevelEnv
new_env, [LevelledBndr]
bs') = RecFlag -> LevelEnv -> Level -> [Id] -> (LevelEnv, [LevelledBndr])
substAndLvlBndrs RecFlag
NonRecursive LevelEnv
alts_env Level
incd_lvl [Id]
bs
lvlNonTailMFE :: LevelEnv
-> Bool
-> CoreExprWithFVs
-> LvlM LevelledExpr
lvlNonTailMFE :: LevelEnv -> Bool -> CoreExprWithFVs -> LvlM LevelledExpr
lvlNonTailMFE LevelEnv
env Bool
strict_ctxt CoreExprWithFVs
ann_expr
= LevelEnv -> Bool -> CoreExprWithFVs -> LvlM LevelledExpr
lvlMFE LevelEnv
env Bool
strict_ctxt CoreExprWithFVs
ann_expr
lvlMFE :: LevelEnv
-> Bool
-> CoreExprWithFVs
-> LvlM LevelledExpr
lvlMFE :: LevelEnv -> Bool -> CoreExprWithFVs -> LvlM LevelledExpr
lvlMFE LevelEnv
env Bool
_ (FVAnn
_, AnnType Type
ty)
= LevelledExpr -> LvlM LevelledExpr
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> LevelledExpr
forall b. Type -> Expr b
Type (Subst -> Type -> Type
substTyUnchecked (LevelEnv -> Subst
le_subst LevelEnv
env) Type
ty))
lvlMFE LevelEnv
env Bool
strict_ctxt (FVAnn
_, AnnTick CoreTickish
t CoreExprWithFVs
e)
= do { e' <- LevelEnv -> Bool -> CoreExprWithFVs -> LvlM LevelledExpr
lvlMFE LevelEnv
env Bool
strict_ctxt CoreExprWithFVs
e
; let t' = Subst -> CoreTickish -> CoreTickish
substTickish (LevelEnv -> Subst
le_subst LevelEnv
env) CoreTickish
t
; return (Tick t' e') }
lvlMFE LevelEnv
env Bool
strict_ctxt (FVAnn
_, AnnCast CoreExprWithFVs
e (FVAnn
_, Coercion
co))
= do { e' <- LevelEnv -> Bool -> CoreExprWithFVs -> LvlM LevelledExpr
lvlMFE LevelEnv
env Bool
strict_ctxt CoreExprWithFVs
e
; return (Cast e' (substCo (le_subst env) co)) }
lvlMFE LevelEnv
env Bool
strict_ctxt e :: CoreExprWithFVs
e@(FVAnn
_, AnnCase {})
| Bool
strict_ctxt
= LevelEnv -> CoreExprWithFVs -> LvlM LevelledExpr
lvlExpr LevelEnv
env CoreExprWithFVs
e
lvlMFE LevelEnv
env Bool
strict_ctxt CoreExprWithFVs
ann_expr
| Bool -> Bool
not Bool
float_me
Bool -> Bool -> Bool
|| LevelEnv -> Bool
floatTopLvlOnly LevelEnv
env Bool -> Bool -> Bool
&& Bool -> Bool
not (Level -> Bool
isTopLvl Level
dest_lvl)
Bool -> Bool -> Bool
|| LevelEnv -> FVAnn -> Bool
hasFreeJoin LevelEnv
env FVAnn
fvs
Bool -> Bool -> Bool
|| Bool -> Bool
not (HasDebugCallStack => Type -> Bool
Type -> Bool
typeHasFixedRuntimeRep (HasDebugCallStack => Expr Id -> Type
Expr Id -> Type
exprType Expr Id
expr))
Bool -> Bool -> Bool
|| Expr Id -> [Id] -> Bool
notWorthFloating Expr Id
expr [Id]
abs_vars
=
LevelEnv -> CoreExprWithFVs -> LvlM LevelledExpr
lvlExpr LevelEnv
env CoreExprWithFVs
ann_expr
| Bool
float_is_new_lam Bool -> Bool -> Bool
|| Expr Id -> Type -> Bool
exprIsTopLevelBindable Expr Id
expr Type
expr_ty
= do { expr1 <- [Id]
-> Level
-> LevelEnv
-> RecFlag
-> Bool
-> JoinPointHood
-> CoreExprWithFVs
-> LvlM LevelledExpr
lvlFloatRhs [Id]
abs_vars Level
dest_lvl LevelEnv
rhs_env RecFlag
NonRecursive
Bool
is_bot_lam JoinPointHood
NotJoinPoint CoreExprWithFVs
ann_expr
; var <- newLvlVar expr1 NotJoinPoint is_mk_static
; let var2 = Id -> Int -> Maybe (Int, DmdSig, CprSig) -> Id
annotateBotStr Id
var Int
float_n_lams Maybe (Int, DmdSig, CprSig)
mb_bot_str
; return (Let (NonRec (TB var2 (FloatMe dest_lvl)) expr1)
(mkVarApps (Var var2) abs_vars)) }
| Bool
escapes_value_lam
, Bool -> Bool
not Bool
expr_ok_for_spec
, BI_Box { bi_data_con :: forall b. BoxingInfo b -> DataCon
bi_data_con = DataCon
box_dc, bi_inst_con :: forall b. BoxingInfo b -> Expr b
bi_inst_con = LevelledExpr
boxing_expr
, bi_boxed_type :: forall b. BoxingInfo b -> Type
bi_boxed_type = Type
box_ty } <- Type -> BoxingInfo LevelledBndr
forall b. Type -> BoxingInfo b
boxingDataCon Type
expr_ty
, let [Id
bx_bndr, Id
ubx_bndr] = [Type] -> [Id]
mkTemplateLocals [Type
box_ty, Type
expr_ty]
= do { expr1 <- LevelEnv -> CoreExprWithFVs -> LvlM LevelledExpr
lvlExpr LevelEnv
rhs_env CoreExprWithFVs
ann_expr
; let l1r = LevelEnv -> Level
incMinorLvlFrom LevelEnv
rhs_env
float_rhs = [LevelledBndr] -> LevelledExpr -> LevelledExpr
forall b. [b] -> Expr b -> Expr b
mkLams [LevelledBndr]
abs_vars_w_lvls (LevelledExpr -> LevelledExpr) -> LevelledExpr -> LevelledExpr
forall a b. (a -> b) -> a -> b
$
LevelledExpr
-> LevelledBndr -> Type -> [Alt LevelledBndr] -> LevelledExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case LevelledExpr
expr1 (Level -> Id -> LevelledBndr
stayPut Level
l1r Id
ubx_bndr) Type
box_ty
[AltCon -> [LevelledBndr] -> LevelledExpr -> Alt LevelledBndr
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] (LevelledExpr -> LevelledExpr -> LevelledExpr
forall b. Expr b -> Expr b -> Expr b
App LevelledExpr
boxing_expr (Id -> LevelledExpr
forall b. Id -> Expr b
Var Id
ubx_bndr))]
; var <- newLvlVar float_rhs NotJoinPoint is_mk_static
; let l1u = LevelEnv -> Level
incMinorLvlFrom LevelEnv
env
use_expr = LevelledExpr
-> LevelledBndr -> Type -> [Alt LevelledBndr] -> LevelledExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (LevelledExpr -> [Id] -> LevelledExpr
forall b. Expr b -> [Id] -> Expr b
mkVarApps (Id -> LevelledExpr
forall b. Id -> Expr b
Var Id
var) [Id]
abs_vars)
(Level -> Id -> LevelledBndr
stayPut Level
l1u Id
bx_bndr) Type
expr_ty
[AltCon -> [LevelledBndr] -> LevelledExpr -> Alt LevelledBndr
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
box_dc) [Level -> Id -> LevelledBndr
stayPut Level
l1u Id
ubx_bndr] (Id -> LevelledExpr
forall b. Id -> Expr b
Var Id
ubx_bndr)]
; return (Let (NonRec (TB var (FloatMe dest_lvl)) float_rhs)
use_expr) }
| Bool
otherwise
= LevelEnv -> CoreExprWithFVs -> LvlM LevelledExpr
lvlExpr LevelEnv
env CoreExprWithFVs
ann_expr
where
expr :: Expr Id
expr = CoreExprWithFVs -> Expr Id
forall bndr annot. AnnExpr bndr annot -> Expr bndr
deAnnotate CoreExprWithFVs
ann_expr
expr_ty :: Type
expr_ty = HasDebugCallStack => Expr Id -> Type
Expr Id -> Type
exprType Expr Id
expr
fvs :: FVAnn
fvs = CoreExprWithFVs -> FVAnn
freeVarsOf CoreExprWithFVs
ann_expr
fvs_ty :: TyCoVarSet
fvs_ty = Type -> TyCoVarSet
tyCoVarsOfType Type
expr_ty
is_bot_lam :: Bool
is_bot_lam = Maybe (Int, DmdSig, CprSig) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Int, DmdSig, CprSig)
mb_bot_str
is_function :: Bool
is_function = CoreExprWithFVs -> Bool
isFunction CoreExprWithFVs
ann_expr
mb_bot_str :: Maybe (Int, DmdSig, CprSig)
mb_bot_str = Expr Id -> Maybe (Int, DmdSig, CprSig)
exprBotStrictness_maybe Expr Id
expr
expr_ok_for_spec :: Bool
expr_ok_for_spec = Expr Id -> Bool
exprOkForSpeculation Expr Id
expr
abs_vars :: [Id]
abs_vars = Level -> LevelEnv -> FVAnn -> [Id]
abstractVars Level
dest_lvl LevelEnv
env FVAnn
fvs
dest_lvl :: Level
dest_lvl = LevelEnv -> FVAnn -> TyCoVarSet -> Bool -> Bool -> Level
destLevel LevelEnv
env FVAnn
fvs TyCoVarSet
fvs_ty Bool
is_function Bool
is_bot_lam
float_is_new_lam :: Bool
float_is_new_lam = Int
float_n_lams Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
float_n_lams :: Int
float_n_lams = (Id -> Bool) -> [Id] -> Int
forall a. (a -> Bool) -> [a] -> Int
count Id -> Bool
isId [Id]
abs_vars
(LevelEnv
rhs_env, [LevelledBndr]
abs_vars_w_lvls) = LevelEnv -> Level -> [Id] -> (LevelEnv, [LevelledBndr])
lvlLamBndrs LevelEnv
env Level
dest_lvl [Id]
abs_vars
is_mk_static :: Bool
is_mk_static = Maybe (Expr Id, Type, Expr Id, Expr Id) -> Bool
forall a. Maybe a -> Bool
isJust (Expr Id -> Maybe (Expr Id, Type, Expr Id, Expr Id)
collectMakeStaticArgs Expr Id
expr)
float_me :: Bool
float_me = Bool
saves_work Bool -> Bool -> Bool
|| Bool
saves_alloc Bool -> Bool -> Bool
|| Bool
is_mk_static
saves_work :: Bool
saves_work = Bool
escapes_value_lam
Bool -> Bool -> Bool
&& Bool -> Bool
not (Expr Id -> Bool
exprIsHNF Expr Id
expr)
Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
float_is_new_lam
escapes_value_lam :: Bool
escapes_value_lam = Level
dest_lvl Level -> Level -> Bool
`ltMajLvl` (LevelEnv -> Level
le_ctxt_lvl LevelEnv
env)
saves_alloc :: Bool
saves_alloc = Level -> Bool
isTopLvl Level
dest_lvl
Bool -> Bool -> Bool
&& LevelEnv -> Bool
floatConsts LevelEnv
env
Bool -> Bool -> Bool
&& ( Bool -> Bool
not Bool
strict_ctxt
Bool -> Bool -> Bool
|| Expr Id -> Bool
exprIsHNF Expr Id
expr
Bool -> Bool -> Bool
|| (Bool
is_bot_lam Bool -> Bool -> Bool
&& Bool
escapes_value_lam))
hasFreeJoin :: LevelEnv -> DVarSet -> Bool
hasFreeJoin :: LevelEnv -> FVAnn -> Bool
hasFreeJoin LevelEnv
env FVAnn
fvs
= Bool -> Bool
not ((Id -> Bool) -> LevelEnv -> FVAnn -> Level
maxFvLevel Id -> Bool
isJoinId LevelEnv
env FVAnn
fvs Level -> Level -> Bool
forall a. Eq a => a -> a -> Bool
== Level
tOP_LEVEL)
annotateBotStr :: Id -> Arity -> Maybe (Arity, DmdSig, CprSig) -> Id
annotateBotStr :: Id -> Int -> Maybe (Int, DmdSig, CprSig) -> Id
annotateBotStr Id
id Int
n_extra Maybe (Int, DmdSig, CprSig)
mb_bot_str
| Just (Int
arity, DmdSig
str_sig, CprSig
cpr_sig) <- Maybe (Int, DmdSig, CprSig)
mb_bot_str
= Id
id Id -> Int -> Id
`setIdArity` (Int
arity Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n_extra)
Id -> DmdSig -> Id
`setIdDmdSig` Int -> DmdSig -> DmdSig
prependArgsDmdSig Int
n_extra DmdSig
str_sig
Id -> CprSig -> Id
`setIdCprSig` Int -> CprSig -> CprSig
prependArgsCprSig Int
n_extra CprSig
cpr_sig
| Bool
otherwise
= Id
id
notWorthFloating :: CoreExpr -> [Var] -> Bool
notWorthFloating :: Expr Id -> [Id] -> Bool
notWorthFloating Expr Id
e [Id]
abs_vars
= Expr Id -> Int -> Bool
forall {a}. (Ord a, Num a) => Expr Id -> a -> Bool
go Expr Id
e ((Id -> Bool) -> [Id] -> Int
forall a. (a -> Bool) -> [a] -> Int
count Id -> Bool
isId [Id]
abs_vars)
where
go :: Expr Id -> a -> Bool
go (Var {}) a
n = a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
0
go (Lit Literal
lit) a
n = Bool -> Bool -> Bool
forall a. HasCallStack => Bool -> a -> a
assert (a
na -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
0) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
Literal -> Bool
litIsTrivial Literal
lit
go (Type {}) a
_ = Bool
True
go (Coercion {}) a
_ = Bool
True
go (App Expr Id
e Expr Id
arg) a
n
| Bool -> Bool
not (Expr Id -> Bool
isRuntimeArg Expr Id
arg) = Expr Id -> a -> Bool
go Expr Id
e a
n
| a
na -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
0 = Bool
False
| Expr Id -> Bool
exprIsTrivial Expr Id
arg = Expr Id -> a -> Bool
go Expr Id
e (a
na -> a -> a
forall a. Num a => a -> a -> a
-a
1)
| Bool
otherwise = Bool
False
go (Tick CoreTickish
t Expr Id
e) a
n = Bool -> Bool
not (CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode CoreTickish
t) Bool -> Bool -> Bool
&& Expr Id -> a -> Bool
go Expr Id
e a
n
go (Cast Expr Id
e Coercion
_) a
n = Expr Id -> a -> Bool
go Expr Id
e a
n
go (Case Expr Id
e Id
b Type
_ [Alt Id]
as) a
n
| [Alt Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Alt Id]
as
= Expr Id -> a -> Bool
go Expr Id
e a
n
| Just Expr Id
rhs <- Expr Id -> Id -> [Alt Id] -> Maybe (Expr Id)
isUnsafeEqualityCase Expr Id
e Id
b [Alt Id]
as
= Expr Id -> a -> Bool
go Expr Id
rhs a
n
go Expr Id
_ a
_ = Bool
False
lvlBind :: LevelEnv
-> CoreBindWithFVs
-> LvlM (LevelledBind, LevelEnv)
lvlBind :: LevelEnv -> AnnBind Id FVAnn -> LvlM (LevelledBind, LevelEnv)
lvlBind LevelEnv
env (AnnNonRec Id
bndr CoreExprWithFVs
rhs)
| Id -> Bool
isTyVar Id
bndr
Bool -> Bool -> Bool
|| Id -> Bool
isCoVar Id
bndr
Bool -> Bool -> Bool
|| Bool -> Bool
not (LevelEnv -> RecFlag -> Level -> Bool -> Bool -> Bool
wantToFloat LevelEnv
env RecFlag
NonRecursive Level
dest_lvl Bool
is_join Bool
is_top_bindable)
=
do { rhs' <- LevelEnv
-> RecFlag
-> Bool
-> JoinPointHood
-> CoreExprWithFVs
-> LvlM LevelledExpr
lvlRhs LevelEnv
env RecFlag
NonRecursive Bool
is_bot_lam JoinPointHood
mb_join_arity CoreExprWithFVs
rhs
; let bind_lvl = Level -> Level
incMinorLvl (LevelEnv -> Level
le_ctxt_lvl LevelEnv
env)
(env', [bndr']) = substAndLvlBndrs NonRecursive env bind_lvl [bndr]
; return (NonRec bndr' rhs', env') }
| [Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
abs_vars
= do {
rhs' <- [Id]
-> Level
-> LevelEnv
-> RecFlag
-> Bool
-> JoinPointHood
-> CoreExprWithFVs
-> LvlM LevelledExpr
lvlFloatRhs [] Level
dest_lvl LevelEnv
env RecFlag
NonRecursive
Bool
is_bot_lam JoinPointHood
NotJoinPoint CoreExprWithFVs
rhs
; (env', [bndr']) <- cloneLetVars NonRecursive env dest_lvl [bndr]
; let bndr2 = Id -> Int -> Maybe (Int, DmdSig, CprSig) -> Id
annotateBotStr Id
bndr' Int
0 Maybe (Int, DmdSig, CprSig)
mb_bot_str
; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') }
| Bool
otherwise
= do {
rhs' <- [Id]
-> Level
-> LevelEnv
-> RecFlag
-> Bool
-> JoinPointHood
-> CoreExprWithFVs
-> LvlM LevelledExpr
lvlFloatRhs [Id]
abs_vars Level
dest_lvl LevelEnv
env RecFlag
NonRecursive
Bool
is_bot_lam JoinPointHood
NotJoinPoint CoreExprWithFVs
rhs
; (env', [bndr']) <- newPolyBndrs dest_lvl env abs_vars [bndr]
; let bndr2 = Id -> Int -> Maybe (Int, DmdSig, CprSig) -> Id
annotateBotStr Id
bndr' Int
n_extra Maybe (Int, DmdSig, CprSig)
mb_bot_str
; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') }
where
bndr_ty :: Type
bndr_ty = Id -> Type
idType Id
bndr
ty_fvs :: TyCoVarSet
ty_fvs = Type -> TyCoVarSet
tyCoVarsOfType Type
bndr_ty
rhs_fvs :: FVAnn
rhs_fvs = CoreExprWithFVs -> FVAnn
freeVarsOf CoreExprWithFVs
rhs
bind_fvs :: FVAnn
bind_fvs = FVAnn
rhs_fvs FVAnn -> FVAnn -> FVAnn
`unionDVarSet` Id -> FVAnn
dIdFreeVars Id
bndr
abs_vars :: [Id]
abs_vars = Level -> LevelEnv -> FVAnn -> [Id]
abstractVars Level
dest_lvl LevelEnv
env FVAnn
bind_fvs
dest_lvl :: Level
dest_lvl = LevelEnv -> FVAnn -> TyCoVarSet -> Bool -> Bool -> Level
destLevel LevelEnv
env FVAnn
bind_fvs TyCoVarSet
ty_fvs (CoreExprWithFVs -> Bool
isFunction CoreExprWithFVs
rhs) Bool
is_bot_lam
deann_rhs :: Expr Id
deann_rhs = CoreExprWithFVs -> Expr Id
forall bndr annot. AnnExpr bndr annot -> Expr bndr
deAnnotate CoreExprWithFVs
rhs
mb_bot_str :: Maybe (Int, DmdSig, CprSig)
mb_bot_str = Expr Id -> Maybe (Int, DmdSig, CprSig)
exprBotStrictness_maybe Expr Id
deann_rhs
is_bot_lam :: Bool
is_bot_lam = Bool -> Bool
not Bool
is_join Bool -> Bool -> Bool
&& Maybe (Int, DmdSig, CprSig) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Int, DmdSig, CprSig)
mb_bot_str
is_top_bindable :: Bool
is_top_bindable = Expr Id -> Type -> Bool
exprIsTopLevelBindable Expr Id
deann_rhs Type
bndr_ty
n_extra :: Int
n_extra = (Id -> Bool) -> [Id] -> Int
forall a. (a -> Bool) -> [a] -> Int
count Id -> Bool
isId [Id]
abs_vars
mb_join_arity :: JoinPointHood
mb_join_arity = Id -> JoinPointHood
idJoinPointHood Id
bndr
is_join :: Bool
is_join = JoinPointHood -> Bool
isJoinPoint JoinPointHood
mb_join_arity
lvlBind LevelEnv
env (AnnRec [(Id, CoreExprWithFVs)]
pairs)
| Bool -> Bool
not (LevelEnv -> RecFlag -> Level -> Bool -> Bool -> Bool
wantToFloat LevelEnv
env RecFlag
Recursive Level
dest_lvl Bool
is_join Bool
is_top_bindable)
=
do { let bind_lvl :: Level
bind_lvl = Level -> Level
incMinorLvl (LevelEnv -> Level
le_ctxt_lvl LevelEnv
env)
(LevelEnv
env', [LevelledBndr]
bndrs') = RecFlag -> LevelEnv -> Level -> [Id] -> (LevelEnv, [LevelledBndr])
substAndLvlBndrs RecFlag
Recursive LevelEnv
env Level
bind_lvl [Id]
bndrs
lvl_rhs :: (Id, CoreExprWithFVs) -> LvlM LevelledExpr
lvl_rhs (Id
b,CoreExprWithFVs
r) = LevelEnv
-> RecFlag
-> Bool
-> JoinPointHood
-> CoreExprWithFVs
-> LvlM LevelledExpr
lvlRhs LevelEnv
env' RecFlag
Recursive Bool
is_bot (Id -> JoinPointHood
idJoinPointHood Id
b) CoreExprWithFVs
r
; rhss' <- ((Id, CoreExprWithFVs) -> LvlM LevelledExpr)
-> [(Id, CoreExprWithFVs)] -> UniqSM [LevelledExpr]
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 (Id, CoreExprWithFVs) -> LvlM LevelledExpr
lvl_rhs [(Id, CoreExprWithFVs)]
pairs
; return (Rec (bndrs' `zip` rhss'), env') }
| [Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
abs_vars
= do { (new_env, new_bndrs) <- RecFlag -> LevelEnv -> Level -> [Id] -> LvlM (LevelEnv, [Id])
cloneLetVars RecFlag
Recursive LevelEnv
env Level
dest_lvl [Id]
bndrs
; new_rhss <- mapM (do_rhs new_env) pairs
; return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] `zip` new_rhss)
, new_env) }
| [(Id
bndr,CoreExprWithFVs
rhs)] <- [(Id, CoreExprWithFVs)]
pairs
, (Id -> Bool) -> [Id] -> Int
forall a. (a -> Bool) -> [a] -> Int
count Id -> Bool
isId [Id]
abs_vars Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
= do
let (LevelEnv
rhs_env, [LevelledBndr]
abs_vars_w_lvls) = LevelEnv -> Level -> [Id] -> (LevelEnv, [LevelledBndr])
lvlLamBndrs LevelEnv
env Level
dest_lvl [Id]
abs_vars
rhs_lvl :: Level
rhs_lvl = LevelEnv -> Level
le_ctxt_lvl LevelEnv
rhs_env
(rhs_env', [new_bndr]) <- RecFlag -> LevelEnv -> Level -> [Id] -> LvlM (LevelEnv, [Id])
cloneLetVars RecFlag
Recursive LevelEnv
rhs_env Level
rhs_lvl [Id
bndr]
let
(lam_bndrs, rhs_body) = collectAnnBndrs rhs
(body_env1, lam_bndrs1) = substBndrsSL NonRecursive rhs_env' lam_bndrs
(body_env2, lam_bndrs2) = lvlLamBndrs body_env1 rhs_lvl lam_bndrs1
new_rhs_body <- lvlRhs body_env2 Recursive is_bot NotJoinPoint rhs_body
(poly_env, [poly_bndr]) <- newPolyBndrs dest_lvl env abs_vars [bndr]
return (Rec [(TB poly_bndr (FloatMe dest_lvl)
, mkLams abs_vars_w_lvls $
mkLams lam_bndrs2 $
Let (Rec [( TB new_bndr (StayPut rhs_lvl)
, mkLams lam_bndrs2 new_rhs_body)])
(mkVarApps (Var new_bndr) lam_bndrs1))]
, poly_env)
| Bool
otherwise
= do { (new_env, new_bndrs) <- Level -> LevelEnv -> [Id] -> [Id] -> LvlM (LevelEnv, [Id])
newPolyBndrs Level
dest_lvl LevelEnv
env [Id]
abs_vars [Id]
bndrs
; new_rhss <- mapM (do_rhs new_env) pairs
; return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] `zip` new_rhss)
, new_env) }
where
([Id]
bndrs,[CoreExprWithFVs]
rhss) = [(Id, CoreExprWithFVs)] -> ([Id], [CoreExprWithFVs])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Id, CoreExprWithFVs)]
pairs
is_join :: Bool
is_join = Id -> Bool
isJoinId ([Id] -> Id
forall a. HasCallStack => [a] -> a
head [Id]
bndrs)
is_fun :: Bool
is_fun = (CoreExprWithFVs -> Bool) -> [CoreExprWithFVs] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all CoreExprWithFVs -> Bool
isFunction [CoreExprWithFVs]
rhss
is_bot :: Bool
is_bot = Bool
False
do_rhs :: LevelEnv -> (Id, CoreExprWithFVs) -> LvlM LevelledExpr
do_rhs LevelEnv
env (Id
_,CoreExprWithFVs
rhs) = [Id]
-> Level
-> LevelEnv
-> RecFlag
-> Bool
-> JoinPointHood
-> CoreExprWithFVs
-> LvlM LevelledExpr
lvlFloatRhs [Id]
abs_vars Level
dest_lvl LevelEnv
env RecFlag
Recursive
Bool
is_bot JoinPointHood
NotJoinPoint
CoreExprWithFVs
rhs
bind_fvs :: FVAnn
bind_fvs = (([FVAnn] -> FVAnn
unionDVarSets [ CoreExprWithFVs -> FVAnn
freeVarsOf CoreExprWithFVs
rhs | (Id
_, CoreExprWithFVs
rhs) <- [(Id, CoreExprWithFVs)]
pairs])
FVAnn -> FVAnn -> FVAnn
`unionDVarSet`
(FV -> FVAnn
fvDVarSet (FV -> FVAnn) -> FV -> FVAnn
forall a b. (a -> b) -> a -> b
$ [FV] -> FV
unionsFV [ Id -> FV
idFVs Id
bndr
| (Id
bndr, (FVAnn
_,AnnExpr' Id FVAnn
_)) <- [(Id, CoreExprWithFVs)]
pairs]))
FVAnn -> [Id] -> FVAnn
`delDVarSetList`
[Id]
bndrs
ty_fvs :: TyCoVarSet
ty_fvs = (Id -> TyCoVarSet -> TyCoVarSet)
-> TyCoVarSet -> [Id] -> TyCoVarSet
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (TyCoVarSet -> TyCoVarSet -> TyCoVarSet
unionVarSet (TyCoVarSet -> TyCoVarSet -> TyCoVarSet)
-> (Id -> TyCoVarSet) -> Id -> TyCoVarSet -> TyCoVarSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> TyCoVarSet
tyCoVarsOfType (Type -> TyCoVarSet) -> (Id -> Type) -> Id -> TyCoVarSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
idType) TyCoVarSet
emptyVarSet [Id]
bndrs
dest_lvl :: Level
dest_lvl = LevelEnv -> FVAnn -> TyCoVarSet -> Bool -> Bool -> Level
destLevel LevelEnv
env FVAnn
bind_fvs TyCoVarSet
ty_fvs Bool
is_fun Bool
is_bot
abs_vars :: [Id]
abs_vars = Level -> LevelEnv -> FVAnn -> [Id]
abstractVars Level
dest_lvl LevelEnv
env FVAnn
bind_fvs
is_top_bindable :: Bool
is_top_bindable = Bool -> Bool
not ((Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> Bool
mightBeUnliftedType (Type -> Bool) -> (Id -> Type) -> Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
idType) [Id]
bndrs)
wantToFloat :: LevelEnv
-> RecFlag
-> Level
-> Bool
-> Bool
-> Bool
wantToFloat :: LevelEnv -> RecFlag -> Level -> Bool -> Bool -> Bool
wantToFloat LevelEnv
env RecFlag
is_rec Level
dest_lvl Bool
is_join Bool
is_top_bindable
| Bool -> Bool
not (LevelEnv -> Level -> Bool
profitableFloat LevelEnv
env Level
dest_lvl)
= Bool
False
| LevelEnv -> Bool
floatTopLvlOnly LevelEnv
env Bool -> Bool -> Bool
&& Bool -> Bool
not (Level -> Bool
isTopLvl Level
dest_lvl)
= Bool
False
| Level -> Bool
isTopLvl Level
dest_lvl, Bool -> Bool
not Bool
is_top_bindable
= Bool
False
| Bool
is_join
= Level -> Bool
isTopLvl Level
dest_lvl Bool -> Bool -> Bool
&& (RecFlag -> Bool
isRec RecFlag
is_rec Bool -> Bool -> Bool
|| FloatOutSwitches -> Bool
floatJoinsToTop (LevelEnv -> FloatOutSwitches
le_switches LevelEnv
env))
| Bool
otherwise
= Bool
True
profitableFloat :: LevelEnv -> Level -> Bool
profitableFloat :: LevelEnv -> Level -> Bool
profitableFloat LevelEnv
env Level
dest_lvl
= (Level
dest_lvl Level -> Level -> Bool
`ltMajLvl` LevelEnv -> Level
le_ctxt_lvl LevelEnv
env)
Bool -> Bool -> Bool
|| (Level -> Bool
isTopLvl Level
dest_lvl Bool -> Bool -> Bool
&& LevelEnv -> Bool
floatConsts LevelEnv
env)
lvlRhs :: LevelEnv
-> RecFlag
-> Bool
-> JoinPointHood
-> CoreExprWithFVs
-> LvlM LevelledExpr
lvlRhs :: LevelEnv
-> RecFlag
-> Bool
-> JoinPointHood
-> CoreExprWithFVs
-> LvlM LevelledExpr
lvlRhs LevelEnv
env RecFlag
rec_flag Bool
is_bot JoinPointHood
mb_join_arity CoreExprWithFVs
expr
= [Id]
-> Level
-> LevelEnv
-> RecFlag
-> Bool
-> JoinPointHood
-> CoreExprWithFVs
-> LvlM LevelledExpr
lvlFloatRhs [] (LevelEnv -> Level
le_ctxt_lvl LevelEnv
env) LevelEnv
env
RecFlag
rec_flag Bool
is_bot JoinPointHood
mb_join_arity CoreExprWithFVs
expr
lvlFloatRhs :: [OutVar] -> Level -> LevelEnv -> RecFlag
-> Bool
-> JoinPointHood
-> CoreExprWithFVs
-> LvlM (Expr LevelledBndr)
lvlFloatRhs :: [Id]
-> Level
-> LevelEnv
-> RecFlag
-> Bool
-> JoinPointHood
-> CoreExprWithFVs
-> LvlM LevelledExpr
lvlFloatRhs [Id]
abs_vars Level
dest_lvl LevelEnv
env RecFlag
rec Bool
is_bot JoinPointHood
mb_join_arity CoreExprWithFVs
rhs
= do { body' <- if Bool -> Bool
not Bool
is_bot
Bool -> Bool -> Bool
&& (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Id -> Bool
isId [Id]
bndrs
then LevelEnv -> Bool -> CoreExprWithFVs -> LvlM LevelledExpr
lvlMFE LevelEnv
body_env Bool
True CoreExprWithFVs
body
else LevelEnv -> CoreExprWithFVs -> LvlM LevelledExpr
lvlExpr LevelEnv
body_env CoreExprWithFVs
body
; return (mkLams bndrs' body') }
where
([Id]
bndrs, CoreExprWithFVs
body) | JoinPoint Int
join_arity <- JoinPointHood
mb_join_arity
= Int -> CoreExprWithFVs -> ([Id], CoreExprWithFVs)
forall bndr annot.
Int -> AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
collectNAnnBndrs Int
join_arity CoreExprWithFVs
rhs
| Bool
otherwise
= CoreExprWithFVs -> ([Id], CoreExprWithFVs)
forall bndr annot.
AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
collectAnnBndrs CoreExprWithFVs
rhs
(LevelEnv
env1, [Id]
bndrs1) = RecFlag -> LevelEnv -> [Id] -> (LevelEnv, [Id])
substBndrsSL RecFlag
NonRecursive LevelEnv
env [Id]
bndrs
all_bndrs :: [Id]
all_bndrs = [Id]
abs_vars [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
bndrs1
(LevelEnv
body_env, [LevelledBndr]
bndrs') | JoinPoint {} <- JoinPointHood
mb_join_arity
= LevelEnv -> Level -> RecFlag -> [Id] -> (LevelEnv, [LevelledBndr])
lvlJoinBndrs LevelEnv
env1 Level
dest_lvl RecFlag
rec [Id]
all_bndrs
| Bool
otherwise
= LevelEnv -> Level -> [Id] -> (LevelEnv, [LevelledBndr])
lvlLamBndrs LevelEnv
env1 Level
dest_lvl [Id]
all_bndrs
substAndLvlBndrs :: RecFlag -> LevelEnv -> Level -> [InVar] -> (LevelEnv, [LevelledBndr])
substAndLvlBndrs :: RecFlag -> LevelEnv -> Level -> [Id] -> (LevelEnv, [LevelledBndr])
substAndLvlBndrs RecFlag
is_rec LevelEnv
env Level
lvl [Id]
bndrs
= LevelEnv -> Level -> [Id] -> (LevelEnv, [LevelledBndr])
lvlBndrs LevelEnv
subst_env Level
lvl [Id]
subst_bndrs
where
(LevelEnv
subst_env, [Id]
subst_bndrs) = RecFlag -> LevelEnv -> [Id] -> (LevelEnv, [Id])
substBndrsSL RecFlag
is_rec LevelEnv
env [Id]
bndrs
substBndrsSL :: RecFlag -> LevelEnv -> [InVar] -> (LevelEnv, [OutVar])
RecFlag
is_rec env :: LevelEnv
env@(LE { le_subst :: LevelEnv -> Subst
le_subst = Subst
subst, le_env :: LevelEnv -> IdEnv ([Id], LevelledExpr)
le_env = IdEnv ([Id], LevelledExpr)
id_env }) [Id]
bndrs
= ( LevelEnv
env { le_subst = subst'
, le_env = foldl' add_id id_env (bndrs `zip` bndrs') }
, [Id]
bndrs')
where
(Subst
subst', [Id]
bndrs') = case RecFlag
is_rec of
RecFlag
NonRecursive -> Subst -> [Id] -> (Subst, [Id])
forall (f :: * -> *).
Traversable f =>
Subst -> f Id -> (Subst, f Id)
substBndrs Subst
subst [Id]
bndrs
RecFlag
Recursive -> Subst -> [Id] -> (Subst, [Id])
forall (f :: * -> *).
Traversable f =>
Subst -> f Id -> (Subst, f Id)
substRecBndrs Subst
subst [Id]
bndrs
lvlLamBndrs :: LevelEnv -> Level -> [OutVar] -> (LevelEnv, [LevelledBndr])
lvlLamBndrs :: LevelEnv -> Level -> [Id] -> (LevelEnv, [LevelledBndr])
lvlLamBndrs LevelEnv
env Level
lvl [Id]
bndrs
= LevelEnv -> Level -> [Id] -> (LevelEnv, [LevelledBndr])
lvlBndrs LevelEnv
env Level
new_lvl [Id]
bndrs
where
new_lvl :: Level
new_lvl | (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Id -> Bool
is_major [Id]
bndrs = Level -> Level
incMajorLvl Level
lvl
| Bool
otherwise = Level -> Level
incMinorLvl Level
lvl
is_major :: Id -> Bool
is_major Id
bndr = Bool -> Bool
not (Id -> Bool
isOneShotBndr Id
bndr)
lvlJoinBndrs :: LevelEnv -> Level -> RecFlag -> [OutVar]
-> (LevelEnv, [LevelledBndr])
lvlJoinBndrs :: LevelEnv -> Level -> RecFlag -> [Id] -> (LevelEnv, [LevelledBndr])
lvlJoinBndrs LevelEnv
env Level
lvl RecFlag
rec [Id]
bndrs
= LevelEnv -> Level -> [Id] -> (LevelEnv, [LevelledBndr])
lvlBndrs LevelEnv
env Level
new_lvl [Id]
bndrs
where
new_lvl :: Level
new_lvl | RecFlag -> Bool
isRec RecFlag
rec = Level -> Level
incMajorLvl Level
lvl
| Bool
otherwise = Level -> Level
incMinorLvl Level
lvl
lvlBndrs :: LevelEnv -> Level -> [CoreBndr] -> (LevelEnv, [LevelledBndr])
lvlBndrs :: LevelEnv -> Level -> [Id] -> (LevelEnv, [LevelledBndr])
lvlBndrs env :: LevelEnv
env@(LE { le_lvl_env :: LevelEnv -> VarEnv Level
le_lvl_env = VarEnv Level
lvl_env }) Level
new_lvl [Id]
bndrs
= ( LevelEnv
env { le_ctxt_lvl = new_lvl
, le_lvl_env = addLvls new_lvl lvl_env bndrs }
, (Id -> LevelledBndr) -> [Id] -> [LevelledBndr]
forall a b. (a -> b) -> [a] -> [b]
map (Level -> Id -> LevelledBndr
stayPut Level
new_lvl) [Id]
bndrs)
stayPut :: Level -> OutVar -> LevelledBndr
stayPut :: Level -> Id -> LevelledBndr
stayPut Level
new_lvl Id
bndr = Id -> FloatSpec -> LevelledBndr
forall t. Id -> t -> TaggedBndr t
TB Id
bndr (Level -> FloatSpec
StayPut Level
new_lvl)
destLevel :: LevelEnv
-> DVarSet
-> TyCoVarSet
-> Bool
-> Bool
-> Level
destLevel :: LevelEnv -> FVAnn -> TyCoVarSet -> Bool -> Bool -> Level
destLevel LevelEnv
env FVAnn
fvs TyCoVarSet
fvs_ty Bool
is_function Bool
is_bot
| Level -> Bool
isTopLvl Level
max_fv_id_level
= Level
tOP_LEVEL
| Bool
is_bot
= Level
as_far_as_poss
| Just Int
n_args <- LevelEnv -> Maybe Int
floatLams LevelEnv
env
, Int
n_args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
, Bool
is_function
, FVAnn -> Int
countFreeIds FVAnn
fvs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
n_args
= Level
as_far_as_poss
| Bool
otherwise = Level
max_fv_id_level
where
max_fv_id_level :: Level
max_fv_id_level = (Id -> Bool) -> LevelEnv -> FVAnn -> Level
maxFvLevel Id -> Bool
isId LevelEnv
env FVAnn
fvs
as_far_as_poss :: Level
as_far_as_poss = (Id -> Bool) -> LevelEnv -> TyCoVarSet -> Level
maxFvLevel' Id -> Bool
isId LevelEnv
env TyCoVarSet
fvs_ty
isFunction :: CoreExprWithFVs -> Bool
isFunction :: CoreExprWithFVs -> Bool
isFunction (FVAnn
_, AnnLam Id
b CoreExprWithFVs
e) | Id -> Bool
isId Id
b = Bool
True
| Bool
otherwise = CoreExprWithFVs -> Bool
isFunction CoreExprWithFVs
e
isFunction CoreExprWithFVs
_ = Bool
False
countFreeIds :: DVarSet -> Int
countFreeIds :: FVAnn -> Int
countFreeIds = (Id -> Int -> Int) -> Int -> UniqDFM Id Id -> Int
forall {k} elt a (key :: k).
(elt -> a -> a) -> a -> UniqDFM key elt -> a
nonDetStrictFoldUDFM Id -> Int -> Int
add Int
0 (UniqDFM Id Id -> Int) -> (FVAnn -> UniqDFM Id Id) -> FVAnn -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FVAnn -> UniqDFM Id Id
forall a. UniqDSet a -> UniqDFM a a
getUniqDSet
where
add :: Var -> Int -> Int
add :: Id -> Int -> Int
add Id
v Int
n | Id -> Bool
isId Id
v = Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1
| Bool
otherwise = Int
n
data LevelEnv
= LE { LevelEnv -> FloatOutSwitches
le_switches :: FloatOutSwitches
, LevelEnv -> Level
le_ctxt_lvl :: Level
, LevelEnv -> VarEnv Level
le_lvl_env :: VarEnv Level
, LevelEnv -> Subst
le_subst :: Subst
, LevelEnv -> IdEnv ([Id], LevelledExpr)
le_env :: IdEnv ([OutVar], LevelledExpr)
}
initialEnv :: FloatOutSwitches -> CoreProgram -> LevelEnv
initialEnv :: FloatOutSwitches -> CoreProgram -> LevelEnv
initialEnv FloatOutSwitches
float_lams CoreProgram
binds
= LE { le_switches :: FloatOutSwitches
le_switches = FloatOutSwitches
float_lams
, le_ctxt_lvl :: Level
le_ctxt_lvl = Level
tOP_LEVEL
, le_lvl_env :: VarEnv Level
le_lvl_env = VarEnv Level
forall a. VarEnv a
emptyVarEnv
, le_subst :: Subst
le_subst = InScopeSet -> Subst
mkEmptySubst InScopeSet
in_scope_toplvl
, le_env :: IdEnv ([Id], LevelledExpr)
le_env = IdEnv ([Id], LevelledExpr)
forall a. VarEnv a
emptyVarEnv }
where
in_scope_toplvl :: InScopeSet
in_scope_toplvl = InScopeSet
emptyInScopeSet InScopeSet -> CoreProgram -> InScopeSet
`extendInScopeSetBndrs` CoreProgram
binds
addLvl :: Level -> VarEnv Level -> OutVar -> VarEnv Level
addLvl :: Level -> VarEnv Level -> Id -> VarEnv Level
addLvl Level
dest_lvl VarEnv Level
env Id
v' = VarEnv Level -> Id -> Level -> VarEnv Level
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv VarEnv Level
env Id
v' Level
dest_lvl
addLvls :: Level -> VarEnv Level -> [OutVar] -> VarEnv Level
addLvls :: Level -> VarEnv Level -> [Id] -> VarEnv Level
addLvls Level
dest_lvl VarEnv Level
env [Id]
vs = (VarEnv Level -> Id -> VarEnv Level)
-> VarEnv Level -> [Id] -> VarEnv Level
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Level -> VarEnv Level -> Id -> VarEnv Level
addLvl Level
dest_lvl) VarEnv Level
env [Id]
vs
floatLams :: LevelEnv -> Maybe Int
floatLams :: LevelEnv -> Maybe Int
floatLams LevelEnv
le = FloatOutSwitches -> Maybe Int
floatOutLambdas (LevelEnv -> FloatOutSwitches
le_switches LevelEnv
le)
floatConsts :: LevelEnv -> Bool
floatConsts :: LevelEnv -> Bool
floatConsts LevelEnv
le = FloatOutSwitches -> Bool
floatOutConstants (LevelEnv -> FloatOutSwitches
le_switches LevelEnv
le)
floatOverSat :: LevelEnv -> Bool
floatOverSat :: LevelEnv -> Bool
floatOverSat LevelEnv
le = FloatOutSwitches -> Bool
floatOutOverSatApps (LevelEnv -> FloatOutSwitches
le_switches LevelEnv
le)
floatTopLvlOnly :: LevelEnv -> Bool
floatTopLvlOnly :: LevelEnv -> Bool
floatTopLvlOnly LevelEnv
le = FloatOutSwitches -> Bool
floatToTopLevelOnly (LevelEnv -> FloatOutSwitches
le_switches LevelEnv
le)
incMinorLvlFrom :: LevelEnv -> Level
incMinorLvlFrom :: LevelEnv -> Level
incMinorLvlFrom LevelEnv
env = Level -> Level
incMinorLvl (LevelEnv -> Level
le_ctxt_lvl LevelEnv
env)
extendCaseBndrEnv :: LevelEnv
-> Id
-> Expr LevelledBndr
-> LevelEnv
extendCaseBndrEnv :: LevelEnv -> Id -> LevelledExpr -> LevelEnv
extendCaseBndrEnv le :: LevelEnv
le@(LE { le_subst :: LevelEnv -> Subst
le_subst = Subst
subst, le_env :: LevelEnv -> IdEnv ([Id], LevelledExpr)
le_env = IdEnv ([Id], LevelledExpr)
id_env })
Id
case_bndr (Var Id
scrut_var)
= LevelEnv
le { le_subst = extendSubstWithVar subst case_bndr scrut_var
, le_env = add_id id_env (case_bndr, scrut_var) }
extendCaseBndrEnv LevelEnv
env Id
_ LevelledExpr
_ = LevelEnv
env
maxFvLevel :: (Var -> Bool) -> LevelEnv -> DVarSet -> Level
maxFvLevel :: (Id -> Bool) -> LevelEnv -> FVAnn -> Level
maxFvLevel Id -> Bool
max_me LevelEnv
env FVAnn
var_set
= (Id -> Level -> Level) -> Level -> FVAnn -> Level
forall a. (Id -> a -> a) -> a -> FVAnn -> a
nonDetStrictFoldDVarSet ((Id -> Bool) -> LevelEnv -> Id -> Level -> Level
maxIn Id -> Bool
max_me LevelEnv
env) Level
tOP_LEVEL FVAnn
var_set
maxFvLevel' :: (Var -> Bool) -> LevelEnv -> TyCoVarSet -> Level
maxFvLevel' :: (Id -> Bool) -> LevelEnv -> TyCoVarSet -> Level
maxFvLevel' Id -> Bool
max_me LevelEnv
env TyCoVarSet
var_set
= (Id -> Level -> Level) -> Level -> TyCoVarSet -> Level
forall elt a. (elt -> a -> a) -> a -> UniqSet elt -> a
nonDetStrictFoldUniqSet ((Id -> Bool) -> LevelEnv -> Id -> Level -> Level
maxIn Id -> Bool
max_me LevelEnv
env) Level
tOP_LEVEL TyCoVarSet
var_set
maxIn :: (Var -> Bool) -> LevelEnv -> InVar -> Level -> Level
maxIn :: (Id -> Bool) -> LevelEnv -> Id -> Level -> Level
maxIn Id -> Bool
max_me (LE { le_lvl_env :: LevelEnv -> VarEnv Level
le_lvl_env = VarEnv Level
lvl_env, le_env :: LevelEnv -> IdEnv ([Id], LevelledExpr)
le_env = IdEnv ([Id], LevelledExpr)
id_env }) Id
in_var Level
lvl
= case IdEnv ([Id], LevelledExpr) -> Id -> Maybe ([Id], LevelledExpr)
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv IdEnv ([Id], LevelledExpr)
id_env Id
in_var of
Just ([Id]
abs_vars, LevelledExpr
_) -> (Id -> Level -> Level) -> Level -> [Id] -> Level
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Id -> Level -> Level
max_out Level
lvl [Id]
abs_vars
Maybe ([Id], LevelledExpr)
Nothing -> Id -> Level -> Level
max_out Id
in_var Level
lvl
where
max_out :: Id -> Level -> Level
max_out Id
out_var Level
lvl
| Id -> Bool
max_me Id
out_var = case VarEnv Level -> Id -> Maybe Level
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv VarEnv Level
lvl_env Id
out_var of
Just Level
lvl' -> Level -> Level -> Level
maxLvl Level
lvl' Level
lvl
Maybe Level
Nothing -> Level
lvl
| Bool
otherwise = Level
lvl
lookupVar :: LevelEnv -> Id -> LevelledExpr
lookupVar :: LevelEnv -> Id -> LevelledExpr
lookupVar LevelEnv
le Id
v = case IdEnv ([Id], LevelledExpr) -> Id -> Maybe ([Id], LevelledExpr)
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv (LevelEnv -> IdEnv ([Id], LevelledExpr)
le_env LevelEnv
le) Id
v of
Just ([Id]
_, LevelledExpr
expr) -> LevelledExpr
expr
Maybe ([Id], LevelledExpr)
_ -> Id -> LevelledExpr
forall b. Id -> Expr b
Var Id
v
abstractVars :: Level -> LevelEnv -> DVarSet -> [OutVar]
abstractVars :: Level -> LevelEnv -> FVAnn -> [Id]
abstractVars Level
dest_lvl (LE { le_subst :: LevelEnv -> Subst
le_subst = Subst
subst, le_lvl_env :: LevelEnv -> VarEnv Level
le_lvl_env = VarEnv Level
lvl_env }) FVAnn
in_fvs
=
(Id -> Id) -> [Id] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Id
zap ([Id] -> [Id]) -> [Id] -> [Id]
forall a b. (a -> b) -> a -> b
$ [Id] -> [Id]
sortQuantVars ([Id] -> [Id]) -> [Id] -> [Id]
forall a b. (a -> b) -> a -> b
$
(Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter Id -> Bool
abstract_me ([Id] -> [Id]) -> [Id] -> [Id]
forall a b. (a -> b) -> a -> b
$
FVAnn -> [Id]
dVarSetElems (FVAnn -> [Id]) -> FVAnn -> [Id]
forall a b. (a -> b) -> a -> b
$
FVAnn -> FVAnn
closeOverKindsDSet (FVAnn -> FVAnn) -> FVAnn -> FVAnn
forall a b. (a -> b) -> a -> b
$
HasDebugCallStack => Subst -> FVAnn -> FVAnn
Subst -> FVAnn -> FVAnn
substDVarSet Subst
subst FVAnn
in_fvs
where
abstract_me :: Id -> Bool
abstract_me Id
v = case VarEnv Level -> Id -> Maybe Level
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv VarEnv Level
lvl_env Id
v of
Just Level
lvl -> Level
dest_lvl Level -> Level -> Bool
`ltLvl` Level
lvl
Maybe Level
Nothing -> Bool
False
zap :: Id -> Id
zap Id
v | Id -> Bool
isId Id
v = Bool -> String -> SDoc -> Id -> Id
forall a. HasCallStack => Bool -> String -> SDoc -> a -> a
warnPprTrace (Unfolding -> Bool
isStableUnfolding (IdUnfoldingFun
idUnfolding Id
v) Bool -> Bool -> Bool
||
Bool -> Bool
not (RuleInfo -> Bool
isEmptyRuleInfo (Id -> RuleInfo
idSpecialisation Id
v)))
String
"absVarsOf: discarding info on" (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
v) (Id -> Id) -> Id -> Id
forall a b. (a -> b) -> a -> b
$
Id -> IdInfo -> Id
setIdInfo Id
v IdInfo
vanillaIdInfo
| Bool
otherwise = Id
v
type LvlM result = UniqSM result
initLvl :: UniqSupply -> UniqSM a -> a
initLvl :: forall a. UniqSupply -> UniqSM a -> a
initLvl = UniqSupply -> UniqSM a -> a
forall a. UniqSupply -> UniqSM a -> a
initUs_
newPolyBndrs :: Level -> LevelEnv -> [OutVar] -> [InId]
-> LvlM (LevelEnv, [OutId])
newPolyBndrs :: Level -> LevelEnv -> [Id] -> [Id] -> LvlM (LevelEnv, [Id])
newPolyBndrs Level
dest_lvl
env :: LevelEnv
env@(LE { le_lvl_env :: LevelEnv -> VarEnv Level
le_lvl_env = VarEnv Level
lvl_env, le_subst :: LevelEnv -> Subst
le_subst = Subst
subst, le_env :: LevelEnv -> IdEnv ([Id], LevelledExpr)
le_env = IdEnv ([Id], LevelledExpr)
id_env })
[Id]
abs_vars [Id]
bndrs
= Bool -> LvlM (LevelEnv, [Id]) -> LvlM (LevelEnv, [Id])
forall a. HasCallStack => Bool -> a -> a
assert ((Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not (Bool -> Bool) -> (Id -> Bool) -> Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Bool
isCoVar) [Id]
bndrs) (LvlM (LevelEnv, [Id]) -> LvlM (LevelEnv, [Id]))
-> LvlM (LevelEnv, [Id]) -> LvlM (LevelEnv, [Id])
forall a b. (a -> b) -> a -> b
$
do { uniqs <- UniqSM [Unique]
forall (m :: * -> *). MonadUnique m => m [Unique]
getUniquesM
; let new_bndrs = (Id -> Unique -> Id) -> [Id] -> [Unique] -> [Id]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Id -> Unique -> Id
mk_poly_bndr [Id]
bndrs [Unique]
uniqs
bndr_prs = [Id]
bndrs [Id] -> [Id] -> [(Id, Id)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Id]
new_bndrs
env' = LevelEnv
env { le_lvl_env = addLvls dest_lvl lvl_env new_bndrs
, le_subst = foldl' add_subst subst bndr_prs
, le_env = foldl' add_id id_env bndr_prs }
; return (env', new_bndrs) }
where
add_subst :: Subst -> (Id, Id) -> Subst
add_subst Subst
env (Id
v, Id
v') = Subst -> Id -> Expr Id -> Subst
extendIdSubst Subst
env Id
v (Expr Id -> [Id] -> Expr Id
forall b. Expr b -> [Id] -> Expr b
mkVarApps (Id -> Expr Id
forall b. Id -> Expr b
Var Id
v') [Id]
abs_vars)
add_id :: IdEnv ([Id], LevelledExpr)
-> (Id, Id) -> IdEnv ([Id], LevelledExpr)
add_id IdEnv ([Id], LevelledExpr)
env (Id
v, Id
v') = IdEnv ([Id], LevelledExpr)
-> Id -> ([Id], LevelledExpr) -> IdEnv ([Id], LevelledExpr)
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv IdEnv ([Id], LevelledExpr)
env Id
v ((Id
v'Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
abs_vars), LevelledExpr -> [Id] -> LevelledExpr
forall b. Expr b -> [Id] -> Expr b
mkVarApps (Id -> LevelledExpr
forall b. Id -> Expr b
Var Id
v') [Id]
abs_vars)
mk_poly_bndr :: Id -> Unique -> Id
mk_poly_bndr Id
bndr Unique
uniq = Id -> [Id] -> Id -> Id
transferPolyIdInfo Id
bndr [Id]
abs_vars (Id -> Id) -> Id -> Id
forall a b. (a -> b) -> a -> b
$
Id -> Id -> Id
transfer_join_info Id
bndr (Id -> Id) -> Id -> Id
forall a b. (a -> b) -> a -> b
$
FastString -> Unique -> Type -> Type -> Id
mkSysLocal FastString
str Unique
uniq (HasDebugCallStack => Id -> Type
Id -> Type
idMult Id
bndr) Type
poly_ty
where
str :: FastString
str = String -> FastString
fsLit String
"poly_" FastString -> FastString -> FastString
`appendFS` OccName -> FastString
occNameFS (Id -> OccName
forall a. NamedThing a => a -> OccName
getOccName Id
bndr)
poly_ty :: Type
poly_ty = [Id] -> Type -> Type
mkLamTypes [Id]
abs_vars (Subst -> Type -> Type
substTyUnchecked Subst
subst (Id -> Type
idType Id
bndr))
dest_is_top :: Bool
dest_is_top = Level -> Bool
isTopLvl Level
dest_lvl
transfer_join_info :: Id -> Id -> Id
transfer_join_info Id
bndr Id
new_bndr
| JoinPoint Int
join_arity <- Id -> JoinPointHood
idJoinPointHood Id
bndr
, Bool -> Bool
not Bool
dest_is_top
= Id
new_bndr Id -> Int -> Id
`asJoinId` Int
join_arity Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Id] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
abs_vars
| Bool
otherwise
= Id
new_bndr
newLvlVar :: LevelledExpr
-> JoinPointHood
-> Bool
-> LvlM Id
newLvlVar :: LevelledExpr -> JoinPointHood -> Bool -> LvlM Id
newLvlVar LevelledExpr
lvld_rhs JoinPointHood
join_arity_maybe Bool
is_mk_static
= do { uniq <- UniqSM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
; return (add_join_info (mk_id uniq rhs_ty))
}
where
add_join_info :: Id -> Id
add_join_info Id
var = Id
var Id -> JoinPointHood -> Id
`asJoinId_maybe` JoinPointHood
join_arity_maybe
de_tagged_rhs :: Expr Id
de_tagged_rhs = LevelledExpr -> Expr Id
forall t. TaggedExpr t -> Expr Id
deTagExpr LevelledExpr
lvld_rhs
rhs_ty :: Type
rhs_ty = HasDebugCallStack => Expr Id -> Type
Expr Id -> Type
exprType Expr Id
de_tagged_rhs
mk_id :: Unique -> Type -> Id
mk_id Unique
uniq Type
rhs_ty
| Bool
is_mk_static
= Name -> Type -> Id
mkExportedVanillaId (Unique -> FastString -> Name
mkSystemVarName Unique
uniq (String -> FastString
mkFastString String
"static_ptr"))
Type
rhs_ty
| Bool
otherwise
= FastString -> Unique -> Type -> Type -> Id
mkSysLocal (String -> FastString
mkFastString String
"lvl") Unique
uniq Type
ManyTy Type
rhs_ty
cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var])
cloneCaseBndrs :: LevelEnv -> Level -> [Id] -> LvlM (LevelEnv, [Id])
cloneCaseBndrs env :: LevelEnv
env@(LE { le_subst :: LevelEnv -> Subst
le_subst = Subst
subst, le_lvl_env :: LevelEnv -> VarEnv Level
le_lvl_env = VarEnv Level
lvl_env, le_env :: LevelEnv -> IdEnv ([Id], LevelledExpr)
le_env = IdEnv ([Id], LevelledExpr)
id_env })
Level
new_lvl [Id]
vs
= do { (subst', vs') <- Subst -> [Id] -> UniqSM (Subst, [Id])
forall (m :: * -> *).
MonadUnique m =>
Subst -> [Id] -> m (Subst, [Id])
cloneBndrs Subst
subst [Id]
vs
; let env' = LevelEnv
env { le_lvl_env = addLvls new_lvl lvl_env vs'
, le_subst = subst'
, le_env = foldl' add_id id_env (vs `zip` vs') }
; return (env', vs') }
cloneLetVars :: RecFlag -> LevelEnv -> Level -> [InVar]
-> LvlM (LevelEnv, [OutVar])
cloneLetVars :: RecFlag -> LevelEnv -> Level -> [Id] -> LvlM (LevelEnv, [Id])
cloneLetVars RecFlag
is_rec
env :: LevelEnv
env@(LE { le_subst :: LevelEnv -> Subst
le_subst = Subst
subst, le_lvl_env :: LevelEnv -> VarEnv Level
le_lvl_env = VarEnv Level
lvl_env, le_env :: LevelEnv -> IdEnv ([Id], LevelledExpr)
le_env = IdEnv ([Id], LevelledExpr)
id_env })
Level
dest_lvl [Id]
vs
= do { let vs1 :: [Id]
vs1 = (Id -> Id) -> [Id] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Id
zap [Id]
vs
; (subst', vs2) <- case RecFlag
is_rec of
RecFlag
NonRecursive -> Subst -> [Id] -> UniqSM (Subst, [Id])
forall (m :: * -> *).
MonadUnique m =>
Subst -> [Id] -> m (Subst, [Id])
cloneBndrs Subst
subst [Id]
vs1
RecFlag
Recursive -> Subst -> [Id] -> UniqSM (Subst, [Id])
forall (m :: * -> *).
MonadUnique m =>
Subst -> [Id] -> m (Subst, [Id])
cloneRecIdBndrs Subst
subst [Id]
vs1
; let prs = [Id]
vs [Id] -> [Id] -> [(Id, Id)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Id]
vs2
env' = LevelEnv
env { le_lvl_env = addLvls dest_lvl lvl_env vs2
, le_subst = subst'
, le_env = foldl' add_id id_env prs }
; return (env', vs2) }
where
zap :: Var -> Var
zap :: Id -> Id
zap Id
v | Id -> Bool
isId Id
v = Id -> Id
zap_join (Id -> Id
floatifyIdDemandInfo Id
v)
| Bool
otherwise = Id
v
zap_join :: Id -> Id
zap_join | Level -> Bool
isTopLvl Level
dest_lvl = Id -> Id
zapJoinId
| Bool
otherwise = Id -> Id
forall a. a -> a
id
add_id :: IdEnv ([Var], LevelledExpr) -> (Var, Var) -> IdEnv ([Var], LevelledExpr)
add_id :: IdEnv ([Id], LevelledExpr)
-> (Id, Id) -> IdEnv ([Id], LevelledExpr)
add_id IdEnv ([Id], LevelledExpr)
id_env (Id
v, Id
v1)
| Id -> Bool
isTyVar Id
v = IdEnv ([Id], LevelledExpr) -> Id -> IdEnv ([Id], LevelledExpr)
forall a. VarEnv a -> Id -> VarEnv a
delVarEnv IdEnv ([Id], LevelledExpr)
id_env Id
v
| Bool
otherwise = IdEnv ([Id], LevelledExpr)
-> Id -> ([Id], LevelledExpr) -> IdEnv ([Id], LevelledExpr)
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv IdEnv ([Id], LevelledExpr)
id_env Id
v ([Id
v1], Bool -> LevelledExpr -> LevelledExpr
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (Id -> Bool
isCoVar Id
v1)) (LevelledExpr -> LevelledExpr) -> LevelledExpr -> LevelledExpr
forall a b. (a -> b) -> a -> b
$ Id -> LevelledExpr
forall b. Id -> Expr b
Var Id
v1)