{-# LANGUAGE PatternSynonyms #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Core.Opt.SetLevels (
        setLevels,
        Level(..), LevelType(..), tOP_LEVEL, isJoinCeilLvl, asJoinCeilLvl,
        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   ( exprType, exprIsHNF
                        , exprOkForSpeculation
                        , exprIsTopLevelBindable
                        , collectMakeStaticArgs
                        , mkLamTypes
                        )
import GHC.Core.Opt.Arity   ( exprBotStrictness_maybe )
import GHC.Core.FVs     
import GHC.Core.Subst
import GHC.Core.Make    ( sortQuantVars )
import GHC.Core.Type    ( Type, splitTyConApp_maybe, tyCoVarsOfType
                        , mightBeUnliftedType, closeOverKindsDSet
                        , typeHasFixedRuntimeRep
                        )
import GHC.Core.Multiplicity     ( pattern Many )
import GHC.Core.DataCon ( dataConOrigResTy )
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, Demand, isStrUsedDmd, splitDmdSig, prependArgsDmdSig )
import GHC.Types.Cpr          ( mkCprSig, botCpr )
import GHC.Types.Name         ( getOccName, mkSystemVarName )
import GHC.Types.Name.Occurrence ( occNameString )
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.Monad  ( mapAccumLM )
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Trace
import Data.Maybe
type LevelledExpr = TaggedExpr FloatSpec
type LevelledBind = TaggedBind FloatSpec
type LevelledBndr = TaggedBndr FloatSpec
data Level = Level Int  
                   Int  
                        
                        
                   LevelType 
data LevelType = BndrLvl | JoinCeilLvl deriving (LevelType -> LevelType -> Bool
(LevelType -> LevelType -> Bool)
-> (LevelType -> LevelType -> Bool) -> Eq LevelType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LevelType -> LevelType -> Bool
== :: LevelType -> LevelType -> Bool
$c/= :: LevelType -> LevelType -> Bool
/= :: LevelType -> LevelType -> Bool
Eq)
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
char Char
'F' SDoc -> SDoc -> SDoc
<> 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 -> LevelType -> Level
Level Int
0 Int
0 LevelType
BndrLvl
incMajorLvl :: Level -> Level
incMajorLvl :: Level -> Level
incMajorLvl (Level Int
major Int
_ LevelType
_) = Int -> Int -> LevelType -> Level
Level (Int
major Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
0 LevelType
BndrLvl
incMinorLvl :: Level -> Level
incMinorLvl :: Level -> Level
incMinorLvl (Level Int
major Int
minor LevelType
_) = Int -> Int -> LevelType -> Level
Level Int
major (Int
minorInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) LevelType
BndrLvl
asJoinCeilLvl :: Level -> Level
asJoinCeilLvl :: Level -> Level
asJoinCeilLvl (Level Int
major Int
minor LevelType
_) = Int -> Int -> LevelType -> Level
Level Int
major Int
minor LevelType
JoinCeilLvl
maxLvl :: Level -> Level -> Level
maxLvl :: Level -> Level -> Level
maxLvl l1 :: Level
l1@(Level Int
maj1 Int
min1 LevelType
_) l2 :: Level
l2@(Level Int
maj2 Int
min2 LevelType
_)
  | (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 LevelType
_) (Level Int
maj2 Int
min2 LevelType
_)
  = (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
_ LevelType
_) (Level Int
maj2 Int
_ LevelType
_) = 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 LevelType
_) = Bool
True
isTopLvl Level
_             = Bool
False
isJoinCeilLvl :: Level -> Bool
isJoinCeilLvl :: Level -> Bool
isJoinCeilLvl (Level Int
_ Int
_ LevelType
t) = LevelType
t LevelType -> LevelType -> Bool
forall a. Eq a => a -> a -> Bool
== LevelType
JoinCeilLvl
instance Outputable Level where
  ppr :: Level -> SDoc
ppr (Level Int
maj Int
min LevelType
typ)
    = [SDoc] -> SDoc
hcat [ Char -> SDoc
char Char
'<', Int -> SDoc
int Int
maj, Char -> SDoc
char Char
',', Int -> SDoc
int Int
min, Char -> SDoc
char Char
'>'
           , Bool -> SDoc -> SDoc
ppWhen (LevelType
typ LevelType -> LevelType -> Bool
forall a. Eq a => a -> a -> Bool
== LevelType
JoinCeilLvl) (Char -> SDoc
char Char
'C') ]
instance Eq Level where
  (Level Int
maj1 Int
min1 LevelType
_) == :: Level -> Level -> Bool
== (Level Int
maj2 Int
min2 LevelType
_) = 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 { LevelledBind
lvld_bind <- LevelEnv -> CoreBind -> LvlM LevelledBind
lvlTopBind LevelEnv
env CoreBind
b
           ; [LevelledBind]
lvld_binds <- CoreProgram -> UniqSM [LevelledBind]
do_them CoreProgram
bs
           ; [LevelledBind] -> UniqSM [LevelledBind]
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LevelledBind
lvld_bind LevelledBind -> [LevelledBind] -> [LevelledBind]
forall a. a -> [a] -> [a]
: [LevelledBind]
lvld_binds) }
lvlTopBind :: LevelEnv -> Bind Id -> LvlM LevelledBind
lvlTopBind :: LevelEnv -> CoreBind -> LvlM LevelledBind
lvlTopBind LevelEnv
env (NonRec Id
bndr Expr Id
rhs)
  = do { (LevelledBndr
bndr', LevelledExpr
rhs') <- LevelEnv
-> RecFlag -> Id -> Expr Id -> LvlM (LevelledBndr, LevelledExpr)
lvl_top LevelEnv
env RecFlag
NonRecursive Id
bndr Expr Id
rhs
       ; LevelledBind -> LvlM LevelledBind
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LevelledBndr -> LevelledExpr -> LevelledBind
forall b. b -> Expr b -> Bind b
NonRec LevelledBndr
bndr' LevelledExpr
rhs') }
lvlTopBind LevelEnv
env (Rec [(Id, Expr Id)]
pairs)
  = do { [(LevelledBndr, LevelledExpr)]
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
       ; LevelledBind -> LvlM LevelledBind
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(LevelledBndr, LevelledExpr)] -> LevelledBind
forall b. [(b, Expr b)] -> Bind b
Rec [(LevelledBndr, LevelledExpr)]
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 { LevelledExpr
rhs' <- LevelEnv
-> RecFlag
-> Bool
-> Maybe Int
-> CoreExprWithFVs
-> LvlM LevelledExpr
lvlRhs LevelEnv
env RecFlag
is_rec (Id -> Bool
isDeadEndId Id
bndr)
                                   Maybe Int
forall a. Maybe a
Nothing  
                                   (Expr Id -> CoreExprWithFVs
freeVars Expr Id
rhs)
       ; (LevelledBndr, LevelledExpr) -> LvlM (LevelledBndr, LevelledExpr)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Level -> Id -> LevelledBndr
stayPut Level
tOP_LEVEL Id
bndr, LevelledExpr
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
GHC.Core.Subst.substTy (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 (HasCallStack => 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
    LevelledExpr
expr' <- LevelEnv -> CoreExprWithFVs -> LvlM LevelledExpr
lvlNonTailExpr LevelEnv
env CoreExprWithFVs
expr
    LevelledExpr -> LvlM LevelledExpr
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LevelledExpr -> Coercion -> LevelledExpr
forall b. Expr b -> Coercion -> Expr b
Cast LevelledExpr
expr' (HasCallStack => Subst -> Coercion -> Coercion
Subst -> Coercion -> Coercion
substCo (LevelEnv -> Subst
le_subst LevelEnv
env) Coercion
co))
lvlExpr LevelEnv
env (FVAnn
_, AnnTick CoreTickish
tickish CoreExprWithFVs
expr) = do
    LevelledExpr
expr' <- LevelEnv -> CoreExprWithFVs -> LvlM LevelledExpr
lvlNonTailExpr LevelEnv
env CoreExprWithFVs
expr
    let tickish' :: CoreTickish
tickish' = Subst -> CoreTickish -> CoreTickish
substTickish (LevelEnv -> Subst
le_subst LevelEnv
env) CoreTickish
tickish
    LevelledExpr -> LvlM LevelledExpr
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreTickish -> LevelledExpr -> LevelledExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
tickish' LevelledExpr
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 { LevelledExpr
new_body <- LevelEnv -> Bool -> CoreExprWithFVs -> LvlM LevelledExpr
lvlNonTailMFE LevelEnv
new_env Bool
True CoreExprWithFVs
body
       ; LevelledExpr -> LvlM LevelledExpr
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([LevelledBndr] -> LevelledExpr -> LevelledExpr
forall b. [b] -> Expr b -> Expr b
mkLams [LevelledBndr]
new_bndrs LevelledExpr
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 { (LevelledBind
bind', LevelEnv
new_env) <- LevelEnv -> AnnBind Id FVAnn -> LvlM (LevelledBind, LevelEnv)
lvlBind LevelEnv
env AnnBind Id FVAnn
bind
       ; LevelledExpr
body' <- LevelEnv -> CoreExprWithFVs -> LvlM LevelledExpr
lvlExpr LevelEnv
new_env CoreExprWithFVs
body
           
           
           
       ; LevelledExpr -> LvlM LevelledExpr
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LevelledBind -> LevelledExpr -> LevelledExpr
forall b. Bind b -> Expr b -> Expr b
Let LevelledBind
bind' LevelledExpr
body') }
lvlExpr LevelEnv
env (FVAnn
_, AnnCase CoreExprWithFVs
scrut Id
case_bndr Type
ty [AnnAlt Id FVAnn]
alts)
  = do { LevelledExpr
scrut' <- LevelEnv -> Bool -> CoreExprWithFVs -> LvlM LevelledExpr
lvlNonTailMFE LevelEnv
env Bool
True CoreExprWithFVs
scrut
       ; LevelEnv
-> FVAnn
-> LevelledExpr
-> Id
-> Type
-> [AnnAlt Id FVAnn]
-> LvlM LevelledExpr
lvlCase LevelEnv
env (CoreExprWithFVs -> FVAnn
freeVarsOf CoreExprWithFVs
scrut) LevelledExpr
scrut' Id
case_bndr Type
ty [AnnAlt Id FVAnn]
alts }
lvlNonTailExpr :: LevelEnv             
               -> CoreExprWithFVs      
               -> LvlM LevelledExpr    
lvlNonTailExpr :: LevelEnv -> CoreExprWithFVs -> LvlM LevelledExpr
lvlNonTailExpr LevelEnv
env CoreExprWithFVs
expr
  = LevelEnv -> CoreExprWithFVs -> LvlM LevelledExpr
lvlExpr (LevelEnv -> LevelEnv
placeJoinCeiling 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 { [LevelledExpr]
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
       ; LevelledExpr -> LvlM LevelledExpr
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ((LevelledExpr -> LevelledExpr -> LevelledExpr)
-> LevelledExpr -> [LevelledExpr] -> LevelledExpr
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' LevelledExpr -> LevelledExpr -> LevelledExpr
forall b. Expr b -> Expr b -> Expr b
App (LevelEnv -> Id -> LevelledExpr
lookupVar LevelEnv
env Id
fn) [LevelledExpr]
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 { [LevelledExpr]
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
        ; LevelledExpr
lapp'  <- LevelEnv -> Bool -> CoreExprWithFVs -> LvlM LevelledExpr
lvlNonTailMFE LevelEnv
env Bool
False CoreExprWithFVs
lapp
        ; LevelledExpr -> LvlM LevelledExpr
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ((LevelledExpr -> LevelledExpr -> LevelledExpr)
-> LevelledExpr -> [LevelledExpr] -> LevelledExpr
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' LevelledExpr -> LevelledExpr -> LevelledExpr
forall b. Expr b -> Expr b -> Expr b
App LevelledExpr
lapp' [LevelledExpr]
rargs') }
  | Bool
otherwise
  = do { ([Demand]
_, [LevelledExpr]
args') <- ([Demand] -> CoreExprWithFVs -> UniqSM ([Demand], LevelledExpr))
-> [Demand]
-> [CoreExprWithFVs]
-> UniqSM ([Demand], [LevelledExpr])
forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM [Demand] -> CoreExprWithFVs -> UniqSM ([Demand], LevelledExpr)
lvl_arg [Demand]
stricts [CoreExprWithFVs]
args
            
            
       ; LevelledExpr -> LvlM LevelledExpr
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ((LevelledExpr -> LevelledExpr -> LevelledExpr)
-> LevelledExpr -> [LevelledExpr] -> LevelledExpr
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' LevelledExpr -> LevelledExpr -> LevelledExpr
forall b. Expr b -> Expr b -> Expr b
App (LevelEnv -> Id -> LevelledExpr
lookupVar LevelEnv
env Id
fn) [LevelledExpr]
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
    stricts :: [Demand]   
    stricts :: [Demand]
stricts = case DmdSig -> ([Demand], Divergence)
splitDmdSig (Id -> DmdSig
idDmdSig Id
fn) of
                ([Demand]
arg_ds, Divergence
_) | [Demand]
arg_ds [Demand] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthExceeds` Int
n_val_args
                            -> []
                            | Bool
otherwise
                            -> [Demand]
arg_ds
    
    
    
    (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. String -> a
panic String
"GHC.Core.Opt.SetLevels.lvlExpr.left"
    is_val_arg :: CoreExprWithFVs -> Bool
    is_val_arg :: CoreExprWithFVs -> Bool
is_val_arg (FVAnn
_, AnnType {}) = Bool
False
    is_val_arg CoreExprWithFVs
_               = Bool
True
    lvl_arg :: [Demand] -> CoreExprWithFVs -> LvlM ([Demand], LevelledExpr)
    lvl_arg :: [Demand] -> CoreExprWithFVs -> UniqSM ([Demand], LevelledExpr)
lvl_arg [Demand]
strs CoreExprWithFVs
arg | (Demand
str1 : [Demand]
strs') <- [Demand]
strs
                     , CoreExprWithFVs -> Bool
is_val_arg CoreExprWithFVs
arg
                     = do { LevelledExpr
arg' <- LevelEnv -> Bool -> CoreExprWithFVs -> LvlM LevelledExpr
lvlMFE LevelEnv
env (Demand -> Bool
isStrUsedDmd Demand
str1) CoreExprWithFVs
arg
                          ; ([Demand], LevelledExpr) -> UniqSM ([Demand], LevelledExpr)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Demand]
strs', LevelledExpr
arg') }
                     | Bool
otherwise
                     = do { LevelledExpr
arg' <- LevelEnv -> Bool -> CoreExprWithFVs -> LvlM LevelledExpr
lvlMFE LevelEnv
env Bool
False CoreExprWithFVs
arg
                          ; ([Demand], LevelledExpr) -> UniqSM ([Demand], LevelledExpr)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Demand]
strs, LevelledExpr
arg') }
lvlApp LevelEnv
env CoreExprWithFVs
_ (CoreExprWithFVs
fun, [CoreExprWithFVs]
args)
  =  
     
     do { [LevelledExpr]
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
        ; LevelledExpr
fun'  <- LevelEnv -> CoreExprWithFVs -> LvlM LevelledExpr
lvlNonTailExpr LevelEnv
env CoreExprWithFVs
fun
        ; LevelledExpr -> LvlM LevelledExpr
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ((LevelledExpr -> LevelledExpr -> LevelledExpr)
-> LevelledExpr -> [LevelledExpr] -> LevelledExpr
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' LevelledExpr -> LevelledExpr -> LevelledExpr
forall b. Expr b -> Expr b -> Expr b
App LevelledExpr
fun' [LevelledExpr]
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
Many <- Id -> Type
idMult Id
case_bndr     
  =     
        
    do { (LevelEnv
env1, (Id
case_bndr' : [Id]
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
rhs_env = LevelEnv -> Id -> LevelledExpr -> LevelEnv
extendCaseBndrEnv LevelEnv
env1 Id
case_bndr LevelledExpr
scrut'
       ; LevelledExpr
body' <- LevelEnv -> Bool -> CoreExprWithFVs -> LvlM LevelledExpr
lvlMFE LevelEnv
rhs_env Bool
True CoreExprWithFVs
body
       ; let alt' :: Alt LevelledBndr
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'
       ; LevelledExpr -> LvlM LevelledExpr
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LevelledExpr
-> LevelledBndr -> Type -> [Alt LevelledBndr] -> LevelledExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case LevelledExpr
scrut' (Id -> FloatSpec -> LevelledBndr
forall t. Id -> t -> TaggedBndr t
TB Id
case_bndr' (Level -> FloatSpec
FloatMe Level
dest_lvl)) Type
ty' [Alt LevelledBndr
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'
       ; [Alt LevelledBndr]
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
       ; LevelledExpr -> LvlM LevelledExpr
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LevelledExpr
-> LevelledBndr -> Type -> [Alt LevelledBndr] -> LevelledExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case LevelledExpr
scrut' LevelledBndr
case_bndr' Type
ty' [Alt LevelledBndr]
alts') }
  where
    ty' :: Type
ty' = Subst -> Type -> Type
substTy (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 { LevelledExpr
rhs' <- LevelEnv -> Bool -> CoreExprWithFVs -> LvlM LevelledExpr
lvlMFE LevelEnv
new_env Bool
True CoreExprWithFVs
rhs
           ; Alt LevelledBndr -> UniqSM (Alt LevelledBndr)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (AltCon -> [LevelledBndr] -> LevelledExpr -> Alt LevelledBndr
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [LevelledBndr]
bs' LevelledExpr
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 -> LevelEnv
placeJoinCeiling 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
GHC.Core.Subst.substTy (LevelEnv -> Subst
le_subst LevelEnv
env) Type
ty))
lvlMFE LevelEnv
env Bool
strict_ctxt (FVAnn
_, AnnTick CoreTickish
t CoreExprWithFVs
e)
  = do { LevelledExpr
e' <- LevelEnv -> Bool -> CoreExprWithFVs -> LvlM LevelledExpr
lvlMFE LevelEnv
env Bool
strict_ctxt CoreExprWithFVs
e
       ; let t' :: CoreTickish
t' = Subst -> CoreTickish -> CoreTickish
substTickish (LevelEnv -> Subst
le_subst LevelEnv
env) CoreTickish
t
       ; LevelledExpr -> LvlM LevelledExpr
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreTickish -> LevelledExpr -> LevelledExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t' LevelledExpr
e') }
lvlMFE LevelEnv
env Bool
strict_ctxt (FVAnn
_, AnnCast CoreExprWithFVs
e (FVAnn
_, Coercion
co))
  = do  { LevelledExpr
e' <- LevelEnv -> Bool -> CoreExprWithFVs -> LvlM LevelledExpr
lvlMFE LevelEnv
env Bool
strict_ctxt CoreExprWithFVs
e
        ; LevelledExpr -> LvlM LevelledExpr
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LevelledExpr -> Coercion -> LevelledExpr
forall b. Expr b -> Coercion -> Expr b
Cast LevelledExpr
e' (HasCallStack => Subst -> Coercion -> Coercion
Subst -> Coercion -> Coercion
substCo (LevelEnv -> Subst
le_subst LevelEnv
env) Coercion
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
  |  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 (Type -> Bool
typeHasFixedRuntimeRep ((() :: Constraint) => Expr Id -> Type
Expr Id -> Type
exprType Expr Id
expr))
         
         
         
  Bool -> Bool -> Bool
|| Expr Id -> [Id] -> Bool
notWorthFloating Expr Id
expr [Id]
abs_vars
  Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
float_me
  =     
    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 { LevelledExpr
expr1 <- [Id]
-> Level
-> LevelEnv
-> RecFlag
-> Bool
-> Maybe Int
-> CoreExprWithFVs
-> LvlM LevelledExpr
lvlFloatRhs [Id]
abs_vars Level
dest_lvl LevelEnv
rhs_env RecFlag
NonRecursive
                              (Maybe (Int, DmdSig) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Int, DmdSig)
mb_bot_str)
                              Maybe Int
forall a. Maybe a
join_arity_maybe
                              CoreExprWithFVs
ann_expr
                  
       ; Id
var <- LevelledExpr -> Maybe Int -> Bool -> LvlM Id
newLvlVar LevelledExpr
expr1 Maybe Int
forall a. Maybe a
join_arity_maybe Bool
is_mk_static
       ; let var2 :: Id
var2 = Id -> Int -> Maybe (Int, DmdSig) -> Id
annotateBotStr Id
var Int
float_n_lams Maybe (Int, DmdSig)
mb_bot_str
       ; LevelledExpr -> LvlM LevelledExpr
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LevelledBind -> LevelledExpr -> LevelledExpr
forall b. Bind b -> Expr b -> Expr b
Let (LevelledBndr -> LevelledExpr -> LevelledBind
forall b. b -> Expr b -> Bind b
NonRec (Id -> FloatSpec -> LevelledBndr
forall t. Id -> t -> TaggedBndr t
TB Id
var2 (Level -> FloatSpec
FloatMe Level
dest_lvl)) LevelledExpr
expr1)
                     (LevelledExpr -> [Id] -> LevelledExpr
forall b. Expr b -> [Id] -> Expr b
mkVarApps (Id -> LevelledExpr
forall b. Id -> Expr b
Var Id
var2) [Id]
abs_vars)) }
  
  
  
  
  | Bool
escapes_value_lam
  , Bool -> Bool
not Bool
expr_ok_for_spec 
                         
  , Just (TyCon
tc, [Type]
_) <- (() :: Constraint) => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
expr_ty
  , Just DataCon
dc <- TyCon -> Maybe DataCon
boxingDataCon_maybe TyCon
tc
  , let dc_res_ty :: Type
dc_res_ty = DataCon -> Type
dataConOrigResTy DataCon
dc  
        [Id
bx_bndr, Id
ubx_bndr] = [Type] -> [Id]
mkTemplateLocals [Type
dc_res_ty, Type
expr_ty]
  = do { LevelledExpr
expr1 <- LevelEnv -> CoreExprWithFVs -> LvlM LevelledExpr
lvlExpr LevelEnv
rhs_env CoreExprWithFVs
ann_expr
       ; let l1r :: Level
l1r       = LevelEnv -> Level
incMinorLvlFrom LevelEnv
rhs_env
             float_rhs :: LevelledExpr
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
dc_res_ty
                             [AltCon -> [LevelledBndr] -> LevelledExpr -> Alt LevelledBndr
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] (DataCon -> [LevelledExpr] -> LevelledExpr
forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
dc [Id -> LevelledExpr
forall b. Id -> Expr b
Var Id
ubx_bndr])]
       ; Id
var <- LevelledExpr -> Maybe Int -> Bool -> LvlM Id
newLvlVar LevelledExpr
float_rhs Maybe Int
forall a. Maybe a
Nothing Bool
is_mk_static
       ; let l1u :: Level
l1u      = LevelEnv -> Level
incMinorLvlFrom LevelEnv
env
             use_expr :: LevelledExpr
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
dc) [Level -> Id -> LevelledBndr
stayPut Level
l1u Id
ubx_bndr] (Id -> LevelledExpr
forall b. Id -> Expr b
Var Id
ubx_bndr)]
       ; LevelledExpr -> LvlM LevelledExpr
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LevelledBind -> LevelledExpr -> LevelledExpr
forall b. Bind b -> Expr b -> Expr b
Let (LevelledBndr -> LevelledExpr -> LevelledBind
forall b. b -> Expr b -> Bind b
NonRec (Id -> FloatSpec -> LevelledBndr
forall t. Id -> t -> TaggedBndr t
TB Id
var (Level -> FloatSpec
FloatMe Level
dest_lvl)) LevelledExpr
float_rhs)
                     LevelledExpr
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      = (() :: Constraint) => 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 :: Bool
is_bot       = Maybe (Int, DmdSig) -> Bool
forall s. Maybe (Int, s) -> Bool
isBottomThunk Maybe (Int, DmdSig)
mb_bot_str
    is_function :: Bool
is_function  = CoreExprWithFVs -> Bool
isFunction CoreExprWithFVs
ann_expr
    mb_bot_str :: Maybe (Int, DmdSig)
mb_bot_str   = Expr Id -> Maybe (Int, DmdSig)
exprBotStrictness_maybe Expr Id
expr
                           
                           
    expr_ok_for_spec :: Bool
expr_ok_for_spec = Expr Id -> Bool
exprOkForSpeculation Expr Id
expr
    dest_lvl :: Level
dest_lvl     = LevelEnv -> FVAnn -> TyCoVarSet -> Bool -> Bool -> Bool -> Level
destLevel LevelEnv
env FVAnn
fvs TyCoVarSet
fvs_ty Bool
is_function Bool
is_bot Bool
False
    abs_vars :: [Id]
abs_vars     = Level -> LevelEnv -> FVAnn -> [Id]
abstractVars Level
dest_lvl LevelEnv
env FVAnn
fvs
    
    
    
    
    
    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
    join_arity_maybe :: Maybe a
join_arity_maybe = Maybe a
forall a. Maybe a
Nothing
    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 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
|| Bool
is_bot Bool -> Bool -> Bool
|| Expr Id -> Bool
exprIsHNF Expr Id
expr)
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)
isBottomThunk :: Maybe (Arity, s) -> Bool
isBottomThunk :: forall s. Maybe (Int, s) -> Bool
isBottomThunk (Just (Int
0, s
_)) = Bool
True   
isBottomThunk Maybe (Int, s)
_             = Bool
False
annotateBotStr :: Id -> Arity -> Maybe (Arity, DmdSig) -> Id
annotateBotStr :: Id -> Int -> Maybe (Int, DmdSig) -> Id
annotateBotStr Id
id Int
n_extra Maybe (Int, DmdSig)
mb_str
  = case Maybe (Int, DmdSig)
mb_str of
      Maybe (Int, DmdSig)
Nothing           -> Id
id
      Just (Int
arity, DmdSig
sig) -> 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
sig)
                              Id -> CprSig -> Id
`setIdCprSig`    Int -> Cpr -> CprSig
mkCprSig (Int
arity Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n_extra) Cpr
botCpr
notWorthFloating :: CoreExpr -> [Var] -> Bool
notWorthFloating :: Expr Id -> [Id] -> Bool
notWorthFloating Expr Id
e [Id]
abs_vars
  = Expr Id -> Int -> Bool
forall {a} {b}. (Ord a, Num a) => Expr b -> 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 b -> 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 (Tick CoreTickish
t Expr b
e) a
n  = Bool -> Bool
not (CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode CoreTickish
t) Bool -> Bool -> Bool
&& Expr b -> a -> Bool
go Expr b
e a
n
    go (Cast Expr b
e Coercion
_)  a
n = Expr b -> a -> Bool
go Expr b
e a
n
    go (App Expr b
e Expr b
arg) a
n
       
       | Type {} <- Expr b
arg = Expr b -> a -> Bool
go Expr b
e a
n
       | a
na -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
0           = Bool
False
       | Expr b -> Bool
forall b. Expr b -> Bool
is_triv Expr b
arg    = Expr b -> a -> Bool
go Expr b
e (a
na -> a -> a
forall a. Num a => a -> a -> a
-a
1)
       | Bool
otherwise      = Bool
False
    go Expr b
_ a
_              = Bool
False
    is_triv :: Expr b -> Bool
is_triv (Lit {})              = Bool
True        
    is_triv (Var {})              = Bool
True        
    is_triv (Cast Expr b
e Coercion
_)            = Expr b -> Bool
is_triv Expr b
e
    is_triv (App Expr b
e (Type {}))     = Expr b -> Bool
is_triv Expr b
e   
    is_triv (Tick CoreTickish
t Expr b
e)            = Bool -> Bool
not (CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode CoreTickish
t) Bool -> Bool -> Bool
&& Expr b -> Bool
is_triv Expr b
e
    is_triv Expr b
_                     = 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 -> Level -> Bool
profitableFloat LevelEnv
env Level
dest_lvl)
  Bool -> Bool -> Bool
|| (Level -> Bool
isTopLvl Level
dest_lvl Bool -> Bool -> Bool
&& Bool -> Bool
not (Expr Id -> Type -> Bool
exprIsTopLevelBindable Expr Id
deann_rhs Type
bndr_ty))
          
          
          
  = 
    do { LevelledExpr
rhs' <- LevelEnv
-> RecFlag
-> Bool
-> Maybe Int
-> CoreExprWithFVs
-> LvlM LevelledExpr
lvlRhs LevelEnv
env RecFlag
NonRecursive Bool
is_bot Maybe Int
mb_join_arity CoreExprWithFVs
rhs
       ; let  bind_lvl :: Level
bind_lvl        = Level -> Level
incMinorLvl (LevelEnv -> Level
le_ctxt_lvl LevelEnv
env)
              (LevelEnv
env', [LevelledBndr
bndr']) = RecFlag -> LevelEnv -> Level -> [Id] -> (LevelEnv, [LevelledBndr])
substAndLvlBndrs RecFlag
NonRecursive LevelEnv
env Level
bind_lvl [Id
bndr]
       ; (LevelledBind, LevelEnv) -> LvlM (LevelledBind, LevelEnv)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LevelledBndr -> LevelledExpr -> LevelledBind
forall b. b -> Expr b -> Bind b
NonRec LevelledBndr
bndr' LevelledExpr
rhs', LevelEnv
env') }
  
  | [Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
abs_vars
  = do {  
         LevelledExpr
rhs' <- [Id]
-> Level
-> LevelEnv
-> RecFlag
-> Bool
-> Maybe Int
-> CoreExprWithFVs
-> LvlM LevelledExpr
lvlFloatRhs [] Level
dest_lvl LevelEnv
env RecFlag
NonRecursive
                             Bool
is_bot Maybe Int
mb_join_arity CoreExprWithFVs
rhs
       ; (LevelEnv
env', [Id
bndr']) <- RecFlag -> LevelEnv -> Level -> [Id] -> LvlM (LevelEnv, [Id])
cloneLetVars RecFlag
NonRecursive LevelEnv
env Level
dest_lvl [Id
bndr]
       ; let bndr2 :: Id
bndr2 = Id -> Int -> Maybe (Int, DmdSig) -> Id
annotateBotStr Id
bndr' Int
0 Maybe (Int, DmdSig)
mb_bot_str
       ; (LevelledBind, LevelEnv) -> LvlM (LevelledBind, LevelEnv)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LevelledBndr -> LevelledExpr -> LevelledBind
forall b. b -> Expr b -> Bind b
NonRec (Id -> FloatSpec -> LevelledBndr
forall t. Id -> t -> TaggedBndr t
TB Id
bndr2 (Level -> FloatSpec
FloatMe Level
dest_lvl)) LevelledExpr
rhs', LevelEnv
env') }
  | Bool
otherwise
  = do {  
         LevelledExpr
rhs' <- [Id]
-> Level
-> LevelEnv
-> RecFlag
-> Bool
-> Maybe Int
-> CoreExprWithFVs
-> LvlM LevelledExpr
lvlFloatRhs [Id]
abs_vars Level
dest_lvl LevelEnv
env RecFlag
NonRecursive
                             Bool
is_bot Maybe Int
mb_join_arity CoreExprWithFVs
rhs
       ; (LevelEnv
env', [Id
bndr']) <- Level -> LevelEnv -> [Id] -> [Id] -> LvlM (LevelEnv, [Id])
newPolyBndrs Level
dest_lvl LevelEnv
env [Id]
abs_vars [Id
bndr]
       ; let bndr2 :: Id
bndr2 = Id -> Int -> Maybe (Int, DmdSig) -> Id
annotateBotStr Id
bndr' Int
n_extra Maybe (Int, DmdSig)
mb_bot_str
       ; (LevelledBind, LevelEnv) -> LvlM (LevelledBind, LevelEnv)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LevelledBndr -> LevelledExpr -> LevelledBind
forall b. b -> Expr b -> Bind b
NonRec (Id -> FloatSpec -> LevelledBndr
forall t. Id -> t -> TaggedBndr t
TB Id
bndr2 (Level -> FloatSpec
FloatMe Level
dest_lvl)) LevelledExpr
rhs', LevelEnv
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 -> Bool -> Level
destLevel LevelEnv
env FVAnn
bind_fvs TyCoVarSet
ty_fvs (CoreExprWithFVs -> Bool
isFunction CoreExprWithFVs
rhs) Bool
is_bot Bool
is_join
    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)
mb_bot_str = Expr Id -> Maybe (Int, DmdSig)
exprBotStrictness_maybe Expr Id
deann_rhs
    is_bot :: Bool
is_bot     = Maybe (Int, DmdSig) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Int, DmdSig)
mb_bot_str
        
    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 :: Maybe Int
mb_join_arity = Id -> Maybe Int
isJoinId_maybe Id
bndr
    is_join :: Bool
is_join       = Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust Maybe Int
mb_join_arity
lvlBind LevelEnv
env (AnnRec [(Id, CoreExprWithFVs)]
pairs)
  |  LevelEnv -> Bool
floatTopLvlOnly LevelEnv
env Bool -> Bool -> Bool
&& Bool -> Bool
not (Level -> Bool
isTopLvl Level
dest_lvl)
         
  Bool -> Bool -> Bool
|| Bool -> Bool
not (LevelEnv -> Level -> Bool
profitableFloat LevelEnv
env Level
dest_lvl)
  Bool -> Bool -> Bool
|| (Level -> Bool
isTopLvl Level
dest_lvl Bool -> Bool -> Bool
&& (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)
       
       
       
       
       
  =    
    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
-> Maybe Int
-> CoreExprWithFVs
-> LvlM LevelledExpr
lvlRhs LevelEnv
env' RecFlag
Recursive Bool
is_bot (Id -> Maybe Int
isJoinId_maybe Id
b) CoreExprWithFVs
r
       ; [LevelledExpr]
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
       ; (LevelledBind, LevelEnv) -> LvlM (LevelledBind, LevelEnv)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(LevelledBndr, LevelledExpr)] -> LevelledBind
forall b. [(b, Expr b)] -> Bind b
Rec ([LevelledBndr]
bndrs' [LevelledBndr] -> [LevelledExpr] -> [(LevelledBndr, LevelledExpr)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [LevelledExpr]
rhss'), LevelEnv
env') }
  
  | [Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
abs_vars
  = do { (LevelEnv
new_env, [Id]
new_bndrs) <- RecFlag -> LevelEnv -> Level -> [Id] -> LvlM (LevelEnv, [Id])
cloneLetVars RecFlag
Recursive LevelEnv
env Level
dest_lvl [Id]
bndrs
       ; [LevelledExpr]
new_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 (LevelEnv -> (Id, CoreExprWithFVs) -> LvlM LevelledExpr
do_rhs LevelEnv
new_env) [(Id, CoreExprWithFVs)]
pairs
       ; (LevelledBind, LevelEnv) -> LvlM (LevelledBind, LevelEnv)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ( [(LevelledBndr, LevelledExpr)] -> LevelledBind
forall b. [(b, Expr b)] -> Bind b
Rec ([Id -> FloatSpec -> LevelledBndr
forall t. Id -> t -> TaggedBndr t
TB Id
b (Level -> FloatSpec
FloatMe Level
dest_lvl) | Id
b <- [Id]
new_bndrs] [LevelledBndr] -> [LevelledExpr] -> [(LevelledBndr, LevelledExpr)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [LevelledExpr]
new_rhss)
                , LevelEnv
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
    (LevelEnv
rhs_env', [Id
new_bndr]) <- RecFlag -> LevelEnv -> Level -> [Id] -> LvlM (LevelEnv, [Id])
cloneLetVars RecFlag
Recursive LevelEnv
rhs_env Level
rhs_lvl [Id
bndr]
    let
        ([Id]
lam_bndrs, CoreExprWithFVs
rhs_body)   = CoreExprWithFVs -> ([Id], CoreExprWithFVs)
forall bndr annot.
AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
collectAnnBndrs CoreExprWithFVs
rhs
        (LevelEnv
body_env1, [Id]
lam_bndrs1) = RecFlag -> LevelEnv -> [Id] -> (LevelEnv, [Id])
substBndrsSL RecFlag
NonRecursive LevelEnv
rhs_env' [Id]
lam_bndrs
        (LevelEnv
body_env2, [LevelledBndr]
lam_bndrs2) = LevelEnv -> Level -> [Id] -> (LevelEnv, [LevelledBndr])
lvlLamBndrs LevelEnv
body_env1 Level
rhs_lvl [Id]
lam_bndrs1
    LevelledExpr
new_rhs_body <- LevelEnv
-> RecFlag
-> Bool
-> Maybe Int
-> CoreExprWithFVs
-> LvlM LevelledExpr
lvlRhs LevelEnv
body_env2 RecFlag
Recursive Bool
is_bot (Id -> Maybe Int
get_join Id
bndr) CoreExprWithFVs
rhs_body
    (LevelEnv
poly_env, [Id
poly_bndr]) <- Level -> LevelEnv -> [Id] -> [Id] -> LvlM (LevelEnv, [Id])
newPolyBndrs Level
dest_lvl LevelEnv
env [Id]
abs_vars [Id
bndr]
    (LevelledBind, LevelEnv) -> LvlM (LevelledBind, LevelEnv)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(LevelledBndr, LevelledExpr)] -> LevelledBind
forall b. [(b, Expr b)] -> Bind b
Rec [(Id -> FloatSpec -> LevelledBndr
forall t. Id -> t -> TaggedBndr t
TB Id
poly_bndr (Level -> FloatSpec
FloatMe Level
dest_lvl)
                 , [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
$
                   [LevelledBndr] -> LevelledExpr -> LevelledExpr
forall b. [b] -> Expr b -> Expr b
mkLams [LevelledBndr]
lam_bndrs2 (LevelledExpr -> LevelledExpr) -> LevelledExpr -> LevelledExpr
forall a b. (a -> b) -> a -> b
$
                   LevelledBind -> LevelledExpr -> LevelledExpr
forall b. Bind b -> Expr b -> Expr b
Let ([(LevelledBndr, LevelledExpr)] -> LevelledBind
forall b. [(b, Expr b)] -> Bind b
Rec [( Id -> FloatSpec -> LevelledBndr
forall t. Id -> t -> TaggedBndr t
TB Id
new_bndr (Level -> FloatSpec
StayPut Level
rhs_lvl)
                             , [LevelledBndr] -> LevelledExpr -> LevelledExpr
forall b. [b] -> Expr b -> Expr b
mkLams [LevelledBndr]
lam_bndrs2 LevelledExpr
new_rhs_body)])
                       (LevelledExpr -> [Id] -> LevelledExpr
forall b. Expr b -> [Id] -> Expr b
mkVarApps (Id -> LevelledExpr
forall b. Id -> Expr b
Var Id
new_bndr) [Id]
lam_bndrs1))]
           , LevelEnv
poly_env)
  | Bool
otherwise  
  = do { (LevelEnv
new_env, [Id]
new_bndrs) <- Level -> LevelEnv -> [Id] -> [Id] -> LvlM (LevelEnv, [Id])
newPolyBndrs Level
dest_lvl LevelEnv
env [Id]
abs_vars [Id]
bndrs
       ; [LevelledExpr]
new_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 (LevelEnv -> (Id, CoreExprWithFVs) -> LvlM LevelledExpr
do_rhs LevelEnv
new_env) [(Id, CoreExprWithFVs)]
pairs
       ; (LevelledBind, LevelEnv) -> LvlM (LevelledBind, LevelEnv)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ( [(LevelledBndr, LevelledExpr)] -> LevelledBind
forall b. [(b, Expr b)] -> Bind b
Rec ([Id -> FloatSpec -> LevelledBndr
forall t. Id -> t -> TaggedBndr t
TB Id
b (Level -> FloatSpec
FloatMe Level
dest_lvl) | Id
b <- [Id]
new_bndrs] [LevelledBndr] -> [LevelledExpr] -> [(LevelledBndr, LevelledExpr)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [LevelledExpr]
new_rhss)
                , LevelEnv
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
bndr,CoreExprWithFVs
rhs) = [Id]
-> Level
-> LevelEnv
-> RecFlag
-> Bool
-> Maybe Int
-> CoreExprWithFVs
-> LvlM LevelledExpr
lvlFloatRhs [Id]
abs_vars Level
dest_lvl LevelEnv
env RecFlag
Recursive
                                        Bool
is_bot (Id -> Maybe Int
get_join Id
bndr)
                                        CoreExprWithFVs
rhs
    get_join :: Id -> Maybe Int
get_join Id
bndr | Bool
need_zap  = Maybe Int
forall a. Maybe a
Nothing
                  | Bool
otherwise = Id -> Maybe Int
isJoinId_maybe Id
bndr
    need_zap :: Bool
need_zap = Level
dest_lvl Level -> Level -> Bool
`ltLvl` LevelEnv -> Level
joinCeilingLevel LevelEnv
env
        
    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 -> Bool -> Level
destLevel LevelEnv
env FVAnn
bind_fvs TyCoVarSet
ty_fvs Bool
is_fun Bool
is_bot Bool
is_join
    abs_vars :: [Id]
abs_vars = Level -> LevelEnv -> FVAnn -> [Id]
abstractVars Level
dest_lvl LevelEnv
env FVAnn
bind_fvs
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                      
lvlRhs :: LevelEnv
       -> RecFlag
       -> Bool               
       -> Maybe JoinArity
       -> CoreExprWithFVs
       -> LvlM LevelledExpr
lvlRhs :: LevelEnv
-> RecFlag
-> Bool
-> Maybe Int
-> CoreExprWithFVs
-> LvlM LevelledExpr
lvlRhs LevelEnv
env RecFlag
rec_flag Bool
is_bot Maybe Int
mb_join_arity CoreExprWithFVs
expr
  = [Id]
-> Level
-> LevelEnv
-> RecFlag
-> Bool
-> Maybe Int
-> CoreExprWithFVs
-> LvlM LevelledExpr
lvlFloatRhs [] (LevelEnv -> Level
le_ctxt_lvl LevelEnv
env) LevelEnv
env
                RecFlag
rec_flag Bool
is_bot Maybe Int
mb_join_arity CoreExprWithFVs
expr
lvlFloatRhs :: [OutVar] -> Level -> LevelEnv -> RecFlag
            -> Bool   
            -> Maybe JoinArity
            -> CoreExprWithFVs
            -> LvlM (Expr LevelledBndr)
lvlFloatRhs :: [Id]
-> Level
-> LevelEnv
-> RecFlag
-> Bool
-> Maybe Int
-> CoreExprWithFVs
-> LvlM LevelledExpr
lvlFloatRhs [Id]
abs_vars Level
dest_lvl LevelEnv
env RecFlag
rec Bool
is_bot Maybe Int
mb_join_arity CoreExprWithFVs
rhs
  = do { LevelledExpr
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
       ; LevelledExpr -> LvlM LevelledExpr
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([LevelledBndr] -> LevelledExpr -> LevelledExpr
forall b. [b] -> Expr b -> Expr b
mkLams [LevelledBndr]
bndrs' LevelledExpr
body') }
  where
    ([Id]
bndrs, CoreExprWithFVs
body)     | Just Int
join_arity <- Maybe Int
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') | Just Int
_ <- Maybe Int
mb_join_arity
                      = LevelEnv -> Level -> RecFlag -> [Id] -> (LevelEnv, [LevelledBndr])
lvlJoinBndrs LevelEnv
env1 Level
dest_lvl RecFlag
rec [Id]
all_bndrs
                      | Bool
otherwise
                      = case LevelEnv -> Level -> [Id] -> (LevelEnv, [LevelledBndr])
lvlLamBndrs LevelEnv
env1 Level
dest_lvl [Id]
all_bndrs of
                          (LevelEnv
env2, [LevelledBndr]
bndrs') -> (LevelEnv -> LevelEnv
placeJoinCeiling LevelEnv
env2, [LevelledBndr]
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_subst    = Subst
subst'
          , le_env :: IdEnv ([Id], LevelledExpr)
le_env      = (IdEnv ([Id], LevelledExpr)
 -> (Id, Id) -> IdEnv ([Id], LevelledExpr))
-> IdEnv ([Id], LevelledExpr)
-> [(Id, Id)]
-> IdEnv ([Id], LevelledExpr)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' IdEnv ([Id], LevelledExpr)
-> (Id, Id) -> IdEnv ([Id], LevelledExpr)
add_id  IdEnv ([Id], LevelledExpr)
id_env ([Id]
bndrs [Id] -> [Id] -> [(Id, Id)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Id]
bndrs') }
    , [Id]
bndrs')
  where
    (Subst
subst', [Id]
bndrs') = case RecFlag
is_rec of
                         RecFlag
NonRecursive -> Subst -> [Id] -> (Subst, [Id])
substBndrs    Subst
subst [Id]
bndrs
                         RecFlag
Recursive    -> Subst -> [Id] -> (Subst, [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 = Id -> Bool
isId Id
bndr Bool -> Bool -> Bool
&& Bool -> Bool
not (Id -> Bool
isProbablyOneShotLambda 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 :: Level
le_ctxt_lvl = Level
new_lvl
          , le_join_ceil :: Level
le_join_ceil = Level
new_lvl
          , le_lvl_env :: VarEnv Level
le_lvl_env  = Level -> VarEnv Level -> [Id] -> VarEnv Level
addLvls Level
new_lvl VarEnv Level
lvl_env [Id]
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   
          -> Bool   
          -> Level
destLevel :: LevelEnv -> FVAnn -> TyCoVarSet -> Bool -> Bool -> Bool -> Level
destLevel LevelEnv
env FVAnn
fvs TyCoVarSet
fvs_ty Bool
is_function Bool
is_bot Bool
is_join
  | Level -> Bool
isTopLvl Level
max_fv_id_level  
                              
  = Level
tOP_LEVEL
  | Bool
is_join  
             
  = if Level
max_fv_id_level Level -> Level -> Bool
`ltLvl` Level
join_ceiling
    then Level
join_ceiling
    else Level
max_fv_id_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
    join_ceiling :: Level
join_ceiling    = LevelEnv -> Level
joinCeilingLevel LevelEnv
env
    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 elt a key. (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 -> Level
le_join_ceil:: 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_join_ceil :: Level
le_join_ceil = String -> Level
forall a. String -> a
panic String
"initialEnv"
       , 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 -> [Id] -> InScopeSet
`extendInScopeSetList` CoreProgram -> [Id]
forall b. [Bind b] -> [b]
bindersOfBinds 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)
    | Type
Many <- Id -> Type
varMult Id
case_bndr
  = LevelEnv
le { le_subst :: Subst
le_subst   = Subst -> Id -> Id -> Subst
extendSubstWithVar Subst
subst Id
case_bndr Id
scrut_var
       , le_env :: IdEnv ([Id], LevelledExpr)
le_env     = IdEnv ([Id], LevelledExpr)
-> (Id, Id) -> IdEnv ([Id], LevelledExpr)
add_id IdEnv ([Id], LevelledExpr)
id_env (Id
case_bndr, Id
scrut_var) }
extendCaseBndrEnv LevelEnv
env Id
_ LevelledExpr
_ = LevelEnv
env
placeJoinCeiling :: LevelEnv -> LevelEnv
placeJoinCeiling :: LevelEnv -> LevelEnv
placeJoinCeiling le :: LevelEnv
le@(LE { le_ctxt_lvl :: LevelEnv -> Level
le_ctxt_lvl = Level
lvl })
  = LevelEnv
le { le_ctxt_lvl :: Level
le_ctxt_lvl = Level
lvl', le_join_ceil :: Level
le_join_ceil = Level
lvl' }
  where
    lvl' :: Level
lvl' = Level -> Level
asJoinCeilLvl (Level -> Level
incMinorLvl Level
lvl)
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
joinCeilingLevel :: LevelEnv -> Level
joinCeilingLevel :: LevelEnv -> Level
joinCeilingLevel = LevelEnv -> Level
le_join_ceil
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
$
    (() :: Constraint) => 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 (Id -> Unfolding
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 { [Unique]
uniqs <- UniqSM [Unique]
forall (m :: * -> *). MonadUnique m => m [Unique]
getUniquesM
      ; let new_bndrs :: [Id]
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, Id)]
bndr_prs  = [Id]
bndrs [Id] -> [Id] -> [(Id, Id)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Id]
new_bndrs
            env' :: LevelEnv
env' = LevelEnv
env { le_lvl_env :: VarEnv Level
le_lvl_env = Level -> VarEnv Level -> [Id] -> VarEnv Level
addLvls Level
dest_lvl VarEnv Level
lvl_env [Id]
new_bndrs
                       , le_subst :: Subst
le_subst   = (Subst -> (Id, Id) -> Subst) -> Subst -> [(Id, Id)] -> Subst
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Subst -> (Id, Id) -> Subst
add_subst Subst
subst   [(Id, Id)]
bndr_prs
                       , le_env :: IdEnv ([Id], LevelledExpr)
le_env     = (IdEnv ([Id], LevelledExpr)
 -> (Id, Id) -> IdEnv ([Id], LevelledExpr))
-> IdEnv ([Id], LevelledExpr)
-> [(Id, Id)]
-> IdEnv ([Id], LevelledExpr)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' IdEnv ([Id], LevelledExpr)
-> (Id, Id) -> IdEnv ([Id], LevelledExpr)
add_id    IdEnv ([Id], LevelledExpr)
id_env  [(Id, Id)]
bndr_prs }
      ; (LevelEnv, [Id]) -> LvlM (LevelEnv, [Id])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LevelEnv
env', [Id]
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 (String -> FastString
mkFastString String
str) Unique
uniq (Id -> Type
idMult Id
bndr) Type
poly_ty
                           where
                             str :: String
str     = String
"poly_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ OccName -> String
occNameString (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
GHC.Core.Subst.substTy 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
      | Just Int
join_arity <- Id -> Maybe Int
isJoinId_maybe 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        
          -> Maybe JoinArity     
          -> Bool                
          -> LvlM Id
newLvlVar :: LevelledExpr -> Maybe Int -> Bool -> LvlM Id
newLvlVar LevelledExpr
lvld_rhs Maybe Int
join_arity_maybe Bool
is_mk_static
  = do { Unique
uniq <- UniqSM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
       ; Id -> LvlM Id
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> Id
add_join_info (Unique -> Type -> Id
mk_id Unique
uniq Type
rhs_ty))
       }
  where
    add_join_info :: Id -> Id
add_join_info Id
var = Id
var Id -> Maybe Int -> Id
`asJoinId_maybe` Maybe Int
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        = (() :: Constraint) => 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
Many 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 { UniqSupply
us <- UniqSM UniqSupply
forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
       ; let (Subst
subst', [Id]
vs') = Subst -> UniqSupply -> [Id] -> (Subst, [Id])
cloneBndrs Subst
subst UniqSupply
us [Id]
vs
             
             
             
             
             env' :: LevelEnv
env' = LevelEnv
env { le_lvl_env :: VarEnv Level
le_lvl_env   = Level -> VarEnv Level -> [Id] -> VarEnv Level
addLvls Level
new_lvl VarEnv Level
lvl_env [Id]
vs'
                        , le_subst :: Subst
le_subst     = Subst
subst'
                        , le_env :: IdEnv ([Id], LevelledExpr)
le_env       = (IdEnv ([Id], LevelledExpr)
 -> (Id, Id) -> IdEnv ([Id], LevelledExpr))
-> IdEnv ([Id], LevelledExpr)
-> [(Id, Id)]
-> IdEnv ([Id], LevelledExpr)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' IdEnv ([Id], LevelledExpr)
-> (Id, Id) -> IdEnv ([Id], LevelledExpr)
add_id IdEnv ([Id], LevelledExpr)
id_env ([Id]
vs [Id] -> [Id] -> [(Id, Id)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Id]
vs') }
       ; (LevelEnv, [Id]) -> LvlM (LevelEnv, [Id])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LevelEnv
env', [Id]
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 { UniqSupply
us <- UniqSM UniqSupply
forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
       ; let vs1 :: [Id]
vs1  = (Id -> Id) -> [Id] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Id
zap [Id]
vs
                      
             (Subst
subst', [Id]
vs2) = case RecFlag
is_rec of
                               RecFlag
NonRecursive -> Subst -> UniqSupply -> [Id] -> (Subst, [Id])
cloneBndrs      Subst
subst UniqSupply
us [Id]
vs1
                               RecFlag
Recursive    -> Subst -> UniqSupply -> [Id] -> (Subst, [Id])
cloneRecIdBndrs Subst
subst UniqSupply
us [Id]
vs1
             prs :: [(Id, Id)]
prs  = [Id]
vs [Id] -> [Id] -> [(Id, Id)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Id]
vs2
             env' :: LevelEnv
env' = LevelEnv
env { le_lvl_env :: VarEnv Level
le_lvl_env = Level -> VarEnv Level -> [Id] -> VarEnv Level
addLvls Level
dest_lvl VarEnv Level
lvl_env [Id]
vs2
                        , le_subst :: Subst
le_subst   = Subst
subst'
                        , le_env :: IdEnv ([Id], LevelledExpr)
le_env     = (IdEnv ([Id], LevelledExpr)
 -> (Id, Id) -> IdEnv ([Id], LevelledExpr))
-> IdEnv ([Id], LevelledExpr)
-> [(Id, Id)]
-> IdEnv ([Id], LevelledExpr)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' IdEnv ([Id], LevelledExpr)
-> (Id, Id) -> IdEnv ([Id], LevelledExpr)
add_id IdEnv ([Id], LevelledExpr)
id_env [(Id, Id)]
prs }
       ; (LevelEnv, [Id]) -> LvlM (LevelEnv, [Id])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LevelEnv
env', [Id]
vs2) }
  where
    zap :: Var -> Var
    zap :: Id -> Id
zap Id
v | Id -> Bool
isId Id
v    = Id -> Id
zap_join (Id -> Id
zapIdDemandInfo 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)